mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-12 06:41:13 +02:00
Code Activity

(scm_valid_object_procedure_p): New.

Browse source 
(scm_set_object_procedure_x): Use it to check argument.  Fix
docstring.
This commit is contained in:
Marius Vollmer 2001-05-05 19:05:47 +00:00
parent 67dc6a4ea2
commit cec0d28c56
2 changed files with 30 additions and 3 deletions
Download patch file Download diff file Expand all files Collapse all files

30
libguile/objects.c
View file

@ -374,9 +374,35 @@ SCM_DEFINE (scm_operator_p, "operator?", 1, 0, 0,
} }
#undef FUNC_NAME #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_DEFINE (scm_set_object_procedure_x, "set-object-procedure!", 2, 0, 0,
(SCM obj, SCM proc), (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.") "@var{obj} must be either an entity or an operator.")
#define FUNC_NAME s_scm_set_object_procedure_x #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, obj,
SCM_ARG1, SCM_ARG1,
FUNC_NAME); 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)) if (SCM_I_ENTITYP (obj))
SCM_SET_ENTITY_PROCEDURE (obj, proc); SCM_SET_ENTITY_PROCEDURE (obj, proc);
else else

3
libguile/objects.h
View file

@ -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_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3);
extern SCM scm_entity_p (SCM obj); extern SCM scm_entity_p (SCM obj);
extern SCM scm_operator_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 #ifdef GUILE_DEBUG
extern SCM scm_object_procedure (SCM obj); extern SCM scm_object_procedure (SCM obj);
#endif #endif