diff options
Diffstat (limited to 'libguile/procs.c')
-rw-r--r-- | libguile/procs.c | 55 |
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 |