diff options
author | Marius Vollmer <mvo@zagadka.de> | 2001-05-05 19:05:47 +0000 |
---|---|---|
committer | Marius Vollmer <mvo@zagadka.de> | 2001-05-05 19:05:47 +0000 |
commit | cec0d28c565f2a311e89d1657087a84b9f8d80da (patch) | |
tree | f64ea614e2d24feea0303c0bf4f61352d5d10df4 | |
parent | 67dc6a4ea26ddd00c41ec3a095843249ea9fa6c9 (diff) | |
download | guile-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.c | 30 | ||||
-rw-r--r-- | libguile/objects.h | 3 |
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 |