summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMarius Vollmer <mvo@zagadka.de>2001-05-05 19:05:47 +0000
committerMarius Vollmer <mvo@zagadka.de>2001-05-05 19:05:47 +0000
commitcec0d28c565f2a311e89d1657087a84b9f8d80da (patch)
treef64ea614e2d24feea0303c0bf4f61352d5d10df4
parent67dc6a4ea26ddd00c41ec3a095843249ea9fa6c9 (diff)
downloadguile-cec0d28c565f2a311e89d1657087a84b9f8d80da.tar.gz
(scm_valid_object_procedure_p): New.
(scm_set_object_procedure_x): Use it to check argument. Fix docstring.
-rw-r--r--libguile/objects.c30
-rw-r--r--libguile/objects.h3
2 files changed, 30 insertions, 3 deletions
diff --git a/libguile/objects.c b/libguile/objects.c
index c5ddb0538..82033b378 100644
--- a/libguile/objects.c
+++ b/libguile/objects.c
@@ -374,9 +374,35 @@ SCM_DEFINE (scm_operator_p, "operator?", 1, 0, 0,
}
#undef FUNC_NAME
+/* XXX - What code requires the object procedure to be only of certain
+ types? */
+
+SCM_DEFINE (scm_valid_object_procedure_p, "valid-object-procedure?", 1, 0, 0,
+ (SCM proc),
+ "Return @code{#t} iff @var{proc} is a procedure that can be used "
+ "with @code{set-object-procedure}. It is always valid to use "
+ "a closure constructed by @code{lambda}.")
+#define FUNC_NAME s_scm_valid_object_procedure_p
+{
+ if (SCM_IMP (proc))
+ return SCM_BOOL_F;
+ switch (SCM_TYP7 (proc))
+ {
+ default:
+ return SCM_BOOL_F;
+ case scm_tcs_closures:
+ case scm_tc7_subr_1:
+ case scm_tc7_subr_2:
+ case scm_tc7_subr_3:
+ case scm_tc7_lsubr_2:
+ return SCM_BOOL_T;
+ }
+}
+#undef FUNC_NAME
+
SCM_DEFINE (scm_set_object_procedure_x, "set-object-procedure!", 2, 0, 0,
(SCM obj, SCM proc),
- "Return the object procedure of @var{obj} to @var{proc}.\n"
+ "Set the object procedure of @var{obj} to @var{proc}.\n"
"@var{obj} must be either an entity or an operator.")
#define FUNC_NAME s_scm_set_object_procedure_x
{
@@ -388,7 +414,7 @@ SCM_DEFINE (scm_set_object_procedure_x, "set-object-procedure!", 2, 0, 0,
obj,
SCM_ARG1,
FUNC_NAME);
- SCM_VALIDATE_PROC (2,proc);
+ SCM_ASSERT (scm_valid_object_procedure_p (proc), proc, SCM_ARG2, FUNC_NAME);
if (SCM_I_ENTITYP (obj))
SCM_SET_ENTITY_PROCEDURE (obj, proc);
else
diff --git a/libguile/objects.h b/libguile/objects.h
index 110158a8e..20e3fb3ea 100644
--- a/libguile/objects.h
+++ b/libguile/objects.h
@@ -230,7 +230,8 @@ extern SCM scm_apply_generic (SCM gf, SCM args);
extern SCM scm_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3);
extern SCM scm_entity_p (SCM obj);
extern SCM scm_operator_p (SCM obj);
-extern SCM scm_set_object_procedure_x (SCM obj, SCM procs);
+extern SCM scm_valid_object_procedure_p (SCM proc);
+extern SCM scm_set_object_procedure_x (SCM obj, SCM proc);
#ifdef GUILE_DEBUG
extern SCM scm_object_procedure (SCM obj);
#endif