summaryrefslogtreecommitdiff
path: root/libguile/procs.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/procs.c')
-rw-r--r--libguile/procs.c27
1 files changed, 23 insertions, 4 deletions
diff --git a/libguile/procs.c b/libguile/procs.c
index acd7e4663..74cb86cce 100644
--- a/libguile/procs.c
+++ b/libguile/procs.c
@@ -31,6 +31,9 @@
#include "libguile/validate.h"
#include "libguile/procs.h"
+#include "libguile/procprop.h"
+#include "libguile/objcodes.h"
+#include "libguile/programs.h"
@@ -221,7 +224,9 @@ SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0,
obj = SCM_PROCEDURE (obj);
goto again;
default:
- ;
+ if (SCM_PROGRAM_P (obj) && SCM_PROGRAM_DATA (obj)->nargs == 0)
+ return SCM_BOOL_T;
+ /* otherwise fall through */
}
}
return SCM_BOOL_F;
@@ -297,11 +302,25 @@ 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);
- return scm_double_cell (scm_tc7_pws,
- SCM_UNPACK (procedure),
- SCM_UNPACK (setter), 0);
+ ret = scm_double_cell (scm_tc7_pws,
+ SCM_UNPACK (procedure),
+ SCM_UNPACK (setter), 0);
+ /* don't use procedure_name, because don't care enough to do a reverse
+ lookup */
+ switch (SCM_TYP7 (procedure)) {
+ case scm_tcs_subrs:
+ name = SCM_SNAME (procedure);
+ break;
+ default:
+ name = scm_procedure_property (procedure, scm_sym_name);
+ break;
+ }
+ if (scm_is_true (name))
+ scm_set_procedure_property_x (ret, scm_sym_name, name);
+ return ret;
}
#undef FUNC_NAME