summaryrefslogtreecommitdiff
path: root/libguile/procprop.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/procprop.c')
-rw-r--r--libguile/procprop.c245
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 ();
}