This is the mail archive of the
guile@sourceware.cygnus.com
mailing list for the Guile project.
Re: hook? primitive
Mikael Djurfeldt <mdj@mdj-pc.nada.kth.se> writes:
> Greg Badros <gjb@cs.washington.edu> writes:
>
> > I don't seem to be able to find a hook? primitive for testing whether an
> > object is a hook, made with make-hook. If it's really missing, could we
> > get it for 1.3.4?
>
> It is missing.
>
> If you give me an patch, I promise to apply it quickly. :)
Ok, the patch (for it and the rest of the hook API that was missing) is
below. One thing that should be added but I don't know Guile coding
conventions well enough to decide where to put it is an alias for a
useful hook-length test:
(define-public (empty-hook? hook)
(eqv? (hook-length hook) 0))
Here's the ChangeLog entry:
Wed Sep 8 09:18:32 1999 Greg J. Badros <gjb@cs.washington.edu>
* feature.h, feature.c (scm_hook_p, scm_hook_arity,
scm_hook_length): Added these predicates, and use scm_hook_p in
other -hook* functions for validating the object.
and the patch follows.
Greg
Index: feature.c
===================================================================
RCS file: /cvs/guile/guile/guile-core/libguile/feature.c,v
retrieving revision 1.19
diff -u -p -r1.19 feature.c
--- feature.c 1999/08/05 12:08:01 1.19
+++ feature.c 1999/09/08 16:24:16
@@ -116,6 +116,40 @@ scm_make_named_hook (char* name, int n_a
return hook;
}
+SCM_PROC (s_hook_p, "hook?", 1, 0, 0, scm_hook_p);
+
+SCM
+scm_hook_p (SCM x)
+{
+ return (SCM_NIMP (x) && SCM_CONSP (x)
+ && SCM_CAR (x) == scm_sym_hook
+ && SCM_NIMP (SCM_CDR (x)) && SCM_CONSP (SCM_CDR (x))
+ && SCM_INUMP (SCM_CADR (x)))? SCM_BOOL_T: SCM_BOOL_F;
+}
+
+SCM_PROC (s_hook_length, "hook-length", 1, 0, 0, scm_hook_length);
+
+SCM
+scm_hook_length (SCM hook)
+{
+ SCM_ASSERT (SCM_BOOL_T == scm_hook_p(hook),
+ hook, SCM_ARG1, s_hook_length);
+ return scm_length(SCM_CDDR(hook));
+}
+
+
+SCM_PROC (s_hook_arity, "hook-arity", 1, 0, 0, scm_hook_arity);
+
+SCM
+scm_hook_arity (SCM hook)
+{
+ SCM_ASSERT (SCM_BOOL_T == scm_hook_p(hook),
+ hook, SCM_ARG1, s_hook_arity);
+ return SCM_CADR(hook);
+}
+
+
+
SCM_PROC (s_add_hook_x, "add-hook!", 2, 1, 0, scm_add_hook_x);
SCM
@@ -123,10 +157,7 @@ scm_add_hook_x (SCM hook, SCM proc, SCM
{
SCM arity, rest;
int n_args;
- SCM_ASSERT (SCM_NIMP (hook) && SCM_CONSP (hook)
- && SCM_CAR (hook) == scm_sym_hook
- && SCM_NIMP (SCM_CDR (hook)) && SCM_CONSP (SCM_CDR (hook))
- && SCM_INUMP (SCM_CADR (hook))
+ SCM_ASSERT (SCM_BOOL_T == scm_hook_p(hook)
&& scm_ilength (SCM_CDDR (hook)) >= 0,
hook, SCM_ARG1, s_add_hook_x);
SCM_ASSERT (SCM_NFALSEP (arity = scm_i_procedure_arity (proc)),
@@ -152,10 +183,7 @@ SCM_PROC (s_remove_hook_x, "remove-hook!
SCM
scm_remove_hook_x (SCM hook, SCM thunk)
{
- SCM_ASSERT (SCM_NIMP (hook) && SCM_CONSP (hook)
- && SCM_CAR (hook) == scm_sym_hook
- && SCM_NIMP (SCM_CDR (hook)) && SCM_CONSP (SCM_CDR (hook))
- && SCM_INUMP (SCM_CADR (hook))
+ SCM_ASSERT (SCM_BOOL_T == scm_hook_p(hook)
&& scm_ilength (SCM_CDDR (hook)) >= 0,
hook, SCM_ARG1, s_remove_hook_x);
SCM_SETCDR (SCM_CDR (hook), scm_delq_x (thunk, SCM_CDDR (hook)));
@@ -167,10 +195,7 @@ SCM_PROC (s_reset_hook_x, "reset-hook!",
SCM
scm_reset_hook_x (SCM hook)
{
- SCM_ASSERT (SCM_NIMP (hook) && SCM_CONSP (hook)
- && SCM_CAR (hook) == scm_sym_hook
- && SCM_NIMP (SCM_CDR (hook)) && SCM_CONSP (SCM_CDR (hook))
- && SCM_INUMP (SCM_CADR (hook))
+ SCM_ASSERT (SCM_BOOL_T == scm_hook_p(hook)
&& scm_ilength (SCM_CDDR (hook)) >= 0,
hook, SCM_ARG1, s_reset_hook_x);
SCM_SETCDR (SCM_CDR (hook), SCM_EOL);
@@ -182,10 +207,7 @@ SCM_PROC (s_run_hook, "run-hook", 1, 0,
SCM
scm_run_hook (SCM hook, SCM args)
{
- SCM_ASSERT (SCM_NIMP (hook) && SCM_CONSP (hook)
- && SCM_CAR (hook) == scm_sym_hook
- && SCM_NIMP (SCM_CDR (hook)) && SCM_CONSP (SCM_CDR (hook))
- && SCM_INUMP (SCM_CADR (hook))
+ SCM_ASSERT (SCM_BOOL_T == scm_hook_p(hook)
&& scm_ilength (SCM_CDDR (hook)) >= 0,
hook, SCM_ARG1, s_run_hook);
if (SCM_UNBNDP (args))
Index: feature.h
===================================================================
RCS file: /cvs/guile/guile/guile-core/libguile/feature.h,v
retrieving revision 1.14
diff -u -p -r1.14 feature.h
--- feature.h 1999/08/05 12:08:01 1.14
+++ feature.h 1999/09/08 16:24:16
@@ -51,6 +51,9 @@ extern SCM scm_program_arguments (void);
extern void scm_set_program_arguments (int argc, char **argv, char *first);
extern SCM scm_make_hook (SCM n_args);
extern SCM scm_make_named_hook (char* name, int n_args);
+extern SCM scm_hook_p (SCM x);
+extern SCM scm_hook_length (SCM hook);
+extern SCM scm_hook_arity (SCM hook);
extern SCM scm_add_hook_x (SCM hook, SCM thunk, SCM appendp);
extern SCM scm_remove_hook_x (SCM hook, SCM thunk);
extern SCM scm_reset_hook_x (SCM hook);