mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-01 12:20:26 +02:00
Code Activity

* feature.c (scm_remove_hook_x): Bugfix: Changed reference to

Browse source 
s_add_hook_x --> s_remove_hook_x.
(scm_add_hook_x, scm_remove_hook_x): Hooks now takes arguments.
Added #include "procprop.h"
* feature.c, feature.h (scm_reset_hook_x): New procedure.
(scm_make_hook): Optional argument defines number of arguments to
the hook.
(scm_make_named_hook): Take number of args as second arg.
(scm_run_hook): Renamed from scm_run_hooks (old name kept for a
while); First arg is the hook.  The rest are arguments passed on
to the hook procedures.
This commit is contained in:
Mikael Djurfeldt 1998-11-26 07:44:09 +00:00
parent 7a79c6b4d3
commit b90d369ecf
1 changed files with 74 additions and 33 deletions
Download patch file Download diff file Expand all files Collapse all files

107
libguile/feature.c
View file

@ -44,6 +44,7 @@
#include "_scm.h" #include "_scm.h"
#include "eval.h" #include "eval.h"
#include "procprop.h"
#include "feature.h" #include "feature.h"
@ -55,11 +56,11 @@
static SCM *scm_loc_features; static SCM *scm_loc_features;
void void
scm_add_feature(str) scm_add_feature (str)
char* str; char* str;
{ {
*scm_loc_features = scm_cons(SCM_CAR(scm_intern(str, strlen(str))), *scm_loc_features = scm_cons (SCM_CAR (scm_intern (str, strlen (str))),
*scm_loc_features); *scm_loc_features);
} }
@ -95,18 +96,22 @@ scm_set_program_arguments (argc, argv, first)
SCM_SYMBOL (scm_sym_hook, "hook"); SCM_SYMBOL (scm_sym_hook, "hook");
SCM_PROC (s_make_hook, "make-hook", 0, 0, 0, scm_make_hook); SCM_PROC (s_make_hook, "make-hook", 0, 1, 0, scm_make_hook);
SCM SCM
scm_make_hook () scm_make_hook (SCM n_args)
{ {
return scm_cons (scm_sym_hook, SCM_EOL); if (SCM_UNBNDP (n_args))
n_args = SCM_INUM0;
else
SCM_ASSERT (SCM_INUMP (n_args), n_args, SCM_ARG1, s_make_hook);
return scm_cons2 (scm_sym_hook, n_args, SCM_EOL);
} }
SCM SCM
scm_make_named_hook (char* name) scm_make_named_hook (char* name, int n_args)
{ {
SCM hook = scm_make_hook (); SCM hook = scm_make_hook (SCM_MAKINUM (n_args));
scm_permanent_object (scm_sysintern (name, hook)); scm_permanent_object (scm_sysintern (name, hook));
return hook; return hook;
} }
@ -114,20 +119,31 @@ scm_make_named_hook (char* name)
SCM_PROC (s_add_hook_x, "add-hook!", 2, 1, 0, scm_add_hook_x); SCM_PROC (s_add_hook_x, "add-hook!", 2, 1, 0, scm_add_hook_x);
SCM SCM
scm_add_hook_x (SCM hook, SCM thunk, SCM append_p) scm_add_hook_x (SCM hook, SCM proc, SCM append_p)
{ {
SCM rest; SCM arity, rest;
SCM_ASSERT (SCM_NIMP (hook) int n_args;
&& SCM_CONSP (hook) SCM_ASSERT (SCM_NIMP (hook) && SCM_CONSP (hook)
&& SCM_CAR (hook) == scm_sym_hook && SCM_CAR (hook) == scm_sym_hook
&& scm_ilength (SCM_CDR (hook)) >= 0, && SCM_NIMP (SCM_CDR (hook)) && SCM_CONSP (SCM_CDR (hook))
&& SCM_INUMP (SCM_CADR (hook))
&& scm_ilength (SCM_CDDR (hook)) >= 0,
hook, SCM_ARG1, s_add_hook_x); hook, SCM_ARG1, s_add_hook_x);
SCM_ASSERT (SCM_NFALSEP (scm_thunk_p (thunk)), SCM_ASSERT (SCM_NFALSEP (arity = scm_i_procedure_arity (proc)),
thunk, SCM_ARG2, s_add_hook_x); proc, SCM_ARG2, s_add_hook_x);
rest = scm_delq_x (thunk, SCM_CDR (hook)); n_args = SCM_INUM (SCM_CADR (hook));
SCM_SETCDR (hook, (!SCM_UNBNDP (append_p) && SCM_NFALSEP (append_p) if (SCM_INUM (SCM_CAR (arity)) > n_args
? scm_append_x (SCM_LIST2 (rest, SCM_LIST1 (thunk))) || (SCM_FALSEP (SCM_CADDR (arity))
: scm_cons (thunk, rest))); && (SCM_INUM (SCM_CAR (arity)) + SCM_INUM (SCM_CADR (arity))
< n_args)))
scm_misc_error (s_add_hook_x,
"This hook requires %s arguments",
SCM_LIST1 (SCM_CADR (hook)));
rest = scm_delq_x (proc, SCM_CDDR (hook));
SCM_SETCDR (SCM_CDR (hook),
(!SCM_UNBNDP (append_p) && SCM_NFALSEP (append_p)
? scm_append_x (SCM_LIST2 (rest, SCM_LIST1 (proc)))
: scm_cons (proc, rest)));
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
} }
@ -136,29 +152,54 @@ SCM_PROC (s_remove_hook_x, "remove-hook!", 2, 0, 0, scm_remove_hook_x);
SCM SCM
scm_remove_hook_x (SCM hook, SCM thunk) scm_remove_hook_x (SCM hook, SCM thunk)
{ {
SCM_ASSERT (SCM_NIMP (hook) SCM_ASSERT (SCM_NIMP (hook) && SCM_CONSP (hook)
&& SCM_CONSP (hook)
&& SCM_CAR (hook) == scm_sym_hook && SCM_CAR (hook) == scm_sym_hook
&& scm_ilength (SCM_CDR (hook)) >= 0, && SCM_NIMP (SCM_CDR (hook)) && SCM_CONSP (SCM_CDR (hook))
hook, SCM_ARG1, s_add_hook_x); && SCM_INUMP (SCM_CADR (hook))
SCM_ASSERT (SCM_NFALSEP (scm_thunk_p (thunk)), && scm_ilength (SCM_CDDR (hook)) >= 0,
thunk, SCM_ARG2, s_add_hook_x); hook, SCM_ARG1, s_remove_hook_x);
SCM_SETCDR (hook, scm_delq_x (thunk, SCM_CDR (hook))); SCM_SETCDR (SCM_CDR (hook), scm_delq_x (thunk, SCM_CDDR (hook)));
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
} }
SCM_PROC (s_run_hooks, "run-hooks", 1, 0, 0, scm_run_hooks); SCM_PROC (s_reset_hook_x, "reset-hook!", 1, 0, 0, scm_reset_hook_x);
SCM SCM
scm_run_hooks (SCM hook) scm_reset_hook_x (SCM hook)
{ {
SCM_ASSERT (SCM_NIMP (hook) SCM_ASSERT (SCM_NIMP (hook) && SCM_CONSP (hook)
&& SCM_CONSP (hook)
&& SCM_CAR (hook) == scm_sym_hook && SCM_CAR (hook) == scm_sym_hook
&& scm_ilength (SCM_CDR (hook)) >= 0, && SCM_NIMP (SCM_CDR (hook)) && SCM_CONSP (SCM_CDR (hook))
hook, SCM_ARG1, s_add_hook_x); && SCM_INUMP (SCM_CADR (hook))
&& scm_ilength (SCM_CDDR (hook)) >= 0,
hook, SCM_ARG1, s_reset_hook_x);
SCM_SETCDR (SCM_CDR (hook), SCM_EOL);
return SCM_UNSPECIFIED;
}
/* This name is only provided for backward compatibility! */
SCM_PROC (s_run_hooks, "run-hooks", 1, 0, 1, scm_run_hook);
SCM_PROC (s_run_hook, "run-hook", 1, 0, 1, scm_run_hook);
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_ilength (SCM_CDDR (hook)) >= 0,
hook, SCM_ARG1, s_run_hook);
if (SCM_UNBNDP (args))
args = SCM_EOL;
if (scm_ilength (args) != SCM_INUM (SCM_CADR (hook)))
scm_misc_error (s_add_hook_x,
"This hook requires %s arguments",
SCM_LIST1 (SCM_CADR (hook)));
hook = SCM_CDR (hook);
while (SCM_NIMP (hook = SCM_CDR (hook))) while (SCM_NIMP (hook = SCM_CDR (hook)))
scm_apply (SCM_CAR (hook), SCM_EOL, SCM_EOL); scm_apply (SCM_CAR (hook), args, SCM_EOL);
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
} }