This is the mail archive of the guile@sourceware.cygnus.com mailing list for the Guile project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]

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);

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]