1 /*-
2 * Copyright (c) 2005-2019 Michael Scholz <mi-scholz@users.sourceforge.net>
3 * All rights reserved.
4 *
5 * Redistribution and use in source and binary forms, with or without
6 * modification, are permitted provided that the following conditions
7 * are met:
8 * 1. Redistributions of source code must retain the above copyright
9 * notice, this list of conditions and the following disclaimer.
10 * 2. Redistributions in binary form must reproduce the above copyright
11 * notice, this list of conditions and the following disclaimer in the
12 * documentation and/or other materials provided with the distribution.
13 *
14 * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
15 * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
16 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
17 * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
18 * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
19 * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
20 * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
21 * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
22 * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
23 * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
24 * SUCH DAMAGE.
25 *
26 * @(#)hook.c 2.2 1/31/19
27 */
28
29 #if defined(HAVE_CONFIG_H)
30 #include "config.h"
31 #endif
32
33 #include "fth.h"
34 #include "utils.h"
35
36 /* === HOOK === */
37
38 static FTH hook_tag;
39
40 typedef struct {
41 char *name; /* hook name */
42 simple_array *data; /* array of hook functions */
43 int req; /* required arguments */
44 int opt; /* optional arguments */
45 int rest; /* rest arguments */
46 } FHook;
47
48 #define FTH_HOOK_OBJECT(Obj) FTH_INSTANCE_REF_GEN(Obj, FHook)
49 #define FTH_HOOK_NAME(Obj) FTH_HOOK_OBJECT(Obj)->name
50 #define FTH_HOOK_DATA(Obj) FTH_HOOK_OBJECT(Obj)->data
51 #define FTH_HOOK_REQ(Obj) FTH_HOOK_OBJECT(Obj)->req
52 #define FTH_HOOK_OPT(Obj) FTH_HOOK_OBJECT(Obj)->opt
53 #define FTH_HOOK_REST(Obj) FTH_HOOK_OBJECT(Obj)->rest
54 #define FTH_HOOK_LENGTH(Obj) simple_array_length(FTH_HOOK_DATA(Obj))
55
56 static void ficl_create_hook(ficlVm *);
57 static void ficl_hook_apply(ficlVm *);
58 static void ficl_hook_arity(ficlVm *);
59 static void ficl_hook_empty_p(ficlVm *);
60 static void ficl_hook_equal_p(ficlVm *);
61 static void ficl_hook_member_p(ficlVm *);
62 static void ficl_hook_name(ficlVm *);
63 static void ficl_hook_p(ficlVm *);
64 static void ficl_make_hook(ficlVm *);
65 static void ficl_print_hook(ficlVm *);
66 static FTH hk_apply(FTH, FTH);
67 static FTH hk_dump(FTH);
68 static FTH hk_equal_p(FTH, FTH);
69 static void hk_free(FTH);
70 static FTH hk_inspect(FTH);
71 static FTH hk_length(FTH);
72 static FTH hk_ref(FTH, FTH);
73 static FTH hk_to_array(FTH);
74 static FTH hk_to_string(FTH);
75 static FTH make_hook(const char *, int, int, int, const char *);
76
77 #define h_list_of_hook_functions "\
78 *** HOOK PRIMITIVES ***\n\
79 .hook ( hook -- )\n\
80 add-hook! alias for hook-add\n\
81 create-hook ( arity help \"name\" -- )\n\
82 hook->array ( hook -- ary )\n\
83 hook->list alias for hook->array\n\
84 hook-add ( hook prc -- )\n\
85 hook-apply ( hook args -- value-list )\n\
86 hook-arity ( hook -- arity )\n\
87 hook-clear ( hook -- )\n\
88 hook-delete ( hook prc-or-name -- prc )\n\
89 hook-empty? ( hook -- f )\n\
90 hook-member? ( hook prc-or-name -- f )\n\
91 hook-name ( hook -- name )\n\
92 hook-names ( hook -- name-list )\n\
93 hook-procs alias for hook->array\n\
94 hook= ( obj1 obj2 -- f )\n\
95 hook? ( obj -- f )\n\
96 make-hook ( arity -- hook )\n\
97 remove-hook! alias for hook-delete\n\
98 reset-hook! alias for hook-clear\n\
99 run-hook alias for hook-apply"
100
101 #define FTH_HOOK_REST_STR(hook) (FTH_HOOK_REST(hook) ? "#t" : "#f")
102
103 static FTH
hk_inspect(FTH self)104 hk_inspect(FTH self)
105 {
106 int len;
107 FTH fs;
108
109 len = FTH_HOOK_LENGTH(self);
110 fs = fth_make_string_format("%s ", FTH_INSTANCE_NAME(self));
111 fth_string_sformat(fs, "%s: ", FTH_HOOK_NAME(self));
112 fth_string_sformat(fs, "%d/", FTH_HOOK_REQ(self));
113 fth_string_sformat(fs, "%d/", FTH_HOOK_OPT(self));
114 fth_string_sformat(fs, "%s, ", FTH_HOOK_REST_STR(self));
115 fth_string_sformat(fs, "procs[%d]", len);
116
117 if (len > 0) {
118 int i;
119
120 fth_string_scat(fs, ":");
121
122 for (i = 0; i < len; i++) {
123 FTH prc;
124
125 prc = (FTH) simple_array_ref(FTH_HOOK_DATA(self), i);
126 fth_string_sformat(fs, " %s", fth_proc_name(prc));
127 }
128 }
129 return (fs);
130 }
131
132 static FTH
hk_to_string(FTH self)133 hk_to_string(FTH self)
134 {
135 return (fth_make_string(FTH_HOOK_NAME(self)));
136 }
137
138 static FTH
hk_dump(FTH self)139 hk_dump(FTH self)
140 {
141 int i;
142 int len;
143 FTH fs;
144
145 fs = fth_make_string("\\ Doesn't work with lambda: words!\n");
146 fth_string_sformat(fs, "[ifundef] %s\n", FTH_HOOK_NAME(self));
147 fth_string_sformat(fs, "\t#( %d ", FTH_HOOK_REQ(self));
148 fth_string_sformat(fs, "%d ", FTH_HOOK_OPT(self));
149 fth_string_sformat(fs, "%s ) \"no doc\" ", FTH_HOOK_REST_STR(self));
150 fth_string_sformat(fs, "create-hook %s\n", FTH_HOOK_NAME(self));
151 fth_string_scat(fs, "[then]\n");
152
153 len = FTH_HOOK_LENGTH(self);
154
155 for (i = 0; i < len; i++) {
156 ficlWord *word;
157 FTH prc;
158
159 prc = (FTH) simple_array_ref(FTH_HOOK_DATA(self), i);
160 word = FICL_WORD_REF(prc);
161
162 if (word->length > 0) {
163 fth_string_sformat(fs, "%s <'> ", FTH_HOOK_NAME(self));
164 fth_string_sformat(fs, "%s add-hook!\n", word->name);
165 }
166 }
167 return (fs);
168 }
169
170 /* return array of procs */
171 static FTH
hk_to_array(FTH self)172 hk_to_array(FTH self)
173 {
174 return (simple_array_to_array(FTH_HOOK_DATA(self)));
175 }
176
177 static FTH
hk_ref(FTH self,FTH idx)178 hk_ref(FTH self, FTH idx)
179 {
180 return ((FTH)simple_array_ref(FTH_HOOK_DATA(self), FIX_TO_INT32(idx)));
181 }
182
183 static FTH
hk_equal_p(FTH self,FTH obj)184 hk_equal_p(FTH self, FTH obj)
185 {
186 int flag;
187
188 flag = FTH_HOOK_REQ(self) == FTH_HOOK_REQ(obj) &&
189 FTH_HOOK_OPT(self) == FTH_HOOK_OPT(obj) &&
190 FTH_HOOK_REST(self) == FTH_HOOK_REST(obj) &&
191 simple_array_equal_p(FTH_HOOK_DATA(self), FTH_HOOK_DATA(obj));
192 return (BOOL_TO_FTH(flag));
193 }
194
195 static FTH
hk_length(FTH self)196 hk_length(FTH self)
197 {
198 int len;
199
200 len = FTH_HOOK_LENGTH(self);
201 return (fth_make_int((ficlInteger) len));
202 }
203
204 static void
hk_free(FTH self)205 hk_free(FTH self)
206 {
207 FTH_FREE(FTH_HOOK_NAME(self));
208 simple_array_free(FTH_HOOK_DATA(self));
209 FTH_FREE(FTH_HOOK_OBJECT(self));
210 }
211
212 static FTH
hk_apply(FTH self,FTH args)213 hk_apply(FTH self, FTH args)
214 {
215 return (fth_hook_apply(self, args, RUNNING_WORD()));
216 }
217
218 static void
ficl_hook_p(ficlVm * vm)219 ficl_hook_p(ficlVm *vm)
220 {
221 #define h_hook_p "( obj -- f ) test if OBJ is a hook\n\
222 2 make-hook hook? => #t\n\
223 nil hook? => #f\n\
224 Return #t if OBJ is a hook object, otherwise #f."
225 FTH obj;
226
227 FTH_STACK_CHECK(vm, 1, 1);
228 obj = fth_pop_ficl_cell(vm);
229 ficlStackPushBoolean(vm->dataStack, FTH_HOOK_P(obj));
230 }
231
232 static FTH
make_hook(const char * name,int req,int opt,int rest,const char * doc)233 make_hook(const char *name, int req, int opt, int rest, const char *doc)
234 {
235 ficlWord *w;
236 FHook *hk;
237 FTH hook;
238
239 hk = FTH_MALLOC(sizeof(FHook));
240 hk->name = FTH_STRDUP(name);
241 hk->req = req;
242 hk->opt = opt;
243 hk->rest = rest;
244 hk->data = make_simple_array(8);
245 hook = fth_make_instance(hook_tag, hk);
246 w = ficlDictionaryAppendConstant(FTH_FICL_DICT(),
247 (char *) hk->name, (ficlInteger) hook);
248 fth_word_doc_set(w, doc);
249 return (hook);
250 }
251
252 FTH
fth_make_hook_with_arity(const char * name,int req,int opt,int rest,const char * doc)253 fth_make_hook_with_arity(const char *name, int req, int opt, int rest,
254 const char *doc)
255 {
256 return (make_hook(name, req, opt, rest, doc));
257 }
258
259 /*
260 * Return a Hook object called NAME with ARITY required arguments, 0
261 * optional arguments and no rest arguments. An optional documentation
262 * DOC can be provided.
263 */
264 FTH
fth_make_hook(const char * name,int arity,const char * doc)265 fth_make_hook(const char *name, int arity, const char *doc)
266 {
267 return (make_hook(name, arity, 0, 0, doc));
268 }
269
270 static int simple_hook_number = 0;
271
272 /*
273 * Return a Hook object with ARITY required arguments, 0 optional
274 * arguments and no rest arguments.
275 */
276 FTH
fth_make_simple_hook(int arity)277 fth_make_simple_hook(int arity)
278 {
279 char *name;
280 FTH hk;
281
282 name = fth_format("simple-%02d-hook", simple_hook_number++);
283 hk = make_hook(name, arity, 0, 0, NULL);
284 FTH_FREE(name);
285 return (hk);
286 }
287
288 static void
ficl_create_hook(ficlVm * vm)289 ficl_create_hook(ficlVm *vm)
290 {
291 #define h_create_hook "( arity help \"name\" -- ) create hook\n\
292 2 \"A simple hook.\" create-hook my-new-hook\n\
293 #( 2 0 #f ) \"A simple hook.\" create-hook my-new-hook\n\
294 my-new-hook <'> + 2 make-proc add-hook!\n\
295 my-new-hook #( 2 3 ) run-hook => #( 5 )\n\
296 my-new-hook => #<hook my-new-hook: 2/0/0, procs[1]: +>\n\
297 help my-new-hook => A simple hook.\n\
298 Create hook variable NAME with ARITY and documentation HELP. \
299 ARITY can be an integer or an array of length 3, #( req opt rest ).\n\
300 See also make-hook."
301 int req;
302 int opt;
303 int rest;
304 char *help;
305 FTH arity;
306
307 FTH_STACK_CHECK(vm, 2, 0);
308 ficlVmGetWordToPad(vm);
309 help = pop_cstring(vm);
310 arity = fth_pop_ficl_cell(vm);
311 opt = 0;
312 rest = 0;
313
314 if (fth_array_length(arity) == 3) {
315 req = FIX_TO_INT32(fth_array_fast_ref(arity, 0L));
316 opt = FIX_TO_INT32(fth_array_fast_ref(arity, 1L));
317 rest = FTH_TO_BOOL(fth_array_fast_ref(arity, 2L));
318 } else
319 req = FIX_TO_INT32(arity);
320
321 make_hook(vm->pad, req, opt, rest, help);
322 }
323
324 static void
ficl_make_hook(ficlVm * vm)325 ficl_make_hook(ficlVm *vm)
326 {
327 #define h_make_hook "( arity -- hk ) create hook\n\
328 2 make-hook value my-new-hook\n\
329 #( 2 0 #f ) make-hook value my-new-hook\n\
330 my-new-hook <'> + 2 make-proc add-hook!\n\
331 my-new-hook #( 2 3 ) run-hook => #( 5 )\n\
332 my-new-hook => #<hook simple-00-hook: 2/0/0, procs[1]: +>\n\
333 Return hook object for procs accepting ARITY arguments. \
334 ARITY can be an integer or an array of length 3, #( req opt rest ).\n\
335 See also create-hook."
336 int req;
337 int opt;
338 int rest;
339 char *name;
340 FTH arity;
341 FTH hook;
342
343 FTH_STACK_CHECK(vm, 1, 1);
344 arity = fth_pop_ficl_cell(vm);
345 opt = 0;
346 rest = 0;
347
348 if (fth_array_length(arity) == 3) {
349 req = FIX_TO_INT32(fth_array_fast_ref(arity, 0L));
350 opt = FIX_TO_INT32(fth_array_fast_ref(arity, 1L));
351 rest = FTH_TO_BOOL(fth_array_fast_ref(arity, 2L));
352 } else
353 req = FIX_TO_INT32(arity);
354
355 name = fth_format("simple-%02d-hook", simple_hook_number++);
356 hook = make_hook(name, req, opt, rest, NULL);
357 FTH_FREE(name);
358 ficlStackPushFTH(vm->dataStack, hook);
359 }
360
361 static void
ficl_print_hook(ficlVm * vm)362 ficl_print_hook(ficlVm *vm)
363 {
364 #define h_print_hook "( hk -- ) print hook\n\
365 2 make-hook .hook => hook simple-01-hook: 2/0/#f, procs[0]\n\
366 Print hook object HK to current output."
367 FTH hook;
368
369 FTH_STACK_CHECK(vm, 1, 0);
370 hook = ficlStackPopFTH(vm->dataStack);
371 FTH_ASSERT_ARGS(FTH_HOOK_P(hook), hook, FTH_ARG1, "a hook");
372 fth_print(fth_string_ref(hk_inspect(hook)));
373 }
374
375 int
fth_hook_equal_p(FTH obj1,FTH obj2)376 fth_hook_equal_p(FTH obj1, FTH obj2)
377 {
378 if (FTH_HOOK_P(obj1) && FTH_HOOK_P(obj2))
379 return (FTH_TO_BOOL(hk_equal_p(obj1, obj2)));
380
381 return (0);
382 }
383
384 static void
ficl_hook_equal_p(ficlVm * vm)385 ficl_hook_equal_p(ficlVm *vm)
386 {
387 #define h_hook_equal_p "( hk1 hk2 -- f ) compare hooks\n\
388 2 make-hook value hk1\n\
389 2 make-hook value hk2\n\
390 3 make-hook value hk3\n\
391 hk1 hk2 hook= => #t\n\
392 hk1 hk3 hook= => #f\n\
393 Return #t if HK1 and HK2 are hook objects of same arity and procedures, \
394 otherwise #f."
395 FTH obj1;
396 FTH obj2;
397
398 FTH_STACK_CHECK(vm, 2, 1);
399 obj2 = fth_pop_ficl_cell(vm);
400 obj1 = fth_pop_ficl_cell(vm);
401 ficlStackPushBoolean(vm->dataStack, fth_hook_equal_p(obj1, obj2));
402 }
403
404 /*
405 * Return array of all HOOK procedures.
406 */
407 FTH
fth_hook_to_array(FTH hook)408 fth_hook_to_array(FTH hook)
409 {
410 #define h_hook_to_array "( hook -- ary ) return hook procedures\n\
411 2 make-hook value hk1\n\
412 hk1 <'> + 2 make-proc add-hook!\n\
413 hk1 hook->array => #( + )\n\
414 Return array of all HOOK procedures."
415 FTH_ASSERT_ARGS(FTH_HOOK_P(hook), hook, FTH_ARG1, "a hook");
416 return (hk_to_array(hook));
417 }
418
419 int
fth_hook_arity(FTH hook)420 fth_hook_arity(FTH hook)
421 {
422 if (FTH_HOOK_P(hook))
423 return (FTH_HOOK_REQ(hook));
424
425 return (0);
426 }
427
428 static void
ficl_hook_arity(ficlVm * vm)429 ficl_hook_arity(ficlVm *vm)
430 {
431 #define h_hook_arity "( hook -- arity ) return hook arity\n\
432 2 make-hook hook-arity => #( 2 0 #f )\n\
433 Return arity array of HOOK, #( req opt rest )."
434 FTH hook;
435 FTH arity;
436
437 FTH_STACK_CHECK(vm, 1, 1);
438 hook = ficlStackPopFTH(vm->dataStack);
439 FTH_ASSERT_ARGS(FTH_HOOK_P(hook), hook, FTH_ARG1, "a hook");
440 arity = fth_make_array_var(3,
441 INT_TO_FIX(FTH_HOOK_REQ(hook)),
442 INT_TO_FIX(FTH_HOOK_OPT(hook)),
443 BOOL_TO_FTH(FTH_HOOK_REST(hook)));
444 ficlStackPushFTH(vm->dataStack, arity);
445 }
446
447 static void
ficl_hook_name(ficlVm * vm)448 ficl_hook_name(ficlVm *vm)
449 {
450 #define h_hook_name "( obj -- name|#f ) return name of OBJ\n\
451 2 make-hook hook-name => \"simple-01-hook\"\n\
452 Return name of OBJ as string if hook object, otherwise #f."
453 FTH hook;
454
455 FTH_STACK_CHECK(vm, 1, 1);
456 hook = ficlStackPopFTH(vm->dataStack);
457
458 if (FTH_HOOK_P(hook))
459 push_cstring(vm, FTH_HOOK_NAME(hook));
460 else
461 ficlStackPushBoolean(vm->dataStack, 0);
462 }
463
464 /*
465 * Add hook procedure PROC_OR_XT to HOOK. Raise BAD_ARITY exception
466 * if PROC_OR_XT's arity doesn't match HOOK's arity.
467 */
468 void
fth_add_hook(FTH hook,FTH proc_or_xt)469 fth_add_hook(FTH hook, FTH proc_or_xt)
470 {
471 #define h_add_hook "( hook proc-or-xt -- ) add PROC-OR-XT to HOOK\n\
472 2 make-hook value hk1\n\
473 <'> + 2 make-proc value prc\n\
474 hk1 prc add-hook!\n\
475 hk1 hook-names => #( \"+\" )\n\
476 Add hook procedure PROC-OR-XT to HOOK. \
477 Raise BAD-ARITY exception if PROC-OR-XT's arity doesn't match HOOK's arity."
478 FTH proc;
479
480 FTH_ASSERT_ARGS(FTH_HOOK_P(hook), hook, FTH_ARG1, "a hook");
481 proc = proc_from_proc_or_xt(proc_or_xt,
482 FTH_HOOK_REQ(hook),
483 FTH_HOOK_OPT(hook),
484 FTH_HOOK_REST(hook));
485
486 if (!FTH_PROC_P(proc)) {
487 FTH_ASSERT_ARGS(FTH_PROC_P(proc), proc, FTH_ARG2,
488 "a proc or xt");
489 /* NOTREACED */
490 return;
491 }
492 if (FTH_HOOK_REQ(hook) == FICL_WORD_REQ(proc) &&
493 FTH_HOOK_OPT(hook) == FICL_WORD_OPT(proc) &&
494 FTH_HOOK_REST(hook) == FICL_WORD_REST(proc))
495 simple_array_push(FTH_HOOK_DATA(hook), (void *) proc);
496 else
497 FTH_BAD_ARITY_ERROR_ARGS(FTH_ARG2, proc,
498 FTH_HOOK_REQ(hook),
499 FTH_HOOK_OPT(hook),
500 FTH_HOOK_REST(hook),
501 FICL_WORD_REQ(proc),
502 FICL_WORD_OPT(proc),
503 FICL_WORD_REST(proc));
504 }
505
506 FTH
fth_remove_hook(FTH hook,FTH proc_or_name)507 fth_remove_hook(FTH hook, FTH proc_or_name)
508 {
509 #define h_remove_hook "( hook proc-or-name -- proc|#f ) remove PROC-OR-NAME\n\
510 2 make-hook value hk1\n\
511 hk1 <'> + 2 make-proc add-hook!\n\
512 hk1 \"+\" remove-hook!\n\
513 hk1 <'> + remove-hook!\n\
514 Remove hook procedure PROC-OR-NAME from HOOK and return it. \
515 PROC-OR-NAME can be a string, an xt or a proc."
516 char *name;
517 ficlWord *word;
518
519 FTH_ASSERT_ARGS(FTH_HOOK_P(hook), hook, FTH_ARG1, "a hook");
520
521 if (FICL_WORD_P(proc_or_name)) {
522 word = FICL_WORD_REF(proc_or_name);
523 return ((FTH) simple_array_delete(FTH_HOOK_DATA(hook), word));
524 }
525 name = fth_string_ref(proc_or_name);
526
527 if (name == NULL)
528 return (FTH_FALSE);
529
530 word = FICL_WORD_NAME_REF(name);
531
532 if (word == NULL)
533 return (FTH_FALSE);
534
535 return ((FTH) simple_array_delete(FTH_HOOK_DATA(hook), word));
536 }
537
538 int
fth_hook_member_p(FTH hook,FTH proc_or_name)539 fth_hook_member_p(FTH hook, FTH proc_or_name)
540 {
541 char *name;
542 ficlWord *word;
543
544 FTH_ASSERT_ARGS(FTH_HOOK_P(hook), hook, FTH_ARG1, "a hook");
545
546 if (FICL_WORD_P(proc_or_name)) {
547 word = FICL_WORD_REF(proc_or_name);
548 return (simple_array_member_p(FTH_HOOK_DATA(hook), word));
549 }
550 name = fth_string_ref(proc_or_name);
551
552 if (name == NULL)
553 return (0);
554
555 word = FICL_WORD_NAME_REF(name);
556
557 if (word == NULL)
558 return (0);
559
560 return (simple_array_member_p(FTH_HOOK_DATA(hook), word));
561 }
562
563 static void
ficl_hook_member_p(ficlVm * vm)564 ficl_hook_member_p(ficlVm *vm)
565 {
566 #define h_hook_member_p "( hook proc-or-name -- f ) find PROC-OR-NAME\n\
567 2 make-hook value hk1\n\
568 hk1 <'> + 2 make-proc add-hook!\n\
569 hook \"+\" hook-member? => #t\n\
570 hook <'> + hook-member? => #t\n\
571 Return #t if procedure PROC-OR-NAME exist in HOOK, otherwise #f. \
572 PROC-OR-NAME can be a string, an xt or a proc."
573 int flag;
574 FTH hook;
575 FTH proc_or_name;
576
577 FTH_STACK_CHECK(vm, 2, 1);
578 proc_or_name = fth_pop_ficl_cell(vm);
579 hook = ficlStackPopFTH(vm->dataStack);
580 flag = fth_hook_member_p(hook, proc_or_name);
581 ficlStackPushBoolean(vm->dataStack, flag);
582 }
583
584 /*
585 * Return true if no hook procedure exist in HOOK, otherwise false.
586 */
587 int
fth_hook_empty_p(FTH hook)588 fth_hook_empty_p(FTH hook)
589 {
590 if (FTH_HOOK_P(hook))
591 return (FTH_HOOK_LENGTH(hook) == 0);
592
593 return (1);
594 }
595
596 static void
ficl_hook_empty_p(ficlVm * vm)597 ficl_hook_empty_p(ficlVm *vm)
598 {
599 #define h_hook_empty_p "( hook -- f ) test if HOOK is empty\n\
600 2 make-hook value hk1\n\
601 hk1 <'> + 2 make-proc add-hook!\n\
602 hk1 hook-empty? => #f\n\
603 hk1 <'> + remove-hook! => +\n\
604 hk1 hook-empty? => #t\n\
605 Return #t if no hook procedure exist in HOOK, otherwise #f."
606 FTH hook;
607 int flag;
608
609 FTH_STACK_CHECK(vm, 1, 1);
610 hook = ficlStackPopFTH(vm->dataStack);
611 flag = fth_hook_empty_p(hook);
612 ficlStackPushBoolean(vm->dataStack, flag);
613 }
614
615 /*-
616 * fth_run_hook(hook, num-of-args, ...)
617 *
618 * hook: hook object
619 * len: number of arguments, must equal arity
620 * ...: len args
621 *
622 * return array of results of all hook-procedures
623 */
624 FTH
fth_run_hook(FTH hook,int len,...)625 fth_run_hook(FTH hook, int len,...)
626 {
627 ficlInteger i;
628 va_list list;
629 FTH args;
630
631 FTH_ASSERT_ARGS(FTH_HOOK_P(hook), hook, FTH_ARG1, "a hook");
632
633 if (FTH_HOOK_REQ(hook) > len) {
634 FTH_BAD_ARITY_ERROR_ARGS(FTH_ARG1, hook, len, 0, 0,
635 FTH_HOOK_REQ(hook),
636 FTH_HOOK_OPT(hook),
637 FTH_HOOK_REST(hook));
638 /* NOTREACHED */
639 return (FTH_FALSE);
640 }
641 args = fth_make_array_len((ficlInteger) len);
642 va_start(list, len);
643
644 for (i = 0; i < len; i++)
645 fth_array_fast_set(args, i, va_arg(list, FTH));
646
647 va_end(list);
648 return (fth_hook_apply(hook, args, RUNNING_WORD()));
649 }
650
651 /*-
652 * For concatenating strings; the return value of a proc_n is set as
653 * index 0 of the input args-list for proc_n + 1.
654 *
655 * args = #( name pos )
656 *
657 * for (i = 0; i < len; i++)
658 * fth_array_set(args, 0, fth_proc_apply(proc, args, func))
659 */
660 FTH
fth_run_hook_again(FTH hook,int len,...)661 fth_run_hook_again(FTH hook, int len,...)
662 {
663 int i;
664 va_list list;
665 FTH args;
666
667 FTH_ASSERT_ARGS(FTH_HOOK_P(hook), hook, FTH_ARG1, "a hook");
668
669 if (FTH_HOOK_REQ(hook) > len) {
670 FTH_BAD_ARITY_ERROR_ARGS(FTH_ARG1, hook, len, 0, 0,
671 FTH_HOOK_REQ(hook),
672 FTH_HOOK_OPT(hook),
673 FTH_HOOK_REST(hook));
674 /* NOTREACHED */
675 return (FTH_FALSE);
676 }
677 args = fth_make_array_len((ficlInteger) len);
678 va_start(list, len);
679
680 for (i = 0; i < len; i++)
681 fth_array_fast_set(args, (ficlInteger) i, va_arg(list, FTH));
682
683 va_end(list);
684
685 for (i = 0; i < FTH_HOOK_LENGTH(hook); i++) {
686 FTH prc;
687 FTH res;
688
689 prc = (FTH) simple_array_ref(FTH_HOOK_DATA(hook), i);
690 res = fth_proc_apply(prc, args, RUNNING_WORD());
691 fth_array_fast_set(args, 0L, res);
692 }
693
694 return (fth_array_ref(args, 0L));
695 }
696
697 /*-
698 * Return #t if hook is empty or any of the procs didn't return #f,
699 * otherwise #f.
700 */
701 FTH
fth_run_hook_bool(FTH hook,int len,...)702 fth_run_hook_bool(FTH hook, int len,...)
703 {
704 int i;
705 va_list list;
706 FTH args;
707 FTH ret;
708
709 FTH_ASSERT_ARGS(FTH_HOOK_P(hook), hook, FTH_ARG1, "a hook");
710
711 if (FTH_HOOK_REQ(hook) > len) {
712 FTH_BAD_ARITY_ERROR_ARGS(FTH_ARG1, hook, len, 0, 0,
713 FTH_HOOK_REQ(hook),
714 FTH_HOOK_OPT(hook),
715 FTH_HOOK_REST(hook));
716 /* NOTREACHED */
717 return (FTH_FALSE);
718 }
719 args = fth_make_array_len((ficlInteger) len);
720 va_start(list, len);
721
722 for (i = 0; i < len; i++)
723 fth_array_fast_set(args, (ficlInteger) i, va_arg(list, FTH));
724
725 va_end(list);
726 ret = FTH_TRUE;
727
728 for (i = 0; i < FTH_HOOK_LENGTH(hook); i++) {
729 FTH prc;
730 FTH res;
731
732 prc = (FTH) simple_array_ref(FTH_HOOK_DATA(hook), i);
733 res = fth_proc_apply(prc, args, RUNNING_WORD());
734
735 if (FTH_FALSE_P(res))
736 ret = FTH_FALSE;
737 }
738
739 return (ret);
740 }
741
742 /*-
743 * fth_hook_apply
744 * return array of results of all hook-procedures
745 */
746 FTH
fth_hook_apply(FTH hook,FTH args,const char * caller)747 fth_hook_apply(FTH hook, FTH args, const char *caller)
748 {
749 int i;
750 int len;
751 FTH ret;
752
753 FTH_ASSERT_ARGS(FTH_HOOK_P(hook), hook, FTH_ARG1, "a hook");
754 len = FTH_HOOK_LENGTH(hook);
755 ret = fth_make_array_len((ficlInteger) len);
756
757 for (i = 0; i < len; i++) {
758 FTH prc;
759 FTH res;
760
761 prc = (FTH) simple_array_ref(FTH_HOOK_DATA(hook), i);
762 res = fth_proc_apply(prc, args, caller);
763 fth_array_fast_set(ret, (ficlInteger) i, res);
764 }
765
766 return (ret);
767 }
768
769 static void
ficl_hook_apply(ficlVm * vm)770 ficl_hook_apply(ficlVm *vm)
771 {
772 #define h_hook_apply "( hook args -- value-list ) run procs of HOOK\n\
773 2 make-hook value hk1\n\
774 hk1 <'> + 2 make-proc add-hook!\n\
775 hk1 #( 1 2 ) run-hook => #( 3 )\n\
776 Run all hook procedures with ARGS, an array of arguments. \
777 ARGS can be an array of arguments or a single argument. \
778 Raise BAD-ARITY exception if ARGS's length doesn't match HOOK's arity."
779 FTH hook;
780 FTH res;
781 FTH args;
782
783 FTH_STACK_CHECK(vm, 2, 1);
784 args = fth_pop_ficl_cell(vm);
785 hook = ficlStackPopFTH(vm->dataStack);
786
787 if (!FTH_ARRAY_P(args))
788 args = fth_make_empty_array();
789
790 res = fth_hook_apply(hook, args, RUNNING_WORD_VM(vm));
791 ficlStackPushFTH(vm->dataStack, res);
792 }
793
794 /*
795 * Remove all hook procedures from HOOK.
796 */
797 void
fth_hook_clear(FTH hook)798 fth_hook_clear(FTH hook)
799 {
800 #define h_hook_clear "( hook -- ) clear hook\n\
801 2 make-hook value hk1\n\
802 hk1 hook-clear\n\
803 Remove all hook procedures from HOOK."
804 FTH_ASSERT_ARGS(FTH_HOOK_P(hook), hook, FTH_ARG1, "a hook");
805 simple_array_clear(FTH_HOOK_DATA(hook));
806 }
807
808 FTH
fth_hook_names(FTH hook)809 fth_hook_names(FTH hook)
810 {
811 #define h_hook_names "( hook -- name-list ) return proc-names\n\
812 2 make-hook value hk1\n\
813 hk1 <'> + 2 make-proc add-hook!\n\
814 hk1 hook-names => #( \"+\" )\n\
815 Return array of hook procedure names (strings)."
816 int i;
817 int len;
818 FTH names;
819
820 FTH_ASSERT_ARGS(FTH_HOOK_P(hook), hook, FTH_ARG1, "a hook");
821 len = FTH_HOOK_LENGTH(hook);
822 names = fth_make_array_len((ficlInteger) len);
823
824 for (i = 0; i < len; i++) {
825 FTH prc;
826 FTH fs;
827
828 prc = (FTH) simple_array_ref(FTH_HOOK_DATA(hook), i);
829 fs = fth_make_string(fth_proc_name(prc));
830 fth_array_fast_set(names, (ficlInteger) i, fs);
831 }
832
833 return (names);
834 }
835
836 void
init_hook_type(void)837 init_hook_type(void)
838 {
839 /* init hook */
840 hook_tag = make_object_type(FTH_STR_HOOK, FTH_HOOK_T);
841 fth_set_object_inspect(hook_tag, hk_inspect);
842 fth_set_object_to_string(hook_tag, hk_to_string);
843 fth_set_object_dump(hook_tag, hk_dump);
844 fth_set_object_to_array(hook_tag, hk_to_array);
845 fth_set_object_value_ref(hook_tag, hk_ref);
846 fth_set_object_equal_p(hook_tag, hk_equal_p);
847 fth_set_object_length(hook_tag, hk_length);
848 fth_set_object_free(hook_tag, hk_free);
849 }
850
851 void
init_hook(void)852 init_hook(void)
853 {
854 fth_set_object_apply(hook_tag, (void *) hk_apply, 1, 0, 0);
855 /* hook */
856 FTH_PRI1("hook?", ficl_hook_p, h_hook_p);
857 FTH_PRI1("create-hook", ficl_create_hook, h_create_hook);
858 FTH_PRI1("make-hook", ficl_make_hook, h_make_hook);
859 FTH_PRI1(".hook", ficl_print_hook, h_print_hook);
860 FTH_PRI1("hook=", ficl_hook_equal_p, h_hook_empty_p);
861 FTH_PROC("hook->array", fth_hook_to_array, 1, 0, 0, h_hook_to_array);
862 FTH_PROC("hook-procs", fth_hook_to_array, 1, 0, 0, h_hook_to_array);
863 FTH_PROC("hook->list", fth_hook_to_array, 1, 0, 0, h_hook_to_array);
864 FTH_PRI1("hook-arity", ficl_hook_arity, h_hook_arity);
865 FTH_PRI1("hook-name", ficl_hook_name, h_hook_name);
866 FTH_VOID_PROC("hook-add", fth_add_hook, 2, 0, 0, h_add_hook);
867 FTH_VOID_PROC("add-hook!", fth_add_hook, 2, 0, 0, h_add_hook);
868 FTH_PROC("hook-delete", fth_remove_hook, 2, 0, 0, h_remove_hook);
869 FTH_PROC("remove-hook!", fth_remove_hook, 2, 0, 0, h_remove_hook);
870 FTH_PRI1("hook-member?", ficl_hook_member_p, h_hook_member_p);
871 FTH_PRI1("hook-empty?", ficl_hook_empty_p, h_hook_empty_p);
872 FTH_PRI1("hook-apply", ficl_hook_apply, h_hook_apply);
873 FTH_PRI1("run-hook", ficl_hook_apply, h_hook_apply);
874 FTH_VOID_PROC("hook-clear", fth_hook_clear, 1, 0, 0, h_hook_clear);
875 FTH_VOID_PROC("reset-hook!", fth_hook_clear, 1, 0, 0, h_hook_clear);
876 FTH_PROC("hook-names", fth_hook_names, 1, 0, 0, h_hook_names);
877 FTH_ADD_FEATURE_AND_INFO(FTH_STR_HOOK, h_list_of_hook_functions);
878 }
879
880 /*
881 * hook.c ends here
882 */
883