diff options
Diffstat (limited to 'libguile/procprop.c')
-rw-r--r-- | libguile/procprop.c | 245 |
1 files changed, 161 insertions, 84 deletions
diff --git a/libguile/procprop.c b/libguile/procprop.c index be57b6bac..d45536062 100644 --- a/libguile/procprop.c +++ b/libguile/procprop.c @@ -1,6 +1,5 @@ -/* Copyright (C) 1995, 1996, 1998, 2000, 2001, 2003, 2004, 2006, - * 2008, 2009, 2010, 2011, 2012 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 * as published by the Free Software Foundation; either version 3 of @@ -23,34 +22,27 @@ # include <config.h> #endif -#define SCM_BUILDING_DEPRECATED_CODE - #include "libguile/_scm.h" #include "libguile/alist.h" -#include "libguile/deprecation.h" -#include "libguile/deprecated.h" #include "libguile/eval.h" #include "libguile/procs.h" #include "libguile/gsubr.h" #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" SCM_GLOBAL_SYMBOL (scm_sym_system_procedure, "system-procedure"); -#if (SCM_ENABLE_DEPRECATED == 1) -SCM_GLOBAL_SYMBOL (scm_sym_arity, "arity"); -#endif SCM_GLOBAL_SYMBOL (scm_sym_name, "name"); static SCM overrides; -static scm_i_pthread_mutex_t overrides_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER; static SCM arity_overrides; @@ -59,9 +51,7 @@ scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest) { SCM o; - scm_i_pthread_mutex_lock (&overrides_lock); - o = scm_hashq_ref (arity_overrides, proc, SCM_BOOL_F); - scm_i_pthread_mutex_unlock (&overrides_lock); + o = scm_weak_table_refq (arity_overrides, proc, SCM_BOOL_F); if (scm_is_true (o)) { @@ -73,16 +63,18 @@ scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest) while (!SCM_PROGRAM_P (proc)) { - if (SCM_IMP (proc)) - return 0; - switch (SCM_TYP7 (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)) { - case scm_tc7_smob: if (!SCM_SMOB_APPLICABLE_P (proc)) return 0; - if (!scm_i_program_arity - (SCM_SMOB_DESCRIPTOR (proc).apply_trampoline_objcode, - req, opt, rest)) + 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 @@ -90,14 +82,9 @@ scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest) *req -= 1; return 1; - case scm_tcs_struct: - if (!SCM_STRUCT_APPLICABLE_P (proc)) - return 0; - proc = SCM_STRUCT_PROCEDURE (proc); - break; - default: - return 0; } + else + return 0; } return scm_i_program_arity (proc, req, opt, rest); @@ -115,9 +102,7 @@ SCM_DEFINE (scm_set_procedure_minimum_arity_x, "set-procedure-minimum-arity!", SCM_VALIDATE_INT_COPY (3, opt, t); SCM_VALIDATE_BOOL (4, rest); - scm_i_pthread_mutex_lock (&overrides_lock); - scm_hashq_set_x (arity_overrides, proc, scm_list_3 (req, opt, rest)); - scm_i_pthread_mutex_unlock (&overrides_lock); + scm_weak_table_putq_x (arity_overrides, proc, scm_list_3 (req, opt, rest)); return SCM_UNDEFINED; } #undef FUNC_NAME @@ -152,25 +137,25 @@ SCM_DEFINE (scm_procedure_properties, "procedure-properties", 1, 0, 0, "Return @var{proc}'s property list.") #define FUNC_NAME s_scm_procedure_properties { - SCM ret; + SCM ret, user_props; SCM_VALIDATE_PROC (1, proc); - scm_i_pthread_mutex_lock (&overrides_lock); - ret = scm_hashq_ref (overrides, proc, SCM_BOOL_F); - scm_i_pthread_mutex_unlock (&overrides_lock); + user_props = scm_weak_table_refq (overrides, proc, SCM_BOOL_F); - if (scm_is_false (ret)) - { - if (SCM_PROGRAM_P (proc)) - ret = scm_i_program_properties (proc); - else - ret = SCM_EOL; - } - -#if (SCM_ENABLE_DEPRECATED == 1) - ret = scm_acons (scm_sym_arity, scm_procedure_minimum_arity (proc), ret); -#endif + 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 + 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; } @@ -183,14 +168,7 @@ SCM_DEFINE (scm_set_procedure_properties_x, "set-procedure-properties!", 2, 0, 0 { SCM_VALIDATE_PROC (1, proc); -#if (SCM_ENABLE_DEPRECATED == 1) - if (scm_is_true (scm_assq (scm_sym_arity, alist))) - SCM_MISC_ERROR ("arity is a read-only property", SCM_EOL); -#endif - - scm_i_pthread_mutex_lock (&overrides_lock); - scm_hashq_set_x (overrides, proc, alist); - scm_i_pthread_mutex_unlock (&overrides_lock); + scm_weak_table_putq_x (overrides, proc, scm_cons (SCM_BOOL_T, alist)); return SCM_UNSPECIFIED; } @@ -201,14 +179,24 @@ SCM_DEFINE (scm_procedure_property, "procedure-property", 2, 0, 0, "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_ENABLE_DEPRECATED == 1) - if (scm_is_eq (key, scm_sym_arity)) - scm_c_issue_deprecation_warning - ("Accessing a procedure's arity via `procedure-property' is deprecated.\n" - "Use `procedure-minimum-arity instead."); -#endif + 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 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); } @@ -220,46 +208,135 @@ SCM_DEFINE (scm_set_procedure_property_x, "set-procedure-property!", 3, 0, 0, "@var{val}.") #define FUNC_NAME s_scm_set_procedure_property_x { - SCM props; + SCM user_props, override_p; SCM_VALIDATE_PROC (1, proc); -#if (SCM_ENABLE_DEPRECATED == 1) - if (scm_is_eq (key, scm_sym_arity)) - SCM_MISC_ERROR ("arity is a deprecated read-only property", SCM_EOL); -#endif - - scm_dynwind_begin (0); - /* Here we must block asyncs while overrides_lock is held, to avoid - deadlocks which can happen as follows: scm_i_program_properties - calls out to the VM, which will run asyncs. Asyncs are permitted - to run VM code, which sometimes checks procedure properties, which - locks overrides_lock. */ - scm_i_dynwind_pthread_mutex_lock_block_asyncs (&overrides_lock); - props = scm_hashq_ref (overrides, proc, SCM_BOOL_F); - if (scm_is_false (props)) + 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)) { - if (SCM_PROGRAM_P (proc)) - props = scm_i_program_properties (proc); - else - props = SCM_EOL; + override_p = SCM_BOOL_F; + user_props = SCM_EOL; + } + else + { + override_p = scm_car (user_props); + user_props = scm_cdr (user_props); } - scm_hashq_set_x (overrides, proc, scm_assq_set_x (props, key, val)); - scm_dynwind_end (); + 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 + +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 + + + void scm_init_procprop () { - overrides = scm_make_weak_key_hash_table (SCM_UNDEFINED); - arity_overrides = 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 (); } |