-/* 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 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/validate.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_program:
- if (scm_i_program_arity (proc, &a, &o, &r))
- break;
- else
- return SCM_BOOL_F;
- 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:
- a = SCM_CLOSURE_NUM_REQUIRED_ARGS (proc);
- r = SCM_CLOSURE_HAS_REST_ARGS (proc) ? 1 : 0;
- break;
- case scm_tcs_struct:
- if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
- {
- r = 1;
- break;
- }
- else if (!SCM_STRUCT_APPLICABLE_P (proc))
- return SCM_BOOL_F;
- proc = SCM_STRUCT_PROCEDURE (proc);
- goto loop;
- 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;
SCM_VALIDATE_PROC (1, proc);
- if (SCM_CLOSUREP (proc))
- props = SCM_PROCPROPS (proc);
- else
+
+ ret = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
+
+ if (scm_is_false (ret))
{
- 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);
+ if (SCM_PROGRAM_P (proc))
+ ret = scm_i_program_properties (proc);
+ else
+ ret = SCM_EOL;
}
- return scm_acons (scm_sym_arity, scm_i_procedure_arity (proc), 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, alist);
+
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
{
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
- {
- 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);
- }
+ 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 props;
- 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));
- else
+ scm_i_pthread_mutex_lock (&scm_i_misc_mutex);
+ props = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
+ if (scm_is_false (props))
{
- 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);
+ if (SCM_PROGRAM_P (proc))
+ props = scm_i_program_properties (proc);
+ else
+ props = SCM_EOL;
}
+ scm_weak_table_putq_x (overrides, proc, scm_assq_set_x (props, key, val));
+ scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
return SCM_UNSPECIFIED;
}
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"
}