1 /* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2006, 2008, 2009 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public License
5 * as published by the Free Software Foundation; either version 3 of
6 * the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful, but
9 * WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
26 #include "libguile/_scm.h"
28 #include "libguile/eval.h"
29 #include "libguile/ports.h"
30 #include "libguile/procprop.h"
31 #include "libguile/root.h"
32 #include "libguile/smob.h"
33 #include "libguile/strings.h"
35 #include "libguile/validate.h"
36 #include "libguile/hooks.h"
41 * Currently, this implementation is separate from the Scheme level
42 * hooks. The possibility exists to implement the Scheme level hooks
43 * using C level hooks.
46 /* Hint for `scm_gc_malloc ()' and friends. */
47 static const char hook_entry_gc_hint
[] = "hook entry";
50 scm_c_hook_init (scm_t_c_hook
*hook
, void *hook_data
, scm_t_c_hook_type type
)
54 hook
->data
= hook_data
;
58 scm_c_hook_add (scm_t_c_hook
*hook
,
59 scm_t_c_hook_function func
,
63 scm_t_c_hook_entry
*entry
;
64 scm_t_c_hook_entry
**loc
= &hook
->first
;
66 entry
= scm_gc_malloc (sizeof (scm_t_c_hook_entry
), hook_entry_gc_hint
);
72 entry
->data
= fn_data
;
77 scm_c_hook_remove (scm_t_c_hook
*hook
,
78 scm_t_c_hook_function func
,
81 scm_t_c_hook_entry
**loc
= &hook
->first
;
84 if ((*loc
)->func
== func
&& (*loc
)->data
== fn_data
)
91 fprintf (stderr
, "Attempt to remove non-existent hook function\n");
96 scm_c_hook_run (scm_t_c_hook
*hook
, void *data
)
98 scm_t_c_hook_entry
*entry
= hook
->first
;
99 scm_t_c_hook_type type
= hook
->type
;
103 res
= (entry
->func
) (hook
->data
, entry
->data
, data
);
106 if (type
== SCM_C_HOOK_OR
)
111 if (type
== SCM_C_HOOK_AND
)
120 /* Scheme level hooks
122 * A hook is basically a list of procedures to be called at well defined
125 * Hook arity is not a full member of this type and therefore lacks an
126 * accessor. It exists to aid debugging and is not intended to be used in
130 scm_t_bits scm_tc16_hook
;
134 hook_print (SCM hook
, SCM port
, scm_print_state
*pstate
)
137 scm_puts ("#<hook ", port
);
138 scm_intprint (SCM_HOOK_ARITY (hook
), 10, port
);
139 scm_putc (' ', port
);
140 scm_uintprint (SCM_UNPACK (hook
), 16, port
);
141 ls
= SCM_HOOK_PROCEDURES (hook
);
142 while (SCM_NIMP (ls
))
144 scm_putc (' ', port
);
145 name
= scm_procedure_name (SCM_CAR (ls
));
146 if (scm_is_true (name
))
147 scm_iprin1 (name
, port
, pstate
);
149 scm_putc ('?', port
);
152 scm_putc ('>', port
);
157 SCM_DEFINE (scm_make_hook
, "make-hook", 0, 1, 0,
159 "Create a hook for storing procedure of arity @var{n_args}.\n"
160 "@var{n_args} defaults to zero. The returned value is a hook\n"
161 "object to be used with the other hook procedures.")
162 #define FUNC_NAME s_scm_make_hook
166 if (SCM_UNBNDP (n_args
))
169 n
= scm_to_unsigned_integer (n_args
, 0, 16);
171 SCM_RETURN_NEWSMOB (scm_tc16_hook
+ (n
<< 16), SCM_UNPACK (SCM_EOL
));
176 SCM_DEFINE (scm_hook_p
, "hook?", 1, 0, 0,
178 "Return @code{#t} if @var{x} is a hook, @code{#f} otherwise.")
179 #define FUNC_NAME s_scm_hook_p
181 return scm_from_bool (SCM_HOOKP (x
));
186 SCM_DEFINE (scm_hook_empty_p
, "hook-empty?", 1, 0, 0,
188 "Return @code{#t} if @var{hook} is an empty hook, @code{#f}\n"
190 #define FUNC_NAME s_scm_hook_empty_p
192 SCM_VALIDATE_HOOK (1, hook
);
193 return scm_from_bool (scm_is_null (SCM_HOOK_PROCEDURES (hook
)));
198 SCM_DEFINE (scm_add_hook_x
, "add-hook!", 2, 1, 0,
199 (SCM hook
, SCM proc
, SCM append_p
),
200 "Add the procedure @var{proc} to the hook @var{hook}. The\n"
201 "procedure is added to the end if @var{append_p} is true,\n"
202 "otherwise it is added to the front. The return value of this\n"
203 "procedure is not specified.")
204 #define FUNC_NAME s_scm_add_hook_x
207 int n_args
, p_req
, p_opt
, p_rest
;
208 SCM_VALIDATE_HOOK (1, hook
);
209 SCM_ASSERT (scm_i_procedure_arity (proc
, &p_req
, &p_opt
, &p_rest
),
210 proc
, SCM_ARG2
, FUNC_NAME
);
211 n_args
= SCM_HOOK_ARITY (hook
);
212 if (p_req
> n_args
|| (!p_rest
&& p_req
+ p_opt
< n_args
))
213 scm_wrong_type_arg (FUNC_NAME
, 2, proc
);
214 rest
= scm_delq_x (proc
, SCM_HOOK_PROCEDURES (hook
));
215 SCM_SET_HOOK_PROCEDURES (hook
,
216 (!SCM_UNBNDP (append_p
) && scm_is_true (append_p
)
217 ? scm_append_x (scm_list_2 (rest
, scm_list_1 (proc
)))
218 : scm_cons (proc
, rest
)));
219 return SCM_UNSPECIFIED
;
224 SCM_DEFINE (scm_remove_hook_x
, "remove-hook!", 2, 0, 0,
225 (SCM hook
, SCM proc
),
226 "Remove the procedure @var{proc} from the hook @var{hook}. The\n"
227 "return value of this procedure is not specified.")
228 #define FUNC_NAME s_scm_remove_hook_x
230 SCM_VALIDATE_HOOK (1, hook
);
231 SCM_SET_HOOK_PROCEDURES (hook
,
232 scm_delq_x (proc
, SCM_HOOK_PROCEDURES (hook
)));
233 return SCM_UNSPECIFIED
;
238 SCM_DEFINE (scm_reset_hook_x
, "reset-hook!", 1, 0, 0,
240 "Remove all procedures from the hook @var{hook}. The return\n"
241 "value of this procedure is not specified.")
242 #define FUNC_NAME s_scm_reset_hook_x
244 SCM_VALIDATE_HOOK (1, hook
);
245 SCM_SET_HOOK_PROCEDURES (hook
, SCM_EOL
);
246 return SCM_UNSPECIFIED
;
251 SCM_DEFINE (scm_run_hook
, "run-hook", 1, 0, 1,
252 (SCM hook
, SCM args
),
253 "Apply all procedures from the hook @var{hook} to the arguments\n"
254 "@var{args}. The order of the procedure application is first to\n"
255 "last. The return value of this procedure is not specified.")
256 #define FUNC_NAME s_scm_run_hook
258 SCM_VALIDATE_HOOK (1, hook
);
259 if (scm_ilength (args
) != SCM_HOOK_ARITY (hook
))
260 SCM_MISC_ERROR ("Hook ~S requires ~A arguments",
261 scm_list_2 (hook
, scm_from_int (SCM_HOOK_ARITY (hook
))));
262 scm_c_run_hook (hook
, args
);
263 return SCM_UNSPECIFIED
;
269 scm_c_run_hook (SCM hook
, SCM args
)
271 SCM procs
= SCM_HOOK_PROCEDURES (hook
);
272 while (SCM_NIMP (procs
))
274 scm_apply_0 (SCM_CAR (procs
), args
);
275 procs
= SCM_CDR (procs
);
280 scm_c_run_hookn (SCM hook
, SCM
*argv
, size_t nargs
)
282 SCM procs
= SCM_HOOK_PROCEDURES (hook
);
283 while (SCM_NIMP (procs
))
285 scm_call_n (SCM_CAR (procs
), argv
, nargs
);
286 procs
= SCM_CDR (procs
);
291 SCM_DEFINE (scm_hook_to_list
, "hook->list", 1, 0, 0,
293 "Convert the procedure list of @var{hook} to a list.")
294 #define FUNC_NAME s_scm_hook_to_list
296 SCM_VALIDATE_HOOK (1, hook
);
297 return scm_list_copy (SCM_HOOK_PROCEDURES (hook
));
307 scm_tc16_hook
= scm_make_smob_type ("hook", 0);
308 scm_set_smob_print (scm_tc16_hook
, hook_print
);
309 #include "libguile/hooks.x"