-/* Copyright (C) 1995,1996,1998,2000,2001,2003,2004, 2006, 2008, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000,2001,2003,2004, 2006, 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
#include "libguile/smob.h"
#include "libguile/root.h"
#include "libguile/vectors.h"
-#include "libguile/hashtab.h"
+#include "libguile/weak-table.h"
#include "libguile/programs.h"
+#include "libguile/vm-builtins.h"
#include "libguile/validate.h"
#include "libguile/procprop.h"
\f
SCM_GLOBAL_SYMBOL (scm_sym_system_procedure, "system-procedure");
-SCM_GLOBAL_SYMBOL (scm_sym_arity, "arity");
+SCM_GLOBAL_SYMBOL (scm_sym_name, "name");
-static SCM non_closure_props;
-static scm_i_pthread_mutex_t non_closure_props_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
+static SCM overrides;
-SCM
-scm_i_procedure_arity (SCM proc)
+static SCM arity_overrides;
+
+int
+scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest)
{
- int a = 0, o = 0, r = 0;
- if (SCM_IMP (proc))
- return SCM_BOOL_F;
- loop:
- switch (SCM_TYP7 (proc))
+ SCM o;
+
+ o = scm_weak_table_refq (arity_overrides, proc, SCM_BOOL_F);
+
+ if (scm_is_true (o))
{
- case scm_tc7_subr_1o:
- o = 1;
- case scm_tc7_subr_0:
- break;
- case scm_tc7_subr_2o:
- o = 1;
- case scm_tc7_subr_1:
- case scm_tc7_dsubr:
- case scm_tc7_cxr:
- a += 1;
- break;
- case scm_tc7_subr_2:
- a += 2;
- break;
- case scm_tc7_subr_3:
- a += 3;
- break;
- case scm_tc7_asubr:
- case scm_tc7_rpsubr:
- case scm_tc7_lsubr:
- r = 1;
- break;
- case scm_tc7_program:
- if (scm_i_program_arity (proc, &a, &o, &r))
- break;
- else
- return SCM_BOOL_F;
- case scm_tc7_lsubr_2:
- a += 2;
- r = 1;
- break;
- case scm_tc7_smob:
- if (SCM_SMOB_APPLICABLE_P (proc))
- {
- int type = SCM_SMOB_DESCRIPTOR (proc).gsubr_type;
- a += SCM_GSUBR_REQ (type);
- o = SCM_GSUBR_OPT (type);
- r = SCM_GSUBR_REST (type);
- break;
- }
+ *req = scm_to_int (scm_car (o));
+ *opt = scm_to_int (scm_cadr (o));
+ *rest = scm_is_true (scm_caddr (o));
+ return 1;
+ }
+
+ while (!SCM_PROGRAM_P (proc))
+ {
+ if (SCM_STRUCTP (proc))
+ {
+ if (!SCM_STRUCT_APPLICABLE_P (proc))
+ return 0;
+ proc = SCM_STRUCT_PROCEDURE (proc);
+ }
+ else if (SCM_HAS_TYP7 (proc, scm_tc7_smob))
+ {
+ if (!SCM_SMOB_APPLICABLE_P (proc))
+ return 0;
+ if (!scm_i_program_arity (SCM_SMOB_DESCRIPTOR (proc).apply_trampoline,
+ req, opt, rest))
+ return 0;
+
+ /* The trampoline gets the smob too, which users don't
+ see. */
+ *req -= 1;
+
+ return 1;
+ }
else
- {
- return SCM_BOOL_F;
- }
- case scm_tc7_gsubr:
- {
- unsigned int type = SCM_GSUBR_TYPE (proc);
- a = SCM_GSUBR_REQ (type);
- o = SCM_GSUBR_OPT (type);
- r = SCM_GSUBR_REST (type);
- break;
- }
- case scm_tc7_pws:
- proc = SCM_PROCEDURE (proc);
- goto loop;
- case scm_tcs_closures:
- proc = SCM_CLOSURE_FORMALS (proc);
- if (scm_is_null (proc))
- break;
- while (scm_is_pair (proc))
- {
- ++a;
- proc = SCM_CDR (proc);
- }
- if (!scm_is_null (proc))
- r = 1;
- break;
- case scm_tcs_struct:
- if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
- {
- r = 1;
- break;
- }
- /* FIXME applicable structs */
- return SCM_BOOL_F;
-#if 0
- proc = SCM_ENTITY_PROCEDURE (proc);
- a -= 1;
- goto loop;
-#endif
- default:
- return SCM_BOOL_F;
+ return 0;
}
- return scm_list_3 (scm_from_int (a), scm_from_int (o), scm_from_bool(r));
+
+ return scm_i_program_arity (proc, req, opt, rest);
+}
+
+SCM_DEFINE (scm_set_procedure_minimum_arity_x, "set-procedure-minimum-arity!",
+ 4, 0, 0, (SCM proc, SCM req, SCM opt, SCM rest),
+ "")
+#define FUNC_NAME s_scm_set_procedure_minimum_arity_x
+{
+ int t SCM_UNUSED;
+
+ SCM_VALIDATE_PROC (1, proc);
+ SCM_VALIDATE_INT_COPY (2, req, t);
+ SCM_VALIDATE_INT_COPY (3, opt, t);
+ SCM_VALIDATE_BOOL (4, rest);
+
+ scm_weak_table_putq_x (arity_overrides, proc, scm_list_3 (req, opt, rest));
+ return SCM_UNDEFINED;
}
+#undef FUNC_NAME
-/* FIXME: instead of the weak hash, perhaps for some kinds of procedures, use
- other means; for example subrs have their own property slot, which is unused
- at present. */
+SCM_DEFINE (scm_procedure_minimum_arity, "procedure-minimum-arity", 1, 0, 0,
+ (SCM proc),
+ "Return the \"minimum arity\" of a procedure.\n\n"
+ "If the procedure has only one arity, that arity is returned\n"
+ "as a list of three values: the number of required arguments,\n"
+ "the number of optional arguments, and a boolean indicating\n"
+ "whether or not the procedure takes rest arguments.\n\n"
+ "For a case-lambda procedure, the arity returned is the one\n"
+ "with the lowest minimum number of arguments, and the highest\n"
+ "maximum number of arguments.\n\n"
+ "If it was not possible to determine the arity of the procedure,\n"
+ "@code{#f} is returned.")
+#define FUNC_NAME s_scm_procedure_minimum_arity
+{
+ int req, opt, rest;
+
+ if (scm_i_procedure_arity (proc, &req, &opt, &rest))
+ return scm_list_3 (scm_from_int (req),
+ scm_from_int (opt),
+ scm_from_bool (rest));
+ else
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
SCM_DEFINE (scm_procedure_properties, "procedure-properties", 1, 0, 0,
(SCM proc),
- "Return @var{obj}'s property list.")
+ "Return @var{proc}'s property list.")
#define FUNC_NAME s_scm_procedure_properties
{
- SCM props;
+ SCM ret, user_props;
SCM_VALIDATE_PROC (1, proc);
- if (SCM_CLOSUREP (proc))
- props = SCM_PROCPROPS (proc);
+
+ user_props = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
+
+ if (scm_is_pair (user_props) && scm_is_true (scm_car (user_props)))
+ return scm_cdr (user_props);
+
+ if (SCM_PROGRAM_P (proc))
+ ret = scm_i_program_properties (proc);
else
- {
- scm_i_pthread_mutex_lock (&non_closure_props_lock);
- props = scm_hashq_ref (non_closure_props, proc, SCM_EOL);
- scm_i_pthread_mutex_unlock (&non_closure_props_lock);
- }
- return scm_acons (scm_sym_arity, scm_i_procedure_arity (proc), props);
+ ret = SCM_EOL;
+
+ if (scm_is_pair (user_props))
+ for (user_props = scm_cdr (user_props);
+ scm_is_pair (user_props);
+ user_props = scm_cdr (user_props))
+ ret = scm_assq_set_x (ret, scm_caar (user_props), scm_cdar (user_props));
+
+ return ret;
}
#undef FUNC_NAME
{
SCM_VALIDATE_PROC (1, proc);
- if (SCM_CLOSUREP (proc))
- SCM_SETPROCPROPS (proc, alist);
- else
- {
- scm_i_pthread_mutex_lock (&non_closure_props_lock);
- scm_hashq_set_x (non_closure_props, proc, alist);
- scm_i_pthread_mutex_unlock (&non_closure_props_lock);
- }
+ scm_weak_table_putq_x (overrides, proc, scm_cons (SCM_BOOL_T, alist));
+
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
"Return the property of @var{proc} with name @var{key}.")
#define FUNC_NAME s_scm_procedure_property
{
+ SCM user_props;
+
SCM_VALIDATE_PROC (1, proc);
- if (scm_is_eq (key, scm_sym_arity))
- /* avoid a cons in this case */
- return scm_i_procedure_arity (proc);
- else
+ if (scm_is_eq (key, scm_sym_name))
+ return scm_procedure_name (proc);
+ if (scm_is_eq (key, scm_sym_documentation))
+ return scm_procedure_documentation (proc);
+
+ user_props = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
+ if (scm_is_true (user_props))
{
- SCM props;
- if (SCM_CLOSUREP (proc))
- props = SCM_PROCPROPS (proc);
- else
- {
- scm_i_pthread_mutex_lock (&non_closure_props_lock);
- props = scm_hashq_ref (non_closure_props, proc, SCM_EOL);
- scm_i_pthread_mutex_unlock (&non_closure_props_lock);
- }
- return scm_assq_ref (props, key);
+ SCM pair = scm_assq (key, scm_cdr (user_props));
+ if (scm_is_pair (pair))
+ return scm_cdr (pair);
+ if (scm_is_true (scm_car (user_props)))
+ return SCM_BOOL_F;
}
+
+ return scm_assq_ref (scm_procedure_properties (proc), key);
}
#undef FUNC_NAME
"@var{val}.")
#define FUNC_NAME s_scm_set_procedure_property_x
{
- SCM_VALIDATE_PROC (1, proc);
+ SCM user_props, override_p;
- if (scm_is_eq (key, scm_sym_arity))
- SCM_MISC_ERROR ("arity is a read-only property", SCM_EOL);
+ SCM_VALIDATE_PROC (1, proc);
- if (SCM_CLOSUREP (proc))
- SCM_SETPROCPROPS (proc,
- scm_assq_set_x (SCM_PROCPROPS (proc), key, val));
+ scm_i_pthread_mutex_lock (&scm_i_misc_mutex);
+ user_props = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
+ if (scm_is_false (user_props))
+ {
+ override_p = SCM_BOOL_F;
+ user_props = SCM_EOL;
+ }
else
{
- scm_i_pthread_mutex_lock (&non_closure_props_lock);
- scm_hashq_set_x (non_closure_props, proc,
- scm_assq_set_x (scm_hashq_ref (non_closure_props, proc,
- SCM_EOL),
- key, val));
- scm_i_pthread_mutex_unlock (&non_closure_props_lock);
+ override_p = scm_car (user_props);
+ user_props = scm_cdr (user_props);
}
+ scm_weak_table_putq_x (overrides, proc,
+ scm_cons (override_p,
+ scm_assq_set_x (user_props, key, val)));
+ scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
+
\f
+SCM_SYMBOL (scm_sym_source, "source");
+
+
+SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0,
+ (SCM proc),
+ "Return the name of the procedure @var{proc}")
+#define FUNC_NAME s_scm_procedure_name
+{
+ SCM user_props;
+
+ SCM_VALIDATE_PROC (1, proc);
+
+ user_props = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
+ if (scm_is_true (user_props))
+ {
+ SCM pair = scm_assq (scm_sym_name, scm_cdr (user_props));
+ if (scm_is_pair (pair))
+ return scm_cdr (pair);
+ if (scm_is_true (scm_car (user_props)))
+ return SCM_BOOL_F;
+ }
+
+ if (SCM_PROGRAM_P (proc))
+ return scm_i_program_name (proc);
+ else if (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc))
+ return scm_procedure_name (SCM_STRUCT_PROCEDURE (proc));
+ else
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+
+SCM_GLOBAL_SYMBOL (scm_sym_documentation, "documentation");
+
+SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0,
+ (SCM proc),
+ "Return the documentation string associated with @code{proc}. By\n"
+ "convention, if a procedure contains more than one expression and the\n"
+ "first expression is a string constant, that string is assumed to contain\n"
+ "documentation for that procedure.")
+#define FUNC_NAME s_scm_procedure_documentation
+{
+ SCM user_props;
+
+ SCM_VALIDATE_PROC (1, proc);
+
+ while (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc))
+ proc = SCM_STRUCT_PROCEDURE (proc);
+
+ user_props = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
+ if (scm_is_true (user_props))
+ {
+ SCM pair = scm_assq (scm_sym_documentation, scm_cdr (user_props));
+ if (scm_is_pair (pair))
+ return scm_cdr (pair);
+ if (scm_is_true (scm_car (user_props)))
+ return SCM_BOOL_F;
+ }
+
+ if (SCM_PROGRAM_P (proc))
+ return scm_i_program_documentation (proc);
+ else
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0,
+ (SCM proc),
+ "Return the source of the procedure @var{proc}.")
+#define FUNC_NAME s_scm_procedure_source
+{
+ SCM src;
+ SCM_VALIDATE_PROC (1, proc);
+
+ do
+ {
+ src = scm_procedure_property (proc, scm_sym_source);
+ if (scm_is_true (src))
+ return src;
+
+ if (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc)
+ && SCM_HEAP_OBJECT_P ((proc = SCM_STRUCT_PROCEDURE (proc))))
+ continue;
+ }
+ while (0);
+
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+
+\f
void
scm_init_procprop ()
{
- non_closure_props = scm_make_weak_key_hash_table (SCM_UNDEFINED);
+ overrides = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY);
+ arity_overrides = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY);
#include "libguile/procprop.x"
+ scm_init_vm_builtin_properties ();
}
HCoop / bpt / guile.git / blobdiff