summaryrefslogtreecommitdiff
path: root/libguile/procs.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/procs.c')
-rw-r--r--libguile/procs.c55
1 files changed, 11 insertions, 44 deletions
diff --git a/libguile/procs.c b/libguile/procs.c
index 59caed1b4..1be7fd10c 100644
--- a/libguile/procs.c
+++ b/libguile/procs.c
@@ -1,5 +1,5 @@
/* Copyright (C) 1995, 1996, 1997, 1999, 2000, 2001, 2006, 2008, 2009,
- * 2010, 2011, 2012 Free Software Foundation, Inc.
+ * 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
@@ -33,7 +33,7 @@
#include "libguile/validate.h"
#include "libguile/procs.h"
#include "libguile/procprop.h"
-#include "libguile/objcodes.h"
+#include "libguile/loader.h"
#include "libguile/programs.h"
@@ -47,21 +47,10 @@ SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0,
"Return @code{#t} if @var{obj} is a procedure.")
#define FUNC_NAME s_scm_procedure_p
{
- if (SCM_NIMP (obj))
- switch (SCM_TYP7 (obj))
- {
- case scm_tcs_struct:
- if (!((SCM_OBJ_CLASS_FLAGS (obj) & SCM_CLASSF_PURE_GENERIC)
- || SCM_STRUCT_APPLICABLE_P (obj)))
- break;
- case scm_tc7_program:
- return SCM_BOOL_T;
- case scm_tc7_smob:
- return scm_from_bool (SCM_SMOB_DESCRIPTOR (obj).apply);
- default:
- return SCM_BOOL_F;
- }
- return SCM_BOOL_F;
+ return scm_from_bool (SCM_PROGRAM_P (obj)
+ || (SCM_STRUCTP (obj) && SCM_STRUCT_APPLICABLE_P (obj))
+ || (SCM_HAS_TYP7 (obj, scm_tc7_smob)
+ && SCM_SMOB_APPLICABLE_P (obj)));
}
#undef FUNC_NAME
@@ -76,21 +65,6 @@ SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0,
}
#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_VALIDATE_PROC (SCM_ARG1, proc);
- return scm_procedure_property (proc, scm_sym_documentation);
-}
-#undef FUNC_NAME
-
/* Procedure-with-setter
*/
@@ -114,18 +88,10 @@ SCM_DEFINE (scm_make_procedure_with_setter, "make-procedure-with-setter", 2, 0,
"with the associated setter @var{setter}.")
#define FUNC_NAME s_scm_make_procedure_with_setter
{
- SCM name, ret;
SCM_VALIDATE_PROC (1, procedure);
SCM_VALIDATE_PROC (2, setter);
- ret = scm_make_struct (pws_vtable, SCM_INUM0,
- scm_list_2 (procedure, setter));
-
- /* don't use procedure_name, because don't care enough to do a reverse
- lookup */
- name = scm_procedure_property (procedure, scm_sym_name);
- if (scm_is_true (name))
- scm_set_procedure_property_x (ret, scm_sym_name, name);
- return ret;
+ return scm_make_struct (pws_vtable, SCM_INUM0,
+ scm_list_2 (procedure, setter));
}
#undef FUNC_NAME
@@ -147,14 +113,15 @@ SCM_PRIMITIVE_GENERIC (scm_setter, "setter", 1, 0, 0,
"applicable struct with a setter.")
#define FUNC_NAME s_scm_setter
{
- SCM_GASSERT1 (SCM_STRUCTP (proc), g_scm_setter, proc, SCM_ARG1, FUNC_NAME);
+ if (SCM_UNLIKELY (!SCM_STRUCTP (proc)))
+ return scm_wta_dispatch_1 (g_scm_setter, proc, SCM_ARG1, FUNC_NAME);
if (SCM_STRUCT_SETTER_P (proc))
return SCM_STRUCT_SETTER (proc);
if (SCM_PUREGENERICP (proc)
&& SCM_IS_A_P (proc, scm_class_generic_with_setter))
/* FIXME: might not be an accessor */
return SCM_GENERIC_SETTER (proc);
- SCM_WTA_DISPATCH_1 (g_scm_setter, proc, SCM_ARG1, FUNC_NAME);
+ return scm_wta_dispatch_1 (g_scm_setter, proc, SCM_ARG1, FUNC_NAME);
return SCM_BOOL_F; /* not reached */
}
#undef FUNC_NAME