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 * @(#)proc.c 2.8 11/18/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 #define FICL_WORD_DOC(Obj) \
37 fth_word_property_ref((FTH)(Obj), FTH_SYMBOL_DOCUMENTATION)
38 #define FICL_WORD_SRC(Obj) \
39 fth_word_property_ref((FTH)(Obj), FTH_SYMBOL_SOURCE)
40 #define FICL_WORD_FILE(Obj) \
41 FICL_WORD_REF(Obj)->file
42 #define FICL_WORD_LINE(Obj) \
43 FICL_WORD_REF(Obj)->line
44 #define FICL_WORD_CURRENT_WORD(Obj) \
45 FICL_WORD_REF(Obj)->current_word
46 #define FICL_WORD_CURRENT_FILE(Obj) \
47 FICL_WORD_REF(Obj)->current_file
48 #define FICL_WORD_CURRENT_LINE(Obj) \
49 FICL_WORD_REF(Obj)->current_line
50 #define FICL_WORD_CURRENT_NAME(Obj) \
51 FICL_WORD_NAME(FICL_WORD_CURRENT_WORD(Obj))
52
53 static char proc_scratch[FICL_PAD_SIZE];
54
55 static void ficl_proc_p(ficlVm *);
56 static void ficl_thunk_p(ficlVm *);
57 static void ficl_word_p(ficlVm *);
58 static void ficl_xt_p(ficlVm *);
59
60 static FTH execute_proc(ficlVm *, ficlWord *, int, const char *);
61 static void ficl_args_keys_paren_co(ficlVm *);
62 static void ficl_args_optional_paren_co(ficlVm *);
63 static void ficl_begin_definition(ficlVm *);
64 static void ficl_constant(ficlVm *);
65 static void ficl_defined_p(ficlVm *);
66 static void ficl_doc_quote_co_im(ficlVm *);
67 static void ficl_empty_extended_args_co_im(ficlVm *);
68 static void ficl_extended_args_co_im(ficlVm *);
69 static void ficl_filename_im(ficlVm *);
70 static void ficl_get_func_name_co_im(ficlVm *);
71 static void ficl_get_help(ficlVm *);
72 static void ficl_get_optarg(ficlVm *);
73 static void ficl_get_optargs(ficlVm *);
74 static void ficl_get_optkey(ficlVm *);
75 static void ficl_get_optkeys(ficlVm *);
76 static void ficl_help_add(ficlVm *);
77 static void ficl_help_ref(ficlVm *);
78 static void ficl_help_set(ficlVm *);
79 static void ficl_lambda_definition(ficlVm *);
80 static void ficl_latestxt(ficlVm *);
81 static void ficl_latestxt_co_im(ficlVm *);
82 static void ficl_lineno_im(ficlVm *);
83 static void ficl_local_variables_co_im(ficlVm *);
84 static void ficl_local_variables_paren_co(ficlVm *);
85 static void ficl_make_proc(ficlVm *);
86 static void ficl_print_proc(ficlVm *);
87 static void ficl_proc_apply(ficlVm *);
88 static void ficl_proc_arity(ficlVm *);
89 static void ficl_proc_create_co(ficlVm *);
90 static void ficl_proc_name(ficlVm *);
91 static void ficl_proc_to_xt(ficlVm *);
92 static void ficl_see(ficlVm *);
93 static void ficl_set_bang_im(ficlVm *);
94 static void ficl_set_execute(ficlVm *);
95 static void ficl_set_xt(ficlVm *);
96 static void ficl_tick_set_im(ficlVm *);
97 static void ficl_value(ficlVm *);
98 static void ficl_word_create_co(ficlVm *);
99 static FTH ficl_word_to_source(ficlDictionary *, ficlCell *);
100 static void ficl_xt_to_name(ficlVm *);
101 static void ficl_xt_to_origin(ficlVm *);
102 static char *get_help(FTH, char *);
103 static ficlString get_string_from_tib(ficlVm *, int);
104 static char *help_formatted(char *, int);
105 static FTH local_vars_cb(FTH, FTH, FTH);
106 static ficlWord *make_procedure(const char *,
107 void *, int, int, int, int, const char *);
108 static void word_documentation(ficlVm *, ficlWord *);
109
110 /* === PROC === */
111
112 #define h_list_of_proc_functions "\
113 *** PROC PRIMITIVES ***\n\
114 *filename* ( -- name )\n\
115 *lineno* ( -- n )\n\
116 .proc ( proc -- )\n\
117 <'set> ( \"name\" -- set-xt|#f )\n\
118 <{ ... }> ( ?? -- ?? )\n\
119 defined? ( \"name\" -- f )\n\
120 doc\" ( <ccc>\" -- )\n\
121 documentation-ref ( obj -- str )\n\
122 documentation-set! ( obj str -- )\n\
123 get-func-name ( -- name )\n\
124 get-optarg ( req def -- val )\n\
125 get-optargs ( lst req -- vals )\n\
126 get-optkey ( key def -- val )\n\
127 get-optkeys ( lst req -- vals )\n\
128 help ( \"name\" -- )\n\
129 help-add! ( obj str -- )\n\
130 help-ref ( obj -- str )\n\
131 help-set! ( obj str -- )\n\
132 lambda-create ( -- )\n\
133 lambda: ( -- xt )\n\
134 latestxt ( -- xt )\n\
135 local-variables ( -- vars )\n\
136 make-proc ( xt arity -- proc )\n\
137 proc->xt ( proc -- xt )\n\
138 proc-apply ( proc args -- value )\n\
139 proc-arity ( proc -- arity-list )\n\
140 proc-create ( arity -- proc )\n\
141 proc-name ( proc -- name )\n\
142 proc-source-ref ( proc -- str )\n\
143 proc-source-set! ( proc str -- )\n\
144 proc? ( obj -- f )\n\
145 run-proc alias for proc-apply\n\
146 running-word ( -- xt )\n\
147 see2 ( \"name\" -- )\n\
148 set! ( \"name\" -- )\n\
149 set-execute ( xt -- ?? )\n\
150 set-xt ( xt -- set-xt|#f )\n\
151 source-file ( xt -- file )\n\
152 source-line ( xt -- line )\n\
153 source-ref ( obj -- str )\n\
154 source-set! ( obj str -- )\n\
155 thunk? ( obj -- f )\n\
156 trace-var ( variable-xt proc-or-xt -- )\n\
157 untrace-var ( variable-xt -- )\n\
158 word? ( obj -- f )\n\
159 xt->name ( xt -- str )\n\
160 xt->origin ( xt -- str )\n\
161 xt? ( obj -- f )"
162
163 /*-
164 * Test if OBJ is an already defined word, a variable or constant
165 * or any other object in the dictionary.
166 *
167 * FTH x = (FTH)FICL_WORD_NAME_REF("bye");
168 * fth_word_defined_p(x); => true
169 * fth_variable_set("hello", FTH_FALSE);
170 * FTH x = (FTH)FICL_WORD_NAME_REF("hello");
171 * fth_word_defined_p(x); => true
172 * fth_word_defined_p(FTH_FALSE); => false
173 */
174 int
fth_word_defined_p(FTH obj)175 fth_word_defined_p(FTH obj)
176 {
177 if (obj == 0 || IMMEDIATE_P(obj))
178 return (0);
179 return (ficlDictionaryIncludes(FTH_FICL_DICT(), FICL_WORD_REF(obj)));
180 }
181
182 /*-
183 * Test if OBJ is of TYPE where type can be:
184 * FW_WORD
185 * FW_PROC
186 * FW_SYMBOL
187 * FW_KEYWORD
188 * FW_EXCEPTION
189 * FW_VARIABLE
190 * FW_TRACE_VAR
191 *
192 * FTH x = (FTH)FICL_WORD_NAME_REF("bye");
193 * fth_word_type_p(x, FW_WORD); => true
194 * fth_word_type_p(x, FW_KEYWORD); => false
195 */
196 int
fth_word_type_p(FTH obj,int type)197 fth_word_type_p(FTH obj, int type)
198 {
199 return (FICL_WORD_DEFINED_P(obj) && FICL_WORD_TYPE(obj) == type);
200 }
201
202 static void
ficl_proc_p(ficlVm * vm)203 ficl_proc_p(ficlVm *vm)
204 {
205 #define h_proc_p "( obj -- f ) test if OBJ is a proc object\n\
206 <'> + proc? => #f\n\
207 <'> source-file proc? => #t\n\
208 Return #t if OBJ is a proc object, otherwise #f.\n\
209 See also thunk?, xt?, word?."
210 FTH obj;
211
212 FTH_STACK_CHECK(vm, 1, 1);
213 obj = ficlStackPopFTH(vm->dataStack);
214 ficlStackPushBoolean(vm->dataStack, FTH_PROC_P(obj));
215 }
216
217 static void
ficl_thunk_p(ficlVm * vm)218 ficl_thunk_p(ficlVm *vm)
219 {
220 #define h_thunk_p "( obj -- f ) test if OBJ is proc object\n\
221 <'> source-file thunk? => #f\n\
222 lambda: <{ -- }> ; thunk? => #t\n\
223 Return #t if OBJ is a proc object with arity #( 0 0 #f ), otherwise #f.\n\
224 See also proc?, xt?, word?."
225 FTH obj;
226 int flag;
227
228 FTH_STACK_CHECK(vm, 1, 1);
229 obj = ficlStackPopFTH(vm->dataStack);
230 flag = FTH_PROC_P(obj) &&
231 FICL_WORD_REQ(obj) == 0 &&
232 FICL_WORD_OPT(obj) == 0 &&
233 FICL_WORD_REST(obj) == 0;
234 ficlStackPushBoolean(vm->dataStack, flag);
235 }
236
237 static void
ficl_xt_p(ficlVm * vm)238 ficl_xt_p(ficlVm *vm)
239 {
240 #define h_xt_p "( obj -- f ) test if OBJ is an xt\n\
241 lambda: <{}> ; xt? => #f\n\
242 <'> make-array xt? => #t\n\
243 Return #t if OBJ is an xt (execution token, address of a Ficl word), \
244 otherwise #f.\n\
245 See also proc?, thunk?, word?."
246 FTH obj;
247
248 FTH_STACK_CHECK(vm, 1, 1);
249 obj = ficlStackPopFTH(vm->dataStack);
250 ficlStackPushBoolean(vm->dataStack, FTH_WORD_P(obj));
251 }
252
253 static void
ficl_word_p(ficlVm * vm)254 ficl_word_p(ficlVm *vm)
255 {
256 #define h_word_p "( obj -- f ) test if OBJ is proc or xt\n\
257 10 word? => #f\n\
258 lambda: <{}> ; word? => #t\n\
259 Return #t if OBJ is a proc object or xt (execution token, \
260 address of a Ficl word), otherwise #f.\n\
261 See also proc?, thunk?, xt?."
262 FTH obj;
263
264 FTH_STACK_CHECK(vm, 1, 1);
265 obj = ficlStackPopFTH(vm->dataStack);
266 ficlStackPushBoolean(vm->dataStack, FICL_WORD_P(obj));
267 }
268
269 static ficlWord *
make_procedure(const char * name,void * func,int void_p,int req,int opt,int rest,const char * doc)270 make_procedure(const char *name, void *func, int void_p,
271 int req, int opt, int rest, const char *doc)
272 {
273 ficlWord *word;
274
275 if (FICL_WORD_P(func))
276 word = FICL_WORD_REF(func);
277 else {
278 FTH fnc;
279
280 fnc = void_p ? ficl_execute_void_func : ficl_execute_func;
281 word = ficlDictionaryAppendPrimitive(FTH_FICL_DICT(),
282 (char *) name, (ficlPrimitive) fnc, FICL_WORD_DEFAULT);
283 }
284 word->req = req;
285 word->opt = opt;
286 word->rest = rest;
287 word->argc = req + opt + rest;
288 word->kind = FW_PROC;
289
290 if (void_p)
291 word->vfunc = (void (*) ()) func;
292 else
293 word->func = (FTH (*) ()) func;
294
295 if (doc != NULL && FTH_FALSE_P(FICL_WORD_DOC(word)))
296 fth_word_doc_set(word, doc);
297
298 return (word);
299 }
300
301 FTH
fth_make_proc(ficlWord * word,int req,int opt,int rest)302 fth_make_proc(ficlWord *word, int req, int opt, int rest)
303 {
304 if (word != NULL && FICL_WORD_P(word)) {
305 ficlWord *prc;
306 char *name;
307
308 name = FICL_WORD_NAME(word);
309 prc = make_procedure(name, word, 0, req, opt, rest, NULL);
310 return ((FTH) prc);
311 }
312 FTH_ASSERT_ARGS(0, (FTH) word, FTH_ARG1, "an existing ficl word");
313 return (FTH_FALSE);
314 }
315
316 FTH
fth_make_proc_from_func(const char * name,FTH (* func)(),int void_p,int req,int opt,int rest)317 fth_make_proc_from_func(const char *name,
318 FTH (*func) (), int void_p, int req, int opt, int rest)
319 {
320 ficlWord *prc;
321
322 prc = make_procedure(name, (void *) func, void_p, req, opt, rest, NULL);
323 return ((FTH) prc);
324 }
325
326 /*
327 * Return new ficlWord NAME tied to C function FUNC with REQ required
328 * arguments, OPT optional arguments and REST (1) or no REST (0)
329 * arguments with optional documentation string DOC. FUNC takes zero
330 * or more FTH objects and returns a FTH object.
331 */
332 ficlWord *
fth_define_procedure(const char * name,FTH (* func)(),int req,int opt,int rest,const char * doc)333 fth_define_procedure(const char *name,
334 FTH (*func) (), int req, int opt, int rest, const char *doc)
335 {
336 return (make_procedure(name, (void *) func, 0, req, opt, rest, doc));
337 }
338
339 /*
340 * Return new ficlWord NAME tied to C function FUNC with REQ required
341 * arguments, OPT optional arguments and REST (1) or no REST (0)
342 * arguments with optional documentation string DOC. FUNC takes zero
343 * or more FTH objects and doesn't return any (void).
344 */
345 ficlWord *
fth_define_void_procedure(const char * name,void (* f)(),int req,int opt,int rest,const char * doc)346 fth_define_void_procedure(const char *name,
347 void (*f) (), int req, int opt, int rest, const char *doc)
348 {
349 return (make_procedure(name, (void *) f, 1, req, opt, rest, doc));
350 }
351
352 static void
ficl_make_proc(ficlVm * vm)353 ficl_make_proc(ficlVm *vm)
354 {
355 #define h_make_proc "( xt arity -- proc ) return proc object\n\
356 <'> + 2 make-proc value plus1\n\
357 lambda: ( a b -- c ) + ; #( 2 0 #f ) make-proc value plus2\n\
358 plus1 #( 0 1 ) proc-apply => 1\n\
359 plus2 #( 2 3 ) proc-apply => 5\n\
360 Return new proc object. \
361 ARITY can be an integer or an array of length 3, #( req opt rest )."
362 FTH arity, prc;
363 ficlWord *word;
364 int req, opt, rest;
365
366 FTH_STACK_CHECK(vm, 2, 1);
367 arity = fth_pop_ficl_cell(vm);
368 word = ficlStackPopPointer(vm->dataStack);
369 opt = 0;
370 rest = 0;
371
372 if (fth_array_length(arity) == 3) {
373 req = FIX_TO_INT32(fth_array_ref(arity, 0L));
374 opt = FIX_TO_INT32(fth_array_ref(arity, 1L));
375 rest = FTH_TO_BOOL(fth_array_ref(arity, 2L));
376 } else
377 req = FIX_TO_INT32(arity);
378
379 prc = fth_make_proc(word, req, opt, rest);
380 ficlStackPushFTH(vm->dataStack, prc);
381 }
382
383 static void
ficl_print_proc(ficlVm * vm)384 ficl_print_proc(ficlVm *vm)
385 {
386 #define h_print_proc "( prc -- ) print proc\n\
387 <'> + 2 make-proc .proc => #<proc +: 2/0/#f>\n\
388 Print proc object PRC to current output."
389 FTH proc;
390
391 FTH_STACK_CHECK(vm, 1, 0);
392 proc = ficlStackPopFTH(vm->dataStack);
393
394 if (FTH_PROC_P(proc))
395 fth_printf("#<proc %s: %d/%d/%s>",
396 FICL_WORD_NAME(proc),
397 FICL_WORD_REQ(proc),
398 FICL_WORD_OPT(proc),
399 FICL_WORD_REST(proc) ? "#t" : "#f");
400 else
401 fth_print("not a proc object");
402 }
403
404 /*
405 * If PROC is a Proc object, return required arguments as C int,
406 * otherwise return 0.
407 */
408 int
fth_proc_arity(FTH proc)409 fth_proc_arity(FTH proc)
410 {
411 if (FTH_PROC_P(proc))
412 return (FICL_WORD_REQ(proc));
413 return (0);
414 }
415
416 static void
ficl_proc_arity(ficlVm * vm)417 ficl_proc_arity(ficlVm *vm)
418 {
419 #define h_proc_arity "( prc -- arity ) return arity of PROC\n\
420 <'> + proc-arity => #f\n\
421 <'> source-line proc-arity => #( 1 0 #f )\n\
422 Return arity array #( req opt rest ) of proc object PRC, \
423 or #f if not a proc object."
424 ficlWord *proc;
425
426 FTH_STACK_CHECK(vm, 1, 1);
427 proc = ficlStackPopPointer(vm->dataStack);
428
429 if (FTH_PROC_P(proc)) {
430 FTH ary;
431
432 ary = FTH_LIST_3(INT_TO_FIX(FICL_WORD_REQ(proc)),
433 INT_TO_FIX(FICL_WORD_OPT(proc)),
434 BOOL_TO_FTH(FICL_WORD_REST(proc)));
435 ficlStackPushFTH(vm->dataStack, ary);
436 } else
437 ficlStackPushBoolean(vm->dataStack, 0);
438 }
439
440 /*
441 * If OBJ is a ficlWord, return name as C string, otherwise return
442 * "not-a-proc".
443 */
444 static char proc_not_a_word[] = "not-a-proc";
445 static char proc_no_name[] = "noname";
446
447 char *
fth_proc_name(FTH obj)448 fth_proc_name(FTH obj)
449 {
450 if (FICL_WORD_P(obj)) {
451 if (FICL_WORD_REF(obj)->length > 0)
452 return (FICL_WORD_NAME(obj));
453 return (proc_no_name);
454 }
455 return (proc_not_a_word);
456 }
457
458 static void
ficl_proc_name(ficlVm * vm)459 ficl_proc_name(ficlVm *vm)
460 {
461 #define h_proc_name "( prc -- name ) return name of PROC\n\
462 <'> + proc-name => \"+\"\n\
463 Return name of proc object PRC if found, otherwise an empty string."
464 FTH fs;
465 ficlWord *proc;
466
467 FTH_STACK_CHECK(vm, 1, 1);
468 proc = ficlStackPopPointer(vm->dataStack);
469
470 if (FICL_WORD_P(proc)) {
471 if (FICL_WORD_REF(proc)->length > 0)
472 fs = FTH_WORD_NAME(proc);
473 else
474 fs = fth_make_string("noname");
475 } else
476 fs = fth_make_empty_string();
477 ficlStackPushFTH(vm->dataStack, fs);
478 }
479
480 /*
481 * Return source string property of PROC, or FTH_FALSE if not available.
482 */
483 FTH
fth_proc_source_ref(FTH proc)484 fth_proc_source_ref(FTH proc)
485 {
486 #define h_proc_source_ref "( proc-or-xt -- str ) return source string\n\
487 <'> + 2 make-proc value plus\n\
488 plus proc-source-ref => \"+\"\n\
489 Return source string of PROC-OR-XT, or #f if not available."
490 FTH src;
491
492 FTH_ASSERT_ARGS(FICL_WORD_P(proc), proc, FTH_ARG1, "a proc or xt");
493 src = fth_source_ref(proc);
494 return (FTH_NOT_FALSE_P(src) ? src : fth_word_to_string(proc));
495 }
496
497 /*
498 * Set source string property of PROC to SOURCE.
499 */
500 void
fth_proc_source_set(FTH proc,FTH source)501 fth_proc_source_set(FTH proc, FTH source)
502 {
503 #define h_proc_source_set "( prc str -- ) set source string\n\
504 <'> + 2 make-proc value plus\n\
505 plus #( 1 2 ) proc-apply => 3\n\
506 plus \": plus ( n1 n2 -- n3 ) + ;\" proc-source-set!\n\
507 plus proc-source-ref => \": plus ( n1 n2 -- n3 ) + ;\"\n\
508 Set source string property of PRC to STR."
509 FTH_ASSERT_ARGS(FICL_WORD_P(proc), proc, FTH_ARG1, "a proc or xt");
510 fth_source_set(proc, source);
511 }
512
513 ficlWord *
fth_proc_to_xt(FTH proc)514 fth_proc_to_xt(FTH proc)
515 {
516 if (FICL_WORD_P(proc))
517 return (FICL_WORD_REF(proc));
518 return (NULL);
519 }
520
521 static void
ficl_proc_to_xt(ficlVm * vm)522 ficl_proc_to_xt(ficlVm *vm)
523 {
524 #define h_proc_to_xt "( prc -- xt ) return xt\n\
525 <'> source-line proc->xt => source-line\n\
526 Return the actual word (the execution token xt) of PRC."
527 ficlWord *proc;
528
529 FTH_STACK_CHECK(vm, 1, 1);
530 proc = ficlStackPopPointer(vm->dataStack);
531
532 if (FICL_WORD_P(proc))
533 ficlStackPushPointer(vm->dataStack, FICL_WORD_REF(proc));
534 else
535 ficlStackPushBoolean(vm->dataStack, 0);
536 }
537
538 static FTH
execute_proc(ficlVm * vm,ficlWord * word,int depth,const char * caller)539 execute_proc(ficlVm *vm, ficlWord *word, int depth, const char *caller)
540 {
541 int status;
542 ficlInteger new_depth, i;
543 FTH ret;
544 char *s;
545
546 s = caller != NULL ? (char *) caller : "execute_proc";
547 status = fth_execute_xt(vm, word);
548
549 switch (status) {
550 case FICL_VM_STATUS_ERROR_EXIT:
551 case FICL_VM_STATUS_ABORT:
552 case FICL_VM_STATUS_ABORTQ:
553 if (word->length > 0)
554 ficlVmThrowException(vm, status,
555 "%s: can't execute %S",
556 s, fth_word_inspect((FTH) word));
557 else
558 ficlVmThrowException(vm, status,
559 "%s: can't execute word %p", s, word);
560 break;
561 default:
562 break;
563 }
564
565 /* collect values from stack */
566 if (FTH_STACK_DEPTH(vm) > depth) {
567 /* One entry: return single value. */
568 new_depth = FTH_STACK_DEPTH(vm) - depth;
569
570 if (new_depth == 1)
571 return (fth_pop_ficl_cell(vm));
572
573 /* More than one entries: -> return array with values. */
574 ret = fth_make_array_len(new_depth);
575
576 for (i = 0; i < new_depth; i++)
577 fth_array_fast_set(ret, i, fth_pop_ficl_cell(vm));
578
579 return (ret);
580 }
581 /* If nothing added to stack (no return value), return #f. */
582 return (FTH_FALSE);
583 }
584
585 /*-
586 * Executes NAME, a C string, with LEN arguments of type FTH.
587 * CALLER can be any C string used for error message. Raise an
588 * EVAL_ERROR exception if an error occured during evaluation.
589 *
590 * If the xt with NAME doesn't leave a return value on stack, return
591 * FTH_FALSE, if a single value remains on stack, return it, if
592 * more than one values remain on stack, return them as Array
593 * object.
594 *
595 * no ret => #f
596 * ret => ret
597 * ret1 ret2 => #( ret1 ret2 ... )
598 *
599 * FTH fs = fth_make_string("hello, world!");
600 * FTH re = fth_make_regexp(", (.*)!");
601 *
602 * fth_xt_call("regexp-match", __func__, 2, re, fs); => 8
603 * return (fth_xt_call("*re1*", __func__, 0)); => "world"
604 */
605 FTH
fth_xt_call(const char * name,const char * caller,int len,...)606 fth_xt_call(const char *name, const char *caller, int len,...)
607 {
608 int depth;
609 va_list list;
610 ficlInteger i;
611 ficlWord *xt;
612 ficlVm *vm;
613 ficlString s;
614
615 if (name == NULL || *name == '\0')
616 return (FTH_FALSE);
617
618 FICL_STRING_SET_FROM_CSTRING(s, name);
619 xt = ficlDictionaryLookup(FTH_FICL_DICT(), s);
620
621 if (xt == NULL)
622 return (FTH_FALSE);
623
624 vm = FTH_FICL_VM();
625 depth = FTH_STACK_DEPTH(vm);
626 va_start(list, len);
627
628 for (i = 0; i < len; i++)
629 fth_push_ficl_cell(vm, va_arg(list, FTH));
630
631 va_end(list);
632 return (execute_proc(vm, xt, depth, caller));
633 }
634
635 /*-
636 * Executes Name, a C string, with array length arguments of type
637 * FTH. CALLER can be any C string used for error message. Raise
638 * an EVAL_ERROR exception if an error occured during evaluation.
639 *
640 * If the xt with NAME doesn't leave a return value on stack, return
641 * FTH_FALSE, if a single value remains on stack, return it, if
642 * more than one values remain on stack, return them as Array
643 * object.
644 *
645 * no ret => #f
646 * ret => ret
647 * ret1 ret2 => #( ret1 ret2 ... )
648 *
649 * FTH fs = fth_make_string("hello, world!");
650 * FTH re = fth_make_regexp(", (.*)!");
651 * FTH ary = fth_make_array_var(2, re, fs);
652 *
653 * fth_xt_apply("regexp-match", ary, __func__); => 8
654 * return (fth_xt_apply("*re1*", FTH_FALSE, __func__)); => "world"
655 */
656 FTH
fth_xt_apply(const char * name,FTH args,const char * caller)657 fth_xt_apply(const char *name, FTH args, const char *caller)
658 {
659 int depth, len;
660 ficlInteger i;
661 ficlWord *xt;
662 ficlVm *vm;
663 ficlString s;
664
665 if (name == NULL || *name == '\0')
666 return (FTH_FALSE);
667
668 FICL_STRING_SET_FROM_CSTRING(s, name);
669 xt = ficlDictionaryLookup(FTH_FICL_DICT(), s);
670
671 if (xt == NULL)
672 return (FTH_FALSE);
673
674 len = 0;
675
676 if (FTH_ARRAY_P(args))
677 len = (int) fth_array_length(args);
678
679 vm = FTH_FICL_VM();
680 depth = FTH_STACK_DEPTH(vm);
681
682 for (i = 0; i < len; i++)
683 fth_push_ficl_cell(vm, fth_array_fast_ref(args, i));
684
685 return (execute_proc(vm, xt, depth, caller));
686 }
687
688 /*-
689 * If PROC is a Proc object, execute its ficlWord with LEN arguments
690 * on stack. CALLER can be any C string used for error message. Raise a
691 * BAD_ARITY exception if PROC has more required arguments than LEN.
692 * Raise an EVAL_ERROR exception if an error occured during evaluation.
693 *
694 * If PROC is not a Proc object, return FTH_FALSE, if PROC doesn't
695 * leave a return value on stack, return FTH_FALSE, if PROC leaves a
696 * single value on stack, return it, if PROC leaves more than one
697 * values on stack, return them as Array object.
698 *
699 * !proc => #f
700 * no ret => #f
701 * ret => ret
702 * ret1 ret2 => #( ret1 ret2 ... )
703 */
704 FTH
fth_proc_call(FTH proc,const char * caller,int len,...)705 fth_proc_call(FTH proc, const char *caller, int len,...)
706 {
707 int depth;
708 va_list list;
709 ficlInteger i;
710 ficlVm *vm;
711
712 if (!FTH_PROC_P(proc))
713 return (FTH_FALSE);
714
715 if (FICL_WORD_REQ(proc) > len)
716 FTH_BAD_ARITY_ERROR_ARGS(FTH_ARG1,
717 proc, len, 0, 0,
718 FICL_WORD_REQ(proc),
719 FICL_WORD_OPT(proc),
720 FICL_WORD_REST(proc));
721
722 if (len > FICL_WORD_LENGTH(proc))
723 len = FICL_WORD_LENGTH(proc);
724
725 vm = FTH_FICL_VM();
726 depth = FTH_STACK_DEPTH(vm);
727 va_start(list, len);
728
729 for (i = 0; i < len; i++)
730 fth_push_ficl_cell(vm, va_arg(list, FTH));
731
732 va_end(list);
733 return (execute_proc(vm, FICL_WORD_REF(proc), depth, caller));
734 }
735
736 /*-
737 * If PROC is a Proc object, execute its ficlWord with Array object
738 * ARGS as arguments on stack. CALLER can be any C string used for
739 * error message. Raise a BAD_ARITY exception if PROC has more required
740 * arguments than length of ARGS. Raise an EVAL_ERROR exception if an
741 * error occured during evaluation.
742 *
743 * If PROC is not a Proc object, return FTH_FALSE, if PROC doesn't
744 * leave a return value on stack, return FTH_FALSE, if PROC leaves a
745 * single value on stack, return it, if PROC leaves more than one
746 * values on stack, return them as Array object.
747 *
748 * !proc => #f
749 * no ret => #f
750 * ret => ret
751 * ret1 ret2 => #( ret1 ret2 ... )
752 */
753 FTH
fth_proc_apply(FTH proc,FTH args,const char * caller)754 fth_proc_apply(FTH proc, FTH args, const char *caller)
755 {
756 int depth, len;
757 ficlInteger i;
758 ficlVm *vm;
759
760 if (proc == 0 || !FTH_PROC_P(proc))
761 return (FTH_FALSE);
762
763 FTH_ASSERT_ARGS(FTH_ARRAY_P(args), args, FTH_ARG2, "an array");
764 len = (int) fth_array_length(args);
765
766 if (FICL_WORD_REQ(proc) > len)
767 FTH_BAD_ARITY_ERROR_ARGS(FTH_ARG1,
768 proc, len, 0, 0,
769 FICL_WORD_REQ(proc),
770 FICL_WORD_OPT(proc),
771 FICL_WORD_REST(proc));
772
773 if (len > FICL_WORD_LENGTH(proc))
774 len = FICL_WORD_LENGTH(proc);
775
776 vm = FTH_FICL_VM();
777 depth = FTH_STACK_DEPTH(vm);
778
779 for (i = 0; i < len; i++)
780 fth_push_ficl_cell(vm, fth_array_fast_ref(args, i));
781
782 return (execute_proc(vm, FICL_WORD_REF(proc), depth, caller));
783 }
784
785 static void
ficl_proc_apply(ficlVm * vm)786 ficl_proc_apply(ficlVm *vm)
787 {
788 #define h_proc_apply "( prc args -- res ) run PRC with ARGS\n\
789 <'> + 2 make-proc value plus\n\
790 plus #( 1 2 ) proc-apply => 3\n\
791 Execute proc object PRC with argument ARGS and return result or #f. \
792 ARGS can be an array of arguments or a single argument. \
793 If execution fails, raise EVAL-ERROR exception, \
794 if length of ARGS is less than required arity of PRC, \
795 raise BAD-ARITY exception."
796 FTH proc_or_xt, args, proc;
797
798 FTH_STACK_CHECK(vm, 2, 1);
799 args = fth_pop_ficl_cell(vm);
800 proc_or_xt = ficlStackPopFTH(vm->dataStack);
801
802 if (!FTH_ARRAY_P(args))
803 args = fth_make_array_var(1, args);
804
805 if (FTH_PROC_P(proc_or_xt))
806 proc = proc_or_xt;
807 else if (FTH_WORD_P(proc_or_xt))
808 proc = fth_make_proc(FICL_WORD_REF(proc_or_xt),
809 (int) fth_array_length(args), 0, 0);
810 else
811 proc = FTH_FALSE;
812
813 fth_push_ficl_cell(vm, fth_proc_apply(proc, args, RUNNING_WORD_VM(vm)));
814 }
815
816 static void
ficl_tick_set_im(ficlVm * vm)817 ficl_tick_set_im(ficlVm *vm)
818 {
819 #define h_tick_set_im "( \"name\" -- set-name|#f ) SET-NAME (parse word)\n\
820 <'set> object-print-length => set-object-print-length\n\
821 Parse NAME and search for word SET-NAME. \
822 Return xt of SET-NAME or #f if not found.\n\
823 See also set!, set-xt and set-execute."
824 ficlWord *set_word;
825 ficlString s;
826
827 s = ficlVmGetWord(vm);
828 snprintf(vm->pad, sizeof(vm->pad), "set-%.*s", (int) s.length, s.text);
829 set_word = FICL_WORD_NAME_REF(vm->pad);
830
831 if (set_word == NULL)
832 set_word = FICL_WORD_REF(FTH_FALSE);
833
834 if (vm->state == FICL_VM_STATE_COMPILE) {
835 ficlDictionary *dict;
836 ficlUnsigned u;
837
838 dict = ficlVmGetDictionary(vm);
839 u = (ficlUnsigned) ficlInstructionLiteralParen;
840 ficlDictionaryAppendUnsigned(dict, u);
841 ficlDictionaryAppendPointer(dict, set_word);
842 } else
843 ficlStackPushPointer(vm->dataStack, set_word);
844 }
845
846 static void
ficl_set_bang_im(ficlVm * vm)847 ficl_set_bang_im(ficlVm *vm)
848 {
849 #define h_set_bang_im "( ?? \"name\" -- ?? ) execute SET-NAME (parse word)\n\
850 object-print-length => 12\n\
851 128 set! object-print-length \\ execute actually: \
852 128 set-object-print-length\n\
853 object-print-length => 128\n\
854 Parse NAME and execute word SET-NAME if found, \
855 otherwise raise UNDEFINED-WORD exception.\n\
856 See also <'set>, set-xt and set-execute."
857 ficlWord *word;
858 ficlString s;
859
860 s = ficlVmGetWord(vm);
861 snprintf(vm->pad, sizeof(vm->pad), "set-%.*s", (int) s.length, s.text);
862 word = FICL_WORD_NAME_REF(vm->pad);
863
864 if (word == NULL) {
865 fth_throw(FTH_UNDEFINED, "%s: %s not found",
866 RUNNING_WORD_VM(vm), vm->pad);
867 /* NOTREACHED */
868 return;
869 }
870 if (vm->state == FICL_VM_STATE_COMPILE)
871 ficlDictionaryAppendPointer(ficlVmGetDictionary(vm), word);
872 else
873 fth_execute_xt(vm, word);
874 }
875
876 static void
ficl_set_xt(ficlVm * vm)877 ficl_set_xt(ficlVm *vm)
878 {
879 #define h_set_xt "( xt -- set-xt|#f ) return SET-XT\n\
880 <'> object-print-length set-xt => set-object-print-length\n\
881 Return SET-XT if found, otherwise #f. \
882 See also <'set>, set! and set-execute."
883 FTH obj;
884 ficlWord *word, *set_word;
885
886 FTH_STACK_CHECK(vm, 1, 1);
887 obj = ficlStackPopFTH(vm->dataStack);
888
889 if (!FICL_WORD_P(obj)) {
890 FTH_ASSERT_ARGS(FICL_WORD_P(obj), obj, FTH_ARG1,
891 "a proc or xt");
892 /* NOTREACHED */
893 return;
894 }
895 word = FICL_WORD_REF(obj);
896 snprintf(vm->pad, sizeof(vm->pad), "set-%s", word->name);
897 set_word = FICL_WORD_NAME_REF(vm->pad);
898
899 if (set_word == NULL)
900 set_word = FICL_WORD_REF(FTH_FALSE);
901
902 if (vm->state == FICL_VM_STATE_COMPILE) {
903 ficlDictionary *dict;
904 ficlUnsigned u;
905
906 dict = ficlVmGetDictionary(vm);
907 u = (ficlUnsigned) ficlInstructionLiteralParen;
908 ficlDictionaryAppendUnsigned(dict, u);
909 ficlDictionaryAppendPointer(dict, set_word);
910 } else
911 ficlStackPushPointer(vm->dataStack, set_word);
912 }
913
914 static void
ficl_set_execute(ficlVm * vm)915 ficl_set_execute(ficlVm *vm)
916 {
917 #define h_set_execute "( ?? xt -- ?? ) execute SET-XT\n\
918 object-print-length => 12\n\
919 128 <'> object-print-length set-execute\n\
920 object-print-length => 128\n\
921 Execute SET-XT if found, otherwise raise UNDEFINED-WORD exception.\n\
922 See also <'set>, set! and set-xt."
923 FTH obj;
924 ficlWord *word, *set_word;
925
926 FTH_STACK_CHECK(vm, 1, 1);
927 obj = ficlStackPopFTH(vm->dataStack);
928
929 if (!FICL_WORD_P(obj)) {
930 FTH_ASSERT_ARGS(FICL_WORD_P(obj), obj, FTH_ARG1,
931 "a proc or xt");
932 /* NOTREACHED */
933 return;
934 }
935 word = FICL_WORD_REF(obj);
936 snprintf(vm->pad, sizeof(vm->pad), "set-%s", word->name);
937 set_word = FICL_WORD_NAME_REF(vm->pad);
938
939 if (set_word == NULL) {
940 fth_throw(FTH_UNDEFINED, "%s: %s not found",
941 RUNNING_WORD_VM(vm), vm->pad);
942 /* NOTREACHED */
943 return;
944 }
945 if (vm->state == FICL_VM_STATE_COMPILE)
946 ficlDictionaryAppendPointer(ficlVmGetDictionary(vm), set_word);
947 else
948 fth_execute_xt(vm, set_word);
949 }
950
951 static void
ficl_xt_to_name(ficlVm * vm)952 ficl_xt_to_name(ficlVm *vm)
953 {
954 #define h_xt_to_name "( xt -- str ) return name of XT\n\
955 <'> + xt->name => \"+\"\n\
956 Return name of XT if found, otherwise an empty string."
957 FTH fs;
958 ficlWord *word;
959
960 FTH_STACK_CHECK(vm, 1, 1);
961 word = ficlStackPopPointer(vm->dataStack);
962
963 if (FICL_WORD_DEFINED_P(word))
964 fs = FTH_WORD_NAME(word);
965 else
966 fs = fth_make_empty_string();
967
968 ficlStackPushFTH(vm->dataStack, fs);
969 }
970
971 static void
ficl_xt_to_origin(ficlVm * vm)972 ficl_xt_to_origin(ficlVm *vm)
973 {
974 #define h_xt_to_origin "( xt -- str ) return source origin\n\
975 <'> + xt->origin => \"+:primitive\"\n\
976 <'> make-timer xt->origin\n\
977 => \"make-timer:/usr/local/share/fth/fth-lib/fth.fs:463\"\n\
978 Return name, source file and source line number where XT \
979 was defined (name:file:line). \
980 If XT is a C-primitive, return (name:primitive), if not defined, \
981 return an empty string."
982 FTH fs;
983 ficlWord *word;
984
985 FTH_STACK_CHECK(vm, 1, 1);
986 word = ficlStackPopPointer(vm->dataStack);
987
988 if (FICL_WORD_DEFINED_P(word)) {
989 fs = FTH_WORD_NAME(word);
990
991 if (FICL_WORD_PRIMITIVE_P(word))
992 fth_string_sformat(fs, ":primitive");
993 else
994 fth_string_sformat(fs, ":%S:%ld",
995 FICL_WORD_FILE(word), FICL_WORD_LINE(word));
996 } else
997 fs = fth_make_empty_string();
998
999 ficlStackPushFTH(vm->dataStack, fs);
1000 }
1001
1002 #define MAX_LINE_LENGTH 78
1003
1004 /*
1005 * Returned string must be freed.
1006 */
1007 static char *
help_formatted(char * str,int line_length)1008 help_formatted(char *str, int line_length)
1009 {
1010 size_t len, line_len, size;
1011 char *buffer, *pw, *pstr;
1012
1013 if (str == NULL)
1014 return (NULL);
1015
1016 size = strlen(str) * 2;
1017 buffer = FTH_CALLOC(size, sizeof(char));
1018 pstr = str;
1019 len = 0L;
1020 line_len = (size_t) line_length;
1021
1022 while (pstr != NULL && *pstr != '\0') {
1023 pw = proc_scratch;
1024
1025 while (*pstr != '\0' && !isspace((int) *pstr)) {
1026 *pw++ = *pstr++;
1027 len++;
1028 }
1029
1030 while (*pstr != '\n' && isspace((int) *pstr)) {
1031 *pw++ = *pstr++;
1032 len++;
1033 }
1034
1035 *pw = '\0';
1036
1037 if (len >= line_len) {
1038 len = strlen(proc_scratch);
1039 fth_strcat(buffer, size, "\n");
1040 }
1041 fth_strcat(buffer, size, proc_scratch);
1042
1043 if (*pstr == '\n') {
1044 len = 0L;
1045 pstr++;
1046 fth_strcat(buffer, size, "\n");
1047 }
1048 }
1049
1050 return (buffer);
1051 }
1052
1053 /*
1054 * Returned string must be freed.
1055 */
1056 static char *
get_help(FTH obj,char * name)1057 get_help(FTH obj, char *name)
1058 {
1059 FTH fs;
1060 char *buf, *str, *help;
1061 size_t len;
1062
1063 fs = fth_documentation_ref(obj);
1064
1065 /* symbol? */
1066 if (!FTH_STRING_P(fs) && fth_symbol_p(name))
1067 fs = fth_documentation_ref(fth_symbol(name));
1068
1069 buf = fth_string_ref(fs);
1070
1071 if (buf == NULL)
1072 return (FTH_STRDUP("no documentation available"));
1073
1074 if (name == NULL)
1075 return (help_formatted(buf, MAX_LINE_LENGTH));
1076
1077 /*-
1078 * "play-sound ..."
1079 * "(make-oscil ..."
1080 * name is already in buf
1081 */
1082 len = strlen(name);
1083
1084 if (strncmp(name, buf, len) == 0 || strncmp(name, buf + 1, len) == 0)
1085 return (help_formatted(buf, MAX_LINE_LENGTH));
1086
1087 /*
1088 * FTH_PRI1|PROC ...
1089 */
1090 str = fth_format("%s %s", name, buf);
1091 help = help_formatted(str, MAX_LINE_LENGTH);
1092 FTH_FREE(str);
1093 return (help);
1094 }
1095
1096 static void
ficl_get_help(ficlVm * vm)1097 ficl_get_help(ficlVm *vm)
1098 {
1099 #define h_get_help "( \"name\" -- str ) return documentation (parse word)\n\
1100 help make-array => make-array ( len ...\n\
1101 help *features* => *features* ( -- ) return ...\n\
1102 help array => array *** ARRAY PRIMITIVES *** ...\n\
1103 Print documentation of NAME (Forth word or topic) \
1104 or \"no documentation available\". \
1105 See also help-set!, help-add! and help-ref."
1106 char *help;
1107 ficlWord *word;
1108
1109 ficlVmGetWordToPad(vm);
1110 word = FICL_WORD_NAME_REF(vm->pad);
1111
1112 if (word == NULL)
1113 help = get_help(fth_make_string(vm->pad), vm->pad);
1114 else
1115 help = get_help((FTH) word, vm->pad);
1116
1117 /* help == NULL is no issue here! */
1118 push_cstring(vm, help);
1119 FTH_FREE(help);
1120 }
1121
1122 static void
ficl_help_ref(ficlVm * vm)1123 ficl_help_ref(ficlVm *vm)
1124 {
1125 #define h_help_ref "( obj -- str ) return documentation\n\
1126 \"make-array\" help-ref => \"make-array ( len ...\"\n\
1127 <'> make-array help-ref => \"make-array ( len ...\"\n\
1128 \"*features*\" help-ref => \"*features* ( -- ) return ...\"\n\
1129 <'> *features* help-ref => \"*features* ( -- ) return ...\"\n\
1130 \"array\" help-ref => \"array *** ARRAY PRIMITIVES *** ...\"\n\
1131 Return documentation of OBJ (Forth word, object or topic) \
1132 or \"no documentation available\".\n\
1133 See also help-set!, help-add! and help."
1134 FTH obj;
1135 char *help;
1136
1137 FTH_STACK_CHECK(vm, 1, 1);
1138 obj = ficlStackPopFTH(vm->dataStack);
1139
1140 if (FICL_WORD_DEFINED_P(obj))
1141 help = get_help(obj, FICL_WORD_NAME(obj));
1142 else
1143 help = get_help(obj, fth_string_or_symbol_ref(obj));
1144
1145 /* help == NULL is no issue here! */
1146 push_cstring(vm, help);
1147 FTH_FREE(help);
1148 }
1149
1150 static void
ficl_help_set(ficlVm * vm)1151 ficl_help_set(ficlVm *vm)
1152 {
1153 #define h_help_set "( obj str -- ) set documentation\n\
1154 #( \"behemoth\" \"pumpkin\" \"mugli\" ) value hosts\n\
1155 hosts \"local-net hostnames\" help-set!\n\
1156 hosts help-ref => \"local-net hostnames\"\n\
1157 <'> make-array \"make-array description...\" help-set!\n\
1158 Set documentation of OBJ (Forth word or object) to STR.\n\
1159 See also help, help-add! and help-ref."
1160 FTH obj, str;
1161
1162 FTH_STACK_CHECK(vm, 2, 0);
1163 str = fth_pop_ficl_cell(vm);
1164 obj = fth_pop_ficl_cell(vm);
1165 fth_documentation_set(obj, str);
1166 }
1167
1168 static void
ficl_help_add(ficlVm * vm)1169 ficl_help_add(ficlVm *vm)
1170 {
1171 #define h_help_add "( obj str -- ) append documentation\n\
1172 <'> make-array \"make-array description...\" help-set!\n\
1173 <'> make-array \"further infos\" help-add!\n\
1174 Append STR to documentation of OBJ.\n\
1175 See also help, help-ref, help-set!."
1176 FTH obj, str, help;
1177
1178 FTH_STACK_CHECK(vm, 2, 0);
1179 str = fth_pop_ficl_cell(vm);
1180 obj = fth_pop_ficl_cell(vm);
1181 help = fth_documentation_ref(obj);
1182
1183 if (FTH_STRING_P(help))
1184 fth_string_sformat(help, "\n%S", str);
1185 else
1186 fth_documentation_set(obj, str);
1187 }
1188
1189 /*
1190 * Return documentation property string of OBJ or FTH_FALSE.
1191 */
1192 FTH
fth_documentation_ref(FTH obj)1193 fth_documentation_ref(FTH obj)
1194 {
1195 #define h_doc_ref "( obj -- str|#f ) return documentation\n\
1196 \"make-array\" documentation-ref => \"make-array ( len ...\"\n\
1197 <'> make-array documentation-ref => \"make-array ( len ...\"\n\
1198 Return documentation string of OBJ (Forth word, object or topic) or #f. \
1199 See also documentation-set!."
1200 if (FICL_WORD_DEFINED_P(obj))
1201 return (fth_word_property_ref(obj, FTH_SYMBOL_DOCUMENTATION));
1202
1203 if (FTH_STRING_P(obj)) {
1204 ficlWord *word;
1205
1206 word = FICL_WORD_NAME_REF(fth_string_ref(obj));
1207
1208 if (word != NULL)
1209 return (fth_word_property_ref((FTH) word,
1210 FTH_SYMBOL_DOCUMENTATION));
1211
1212 return (fth_property_ref(obj, FTH_SYMBOL_DOCUMENTATION));
1213 }
1214 return (fth_object_property_ref(obj, FTH_SYMBOL_DOCUMENTATION));
1215 }
1216
1217 /*
1218 * Set documentation property string of any OBJ to DOC.
1219 */
1220 void
fth_documentation_set(FTH obj,FTH doc)1221 fth_documentation_set(FTH obj, FTH doc)
1222 {
1223 #define h_doc_set "( obj str -- ) set documentation\n\
1224 #( \"behemoth\" \"pumpkin\" \"mugli\" ) value hosts\n\
1225 hosts \"local-net hostnames\" documentation-set!\n\
1226 hosts documentation-ref => \"local-net hostnames\"\n\
1227 <'> make-array \"make-array description...\" documentation-set!\n\
1228 Set documentation of any OBJ (Forth word, object or topic) to STR. \
1229 See also documentation-ref."
1230 FTH_ASSERT_ARGS(FTH_STRING_P(doc), doc, FTH_ARG2, "a string");
1231 if (FTH_STRING_P(obj)) {
1232 ficlWord *word;
1233
1234 word = FICL_WORD_NAME_REF(fth_string_ref(obj));
1235 if (word != NULL)
1236 fth_word_property_set((FTH) word,
1237 FTH_SYMBOL_DOCUMENTATION, doc);
1238 else
1239 fth_property_set(obj, FTH_SYMBOL_DOCUMENTATION, doc);
1240 } else if (FICL_WORD_DEFINED_P(obj))
1241 fth_word_property_set(obj, FTH_SYMBOL_DOCUMENTATION, doc);
1242 else
1243 fth_object_property_set(obj, FTH_SYMBOL_DOCUMENTATION, doc);
1244 }
1245
1246 /* obj: ficlWord or proc */
1247 FTH
fth_source_ref(FTH obj)1248 fth_source_ref(FTH obj)
1249 {
1250 #define h_source_ref "( obj -- str|#f ) return source\n\
1251 <'> + 2 make-proc value plus\n\
1252 plus source-ref => \"+\"\n\
1253 Return source string of OBJ, a proc or xt, or #f if not found. \
1254 See also source-set!."
1255 if (FICL_WORD_DEFINED_P(obj))
1256 return (FICL_WORD_SRC(obj));
1257 return (FTH_FALSE);
1258 }
1259
1260 /* obj: ficlWord or proc */
1261 void
fth_source_set(FTH obj,FTH source)1262 fth_source_set(FTH obj, FTH source)
1263 {
1264 #define h_source_set "( obj str -- ) set source\n\
1265 <'> + 2 make-proc value plus\n\
1266 plus #( 1 2 ) proc-apply => 3\n\
1267 plus \": plus ( n1 n2 -- n3 ) + ;\" source-set!\n\
1268 plus source-ref => \": plus ( n1 n2 -- n3 ) + ;\"\n\
1269 Set source string of OBJ, a proc or xt, to STR. \
1270 See also source-ref."
1271 if (FICL_WORD_DEFINED_P(obj))
1272 fth_word_property_set(obj, FTH_SYMBOL_SOURCE, source);
1273 }
1274
1275 /* obj: ficlWord */
1276 FTH
fth_source_file(FTH obj)1277 fth_source_file(FTH obj)
1278 {
1279 #define h_source_file "( xt -- fname ) return source file\n\
1280 <'> + source-file => #f\n\
1281 <'> make-timer source-file => \"/usr/opt/share/nfth/fth-lib/fth.fs\"\n\
1282 Return source file where XT was created or #f if XT is a \
1283 primitive or not defined.\n\
1284 See also source-line."
1285 if (FICL_WORD_DEFINED_P(obj))
1286 return (FICL_WORD_FILE(obj));
1287 return (FTH_FALSE);
1288 }
1289
1290 /* obj: ficlWord */
1291 FTH
fth_source_line(FTH obj)1292 fth_source_line(FTH obj)
1293 {
1294 #define h_source_line "( xt -- source-line ) return source line\n\
1295 <'> + source-line => #f\n\
1296 <'> make-timer source-line => 770\n\
1297 Return source line number where XT was created or #f if XT is a \
1298 primitive or not defined.\n\
1299 See also source-file."
1300 if (FICL_WORD_DEFINED_P(obj) && FICL_WORD_LINE(obj) >= 0)
1301 return (fth_make_int(FICL_WORD_LINE(obj)));
1302 return (FTH_FALSE);
1303 }
1304
1305 /* === Word specific functions. === */
1306
1307 ficlWord *
fth_word_doc_set(ficlWord * word,const char * str)1308 fth_word_doc_set(ficlWord *word, const char *str)
1309 {
1310 if (word != NULL && str != NULL)
1311 fth_word_property_set((FTH) word,
1312 FTH_SYMBOL_DOCUMENTATION, fth_make_string(str));
1313 return (word);
1314 }
1315
1316 /*
1317 * Takes first comment or local variables declaration after word name (on
1318 * same line) as documentation string.
1319 *
1320 * : foo ( a b -- c ) => foo ( a b -- c )
1321 * : foo \ a b -- c => foo \ a b -- c
1322 * : foo { a b -- c } => foo { a b -- c }
1323 */
1324 static void
word_documentation(ficlVm * vm,ficlWord * word)1325 word_documentation(ficlVm *vm, ficlWord *word)
1326 {
1327 char *name, *doc;
1328 ficlInteger idx;
1329 ficlString s;
1330
1331 idx = ficlVmGetTibIndex(vm);
1332 s = ficlVmGetWord0(vm);
1333
1334 /*
1335 * Reset terminal input index. We need only the length of the next
1336 * word.
1337 */
1338 ficlVmSetTibIndex(vm, idx);
1339
1340 if (s.length <= 0)
1341 return;
1342
1343 name = word->length > 0 ? word->name : "noname";
1344
1345 if (s.text[0] == '(') {
1346 s = ficlVmParseString(vm, ')');
1347 doc = fth_format("%s %.*s)", name, (int) s.length, s.text);
1348 } else if (s.text[0] == '{') {
1349 s = ficlVmParseString(vm, '}');
1350 /*
1351 * Reset terminal input index for reading local vars.
1352 */
1353 ficlVmSetTibIndex(vm, idx);
1354 doc = fth_format("%s %.*s}", name, (int) s.length, s.text);
1355 } else if (s.text[0] == '\\') {
1356 s = ficlVmParseString(vm, '\n');
1357 doc = fth_format("%s %.*s", name, (int) s.length, s.text);
1358 } else
1359 doc = fth_format("%s", name);
1360
1361 fth_word_doc_set(word, doc);
1362 FTH_FREE(doc);
1363 }
1364
1365 /* defined in ficl/dictionary.c */
1366 extern char *ficlDictionaryInstructionNames[];
1367
1368 /* from ficl/dictionary.c */
1369 static FTH
ficl_word_to_source(ficlDictionary * dict,ficlCell * cell)1370 ficl_word_to_source(ficlDictionary *dict, ficlCell *cell)
1371 {
1372 FTH fs;
1373 ficlWord *word;
1374 ficlWordKind kind;
1375 ficlCell c;
1376 ficlCountedString *counted;
1377
1378 fs = fth_make_empty_string();
1379
1380 for (; CELL_INT_REF(cell) != ficlInstructionSemiParen; cell++) {
1381 word = CELL_VOIDP_REF(cell);
1382
1383 if (CELL_INT_REF(cell) == ficl_word_location) {
1384 cell += 3;
1385 continue;
1386 }
1387 if (!ficlDictionaryIsAWord(dict, word)) {
1388 /* probably not a word - punt and print value */
1389 fth_string_sformat(fs, "%D ",
1390 ficl_to_fth(CELL_FTH_REF(cell)));
1391 continue;
1392 }
1393
1394 kind = ficlWordClassify(word);
1395
1396 switch (kind) {
1397 case FICL_WORDKIND_INSTRUCTION:
1398 fth_string_sformat(fs, "%s",
1399 ficlDictionaryInstructionNames[(long) word]);
1400 break;
1401 case FICL_WORDKIND_INSTRUCTION_WITH_ARGUMENT:
1402 c = *++cell;
1403 fth_string_sformat(fs, "%D %s",
1404 ficl_to_fth(CELL_FTH_REF(&c)),
1405 ficlDictionaryInstructionNames[(long) word]);
1406 break;
1407 case FICL_WORDKIND_INSTRUCTION_WORD:
1408 fth_string_sformat(fs, "%s", FICL_WORD_NAME(word));
1409 break;
1410 case FICL_WORDKIND_LITERAL:
1411 c = *++cell;
1412
1413 if (ficlDictionaryIsAWord(dict, CELL_VOIDP_REF(&c)) &&
1414 (CELL_INT_REF(&c) >= ficlInstructionLast))
1415 fth_string_sformat(fs, "%s",
1416 FICL_WORD_NAME(CELL_VOIDP_REF(&c)));
1417 else
1418 fth_string_sformat(fs, "%D",
1419 ficl_to_fth(CELL_FTH_REF(&c)));
1420 break;
1421 case FICL_WORDKIND_STRING_LITERAL:
1422 counted = (ficlCountedString *) (void *) ++cell;
1423 cell = (ficlCell *) ficlAlignPointer(counted->text +
1424 counted->length + 1) - 1;
1425 fth_string_sformat(fs, "s\" %.*s\"",
1426 counted->length, counted->text);
1427 break;
1428 case FICL_WORDKIND_CSTRING_LITERAL:
1429 counted = (ficlCountedString *) (void *) ++cell;
1430 cell = (ficlCell *) ficlAlignPointer(counted->text +
1431 counted->length + 1) - 1;
1432 fth_string_sformat(fs, "c\" %.*s\"",
1433 counted->length, counted->text);
1434 break;
1435 case FICL_WORDKIND_BRANCH0:
1436 case FICL_WORDKIND_BRANCH:
1437 case FICL_WORDKIND_QDO:
1438 case FICL_WORDKIND_DO:
1439 case FICL_WORDKIND_LOOP:
1440 case FICL_WORDKIND_OF:
1441 case FICL_WORDKIND_PLOOP:
1442 c = *++cell;
1443 fth_string_sformat(fs, "%s", FICL_WORD_NAME(word));
1444 break;
1445 default:
1446 if (FICL_WORD_DEFINED_P(word))
1447 fth_string_sformat(fs, "%s",
1448 FICL_WORD_NAME(word));
1449 else
1450 fth_string_sformat(fs, "%D",
1451 ficl_to_fth(CELL_FTH_REF(cell)));
1452 break;
1453 }
1454
1455 fth_string_sformat(fs, " ");
1456 }
1457
1458 return (fth_string_sformat(fs, ";"));
1459 }
1460
1461 /*
1462 * XXX: fth_word_to_source
1463 * That's not enough to reconstruct the source...
1464 */
1465 FTH
fth_word_to_source(ficlWord * word)1466 fth_word_to_source(ficlWord *word)
1467 {
1468 ficlDictionary *dict;
1469 FTH fs;
1470
1471 fs = fth_make_empty_string();
1472 dict = FTH_FICL_DICT();
1473
1474 switch (ficlWordClassify(word)) {
1475 case FICL_WORDKIND_COLON:
1476 if (strncmp(FICL_WORD_NAME(word), "lambda", 6L) == 0)
1477 fth_string_sformat(fs, "lambda: ");
1478 else
1479 fth_string_sformat(fs, ": %s ", FICL_WORD_NAME(word));
1480
1481 fth_string_sformat(fs, "%S",
1482 ficl_word_to_source(dict, word->param));
1483 break;
1484 case FICL_WORDKIND_DOES:
1485 fth_string_sformat(fs, "does> %S",
1486 ficl_word_to_source(dict,
1487 FICL_WORD_REF(CELL_VOIDP_REF(word->param))->param));
1488 break;
1489 case FICL_WORDKIND_CREATE:
1490 fth_string_sformat(fs, "create");
1491 break;
1492 case FICL_WORDKIND_VARIABLE:
1493 case FICL_WORDKIND_USER:
1494 fth_string_sformat(fs, "%D %s !",
1495 FTH_WORD_PARAM(word), FICL_WORD_NAME(word));
1496 break;
1497 case FICL_WORDKIND_CONSTANT:
1498 fth_string_sformat(fs, "%D to %s",
1499 FTH_WORD_PARAM(word), FICL_WORD_NAME(word));
1500 break;
1501 default:
1502 fth_string_sformat(fs, "%s \\ primitive ",
1503 FICL_WORD_NAME(word));
1504 break;
1505 }
1506
1507 if (word->flags & FICL_WORD_IMMEDIATE)
1508 fth_string_sformat(fs, " immediate");
1509
1510 if (word->flags & FICL_WORD_COMPILE_ONLY)
1511 fth_string_sformat(fs, " compile-only");
1512
1513 return (fs);
1514 }
1515
1516 static void
ficl_see(ficlVm * vm)1517 ficl_see(ficlVm *vm)
1518 {
1519 #define h_see "( \"name\" -- ) show definition (parse word)\n\
1520 see2 make-timer => \": make-timer timer% %alloc ...\"\n\
1521 Show word definition of NAME.\n\
1522 See also see."
1523 ficlWord *word;
1524
1525 ficlPrimitiveTick(vm);
1526 word = ficlStackPopPointer(vm->dataStack);
1527 ficlStackPushFTH(vm->dataStack, fth_word_to_source(word));
1528 }
1529
1530 static ficlWord *fth_latest_xt;
1531
1532 static void
ficl_latestxt(ficlVm * vm)1533 ficl_latestxt(ficlVm *vm)
1534 {
1535 #define h_latestxt "( -- xt ) return latest xt\n\
1536 latestxt => object-sort>\n\
1537 Return latest defined xt.\n\
1538 See also running-word and get-func-name."
1539 FTH_STACK_CHECK(vm, 0, 1);
1540 ficlStackPushPointer(vm->dataStack, fth_latest_xt);
1541 }
1542
1543 static void
ficl_latestxt_co_im(ficlVm * vm)1544 ficl_latestxt_co_im(ficlVm *vm)
1545 {
1546 #define h_latestxt_co_im "( -- xt ) return current xt\n\
1547 : new-word\n\
1548 running-word xt->name .$ space\n\
1549 10\n\
1550 ;\n\
1551 new-word => new-word 10\n\
1552 Return current xt in word definitions. \
1553 This word is immediate and compile only and can only be \
1554 used in word definitions.\n\
1555 See also get-func-name and latestxt."
1556 ficlDictionary *dict;
1557 ficlUnsigned u;
1558
1559 dict = ficlVmGetDictionary(vm);
1560 u = (ficlUnsigned) ficlInstructionLiteralParen;
1561 ficlDictionaryAppendUnsigned(dict, u);
1562 ficlDictionaryAppendPointer(dict, dict->smudge);
1563 }
1564
1565 static void
ficl_get_func_name_co_im(ficlVm * vm)1566 ficl_get_func_name_co_im(ficlVm *vm)
1567 {
1568 #define h_get_func_name_co_im "( -- str ) return name of current xt\n\
1569 : new-word\n\
1570 get-func-name .$ space\n\
1571 10\n\
1572 ;\n\
1573 new-word => new-word 10\n\
1574 Return name of current xt in word definition as string. \
1575 This word is immediate and compile only and can only be \
1576 used in word definitions.\n\
1577 See also running-word and latestxt."
1578 ficlDictionary *dict;
1579 ficlUnsigned u;
1580
1581 dict = ficlVmGetDictionary(vm);
1582 u = (ficlUnsigned) ficlInstructionLiteralParen;
1583 ficlDictionaryAppendUnsigned(dict, u);
1584 ficlDictionaryAppendFTH(dict, FTH_WORD_NAME(dict->smudge));
1585 }
1586
1587 static void
ficl_filename_im(ficlVm * vm)1588 ficl_filename_im(ficlVm *vm)
1589 {
1590 #define h_filename_im "( -- str ) return current filename\n\
1591 *filename* => \"repl-eval\"\n\
1592 Return currently read filename.\n\
1593 See also *lineno*."
1594 if (vm->state == FICL_VM_STATE_COMPILE) {
1595 ficlDictionary *dict;
1596 ficlUnsigned u;
1597
1598 dict = ficlVmGetDictionary(vm);
1599 u = (ficlUnsigned) ficlInstructionLiteralParen;
1600 ficlDictionaryAppendUnsigned(dict, u);
1601 ficlDictionaryAppendFTH(dict, fth_current_file);
1602 } else
1603 ficlStackPushFTH(vm->dataStack, fth_current_file);
1604 }
1605
1606 static void
ficl_lineno_im(ficlVm * vm)1607 ficl_lineno_im(ficlVm *vm)
1608 {
1609 #define h_lineno_im "( -- u ) return current line number\n\
1610 *lineno* => 3\n\
1611 Return current read line number.\n\
1612 See also *filename*."
1613 if (vm->state == FICL_VM_STATE_COMPILE) {
1614 ficlDictionary *dict;
1615 ficlUnsigned u;
1616
1617 dict = ficlVmGetDictionary(vm);
1618 u = (ficlUnsigned) ficlInstructionLiteralParen;
1619 ficlDictionaryAppendUnsigned(dict, u);
1620 ficlDictionaryAppendInteger(dict, fth_current_line);
1621 } else
1622 ficlStackPushInteger(vm->dataStack, fth_current_line);
1623 }
1624
1625 static void
ficl_doc_quote_co_im(ficlVm * vm)1626 ficl_doc_quote_co_im(ficlVm *vm)
1627 {
1628 #define h_doc_quote_co_im "( space<ccc>\" -- ) set documentation\n\
1629 : new-word ( -- )\n\
1630 doc\" our documentation may contain \\\"double quotes\\\". \\\n\
1631 Escape them with a backslash.\"\n\
1632 \\ we do nothing\n\
1633 ;\n\
1634 help new-word => new-word ( -- ) our documentation may contain \
1635 \"double quotes\". \
1636 Escape them with a backslash.\n\
1637 Add input buffer up to next double quote character '\"' to \
1638 documentation of current word. \
1639 Escape double quote character with backslash if required in documentation. \
1640 It is not necessary to repeat the stack effect if \
1641 it already exist in the word definition. \
1642 This word is immediate and compile only and can \
1643 only be used in word definitions."
1644 ficlWord *smudge;
1645 char *ndoc;
1646 FTH odoc;
1647
1648 /*-
1649 * doc" open file with \"oboe.snd\" open-sound"
1650 * Escape double quote character with backslash.
1651 */
1652 ndoc = parse_input_buffer(vm, "\""); /* must be freed */
1653 smudge = ficlVmGetDictionary(vm)->smudge;
1654 odoc = FICL_WORD_DOC(smudge);
1655
1656 if (FTH_FALSE_P(odoc))
1657 fth_word_doc_set(smudge, ndoc);
1658 else
1659 fth_string_sformat(odoc, " %s", ndoc);
1660
1661 FTH_FREE(ndoc);
1662 }
1663
1664 FTH
fth_get_optkey(FTH key,FTH def)1665 fth_get_optkey(FTH key, FTH def)
1666 {
1667 ficlVm *vm;
1668 int i, depth;
1669 FTH tmp, val;
1670
1671 vm = FTH_FICL_VM();
1672 depth = FTH_STACK_DEPTH(vm);
1673
1674 for (i = 1; i < depth; i++) {
1675 tmp = STACK_FTH_INDEX_REF(vm->dataStack, i);
1676
1677 if (FTH_KEYWORD_P(tmp) && tmp == key) {
1678 /* key */
1679 ficlStackRoll(vm->dataStack, i);
1680 /* drop key */
1681 ficlStackDrop(vm->dataStack, 1);
1682 /* value on top of stack */
1683 ficlStackRoll(vm->dataStack, i - 1);
1684 val = fth_pop_ficl_cell(vm);
1685 return (FTH_UNDEF_P(val) ? def : val);
1686 }
1687 }
1688 return (def);
1689 }
1690
1691 int
fth_get_optkey_fix(FTH key,int def)1692 fth_get_optkey_fix(FTH key, int def)
1693 {
1694 FTH res;
1695
1696 res = fth_get_optkey(key, INT_TO_FIX(def));
1697 return (FIX_TO_INT32(res));
1698 }
1699
1700 ficlInteger
fth_get_optkey_int(FTH key,ficlInteger def)1701 fth_get_optkey_int(FTH key, ficlInteger def)
1702 {
1703 return (fth_int_ref(fth_get_optkey(key, fth_make_int(def))));
1704 }
1705
1706 ficl2Integer
fth_get_optkey_2int(FTH key,ficl2Integer def)1707 fth_get_optkey_2int(FTH key, ficl2Integer def)
1708 {
1709 FTH di;
1710
1711 di = fth_make_long_long(def);
1712 return (fth_long_long_ref(fth_get_optkey(key, di)));
1713 }
1714
1715 char *
fth_get_optkey_str(FTH key,char * def)1716 fth_get_optkey_str(FTH key, char *def)
1717 {
1718 return (fth_string_ref(fth_get_optkey(key, fth_make_string(def))));
1719 }
1720
1721 static void
ficl_get_optkey(ficlVm * vm)1722 ficl_get_optkey(ficlVm *vm)
1723 {
1724 #define h_get_optkey "( key def -- val ) return key value\n\
1725 : optkey-test ( start dur keyword-args -- ary )\n\
1726 :frequency 440.0 get-optkey { freq }\n\
1727 :initial-phase pi get-optkey { phase }\n\
1728 { start dur }\n\
1729 #( start dur freq phase )\n\
1730 ;\n\
1731 0 1 optkey-test => #( 0.0 1.0 440.0 3.14159 )\n\
1732 0 2 :frequency 330.0 optkey-test => #( 0.0 2.0 330.0 3.14159 )\n\
1733 Return either default value DEF or a value found on \
1734 stack determined by keyword KEY. \
1735 It simulates the :key keyword in Lisp/Scheme.\n\
1736 See also <{, get-optarg, get-optkeys, get-optargs."
1737 FTH key, tmp;
1738 int i, depth;
1739
1740 FTH_STACK_CHECK(vm, 2, 1);
1741 ficlStackRoll(vm->dataStack, 1); /* swap */
1742 key = fth_pop_ficl_cell(vm);
1743 depth = FTH_STACK_DEPTH(vm);
1744
1745 for (i = 2; i < depth; i++) {
1746 tmp = STACK_FTH_INDEX_REF(vm->dataStack, i);
1747
1748 if (FTH_KEYWORD_P(tmp) && tmp == key) {
1749 /* key */
1750 ficlStackRoll(vm->dataStack, i);
1751 /* drop key */
1752 ficlStackDrop(vm->dataStack, 1);
1753 /* value on top of stack */
1754 ficlStackRoll(vm->dataStack, i - 1);
1755
1756 /*
1757 * If user specified undef, drop that and use default
1758 * value.
1759 */
1760 if (!FTH_UNDEF_P(STACK_FTH_INDEX_REF(vm->dataStack, 0)))
1761 ficlStackRoll(vm->dataStack, 1);
1762
1763 ficlStackDrop(vm->dataStack, 1);
1764 break;
1765 }
1766 }
1767 }
1768
1769 FTH
fth_get_optarg(ficlInteger req,FTH def)1770 fth_get_optarg(ficlInteger req, FTH def)
1771 {
1772 ficlVm *vm;
1773 FTH val;
1774
1775 vm = FTH_FICL_VM();
1776
1777 if (FTH_STACK_DEPTH(vm) > req) {
1778 val = fth_pop_ficl_cell(vm);
1779 return (FTH_UNDEF_P(val) ? def : val);
1780 }
1781 return (def);
1782 }
1783
1784 static void
ficl_get_optarg(ficlVm * vm)1785 ficl_get_optarg(ficlVm *vm)
1786 {
1787 #define h_get_optarg "( req def -- val ) return value\n\
1788 : optarg-test ( a b c=33 d=44 e=55 -- ary )\n\
1789 4 55 get-optarg { e }\n\
1790 3 44 get-optarg { d }\n\
1791 2 33 get-optarg { c }\n\
1792 { a b }\n\
1793 #( a b c d e )\n\
1794 ;\n\
1795 1 2 optarg-test => #( 1 2 33 44 55 )\n\
1796 1 2 3 4 optarg-test => #( 1 2 3 4 55 )\n\
1797 1 2 3 4 5 6 7 optarg-test => 1 2 #( 3 4 5 6 7 )\n\
1798 Numbers 1 and 2 remain on stack, they are not needed here.\n\
1799 Return either default value DEF or a value found on stack. \
1800 REQ is the sum of required and following optional arguments. \
1801 It simulates the :optional keyword in Lisp/Scheme.\n\
1802 See also <{, get-optkey, get-optkeys, get-optargs."
1803 ficlInteger req;
1804
1805 FTH_STACK_CHECK(vm, 2, 1);
1806 ficlStackRoll(vm->dataStack, 1); /* swap */
1807 req = ficlStackPopInteger(vm->dataStack);
1808
1809 if (FTH_STACK_DEPTH(vm) - 1 > req) {
1810 /* If user specified undef, drop that and use default value. */
1811 if (FTH_UNDEF_P(STACK_FTH_INDEX_REF(vm->dataStack, 1)))
1812 ficlStackRoll(vm->dataStack, 1);
1813 ficlStackDrop(vm->dataStack, 1);
1814 }
1815 }
1816
1817 static void
ficl_get_optkeys(ficlVm * vm)1818 ficl_get_optkeys(ficlVm *vm)
1819 {
1820 #define h_get_optkeys "( ary req -- vals ) return key values\n\
1821 : optkeys-test ( start dur keyword-args -- ary )\n\
1822 #( :frequency 440.0\n\
1823 :initial-phase pi ) 2 get-optkeys { start dur freq phase }\n\
1824 #( start dur freq phase )\n\
1825 ;\n\
1826 0 1 optkeys-test => #( 0.0 1.0 440.0 3.14159 )\n\
1827 0 2 :frequency 330.0 optkeys-test => #( 0.0 2.0 330.0 3.14159 )\n\
1828 The plural form of get-optkey. \
1829 ARY is an array of key-value pairs, REQ is number of required arguments. \
1830 Return REQ + ARY length / 2 values on stack, either \
1831 default ones or from stack.\n\
1832 See also <{, get-optkey, get-optarg, get-optargs."
1833 FTH array;
1834 ficlInteger req, len, i;
1835
1836 FTH_STACK_CHECK(vm, 2, 0);
1837 req = ficlStackPopInteger(vm->dataStack);
1838 array = fth_pop_ficl_cell(vm);
1839 len = fth_array_length(array);
1840
1841 if (len == 0)
1842 return;
1843
1844 FTH_ASSERT_ARGS(!(len % 2), array, FTH_ARG1, "an array (key/value)");
1845 FTH_ASSERT_ARGS(FTH_ARRAY_P(array), array, FTH_ARG1, "an array");
1846 FTH_STACK_CHECK(vm, req, len);
1847
1848 for (i = 0; i < len; i += 2) {
1849 FTH key, val, tmp;
1850 int j, depth;
1851
1852 key = fth_array_ref(array, i);
1853 val = fth_array_ref(array, i + 1);
1854 fth_push_ficl_cell(vm, val);
1855 depth = FTH_STACK_DEPTH(vm);
1856
1857 for (j = 2; j < depth; j++) {
1858 tmp = STACK_FTH_INDEX_REF(vm->dataStack, j);
1859
1860 if (FTH_KEYWORD_P(tmp) && tmp == key) {
1861 ficlStackRoll(vm->dataStack, j);
1862 ficlStackDrop(vm->dataStack, 1);
1863 ficlStackRoll(vm->dataStack, (int) i - 1);
1864
1865 /*
1866 * If user specified undef, drop that and use
1867 * default value.
1868 */
1869 tmp = STACK_FTH_INDEX_REF(vm->dataStack, 0);
1870
1871 if (!FTH_UNDEF_P(tmp))
1872 ficlStackRoll(vm->dataStack, 1);
1873
1874 ficlStackDrop(vm->dataStack, 1);
1875 break;
1876 }
1877 }
1878 }
1879 }
1880
1881 static void
ficl_get_optargs(ficlVm * vm)1882 ficl_get_optargs(ficlVm *vm)
1883 {
1884 #define h_get_optargs "( args req -- vals ) return values\n\
1885 : optargs-test ( a b c=33 d=44 e=55 -- ary )\n\
1886 #( 33 44 55 ) 2 get-optargs { a b c d e }\n\
1887 #( a b c d e )\n\
1888 ;\n\
1889 1 2 optargs-test => #( 1 2 33 44 55 )\n\
1890 1 2 3 4 optargs-test => #( 1 2 3 4 55 )\n\
1891 1 2 3 4 5 6 7 optargs-test => 1 2 #( 3 4 5 6 7 )\n\
1892 Numbers 1 and 2 remain on stack, they are not needed here.\n\
1893 The plural form of get-optarg. \
1894 ARGS is an array with default values, REQ is number of required arguments. \
1895 Return REQ + ARGS length values on stack, \
1896 either default ones or from stack.\n\
1897 See also <{, get-optkey, get-optarg, get-optkeys."
1898 FTH args, tmp;
1899 ficlInteger req, pos, i, j, len, depth;
1900
1901 FTH_STACK_CHECK(vm, 2, 0);
1902 req = ficlStackPopInteger(vm->dataStack);
1903 args = ficlStackPopFTH(vm->dataStack);
1904 FTH_ASSERT_ARGS(FTH_ARRAY_P(args), args, FTH_ARG1, "an array");
1905 len = fth_array_length(args);
1906
1907 if (len == 0)
1908 return;
1909
1910 FTH_STACK_CHECK(vm, req, len);
1911 depth = FTH_STACK_DEPTH(vm) - req;
1912
1913 if (depth > len)
1914 depth = len;
1915
1916 for (i = 0, j = depth - 1, pos = req; i < len; i++, j--, pos++) {
1917 /* Replace undef with default values. */
1918 if (FTH_UNDEF_P(STACK_FTH_INDEX_REF(vm->dataStack, j))) {
1919 tmp = fth_array_fast_ref(args, i);
1920 STACK_FTH_INDEX_SET(vm->dataStack, j, fth_to_ficl(tmp));
1921 }
1922 /* Missing args filled with default values. */
1923 if (FTH_STACK_DEPTH(vm) <= pos)
1924 fth_push_ficl_cell(vm, fth_array_fast_ref(args, i));
1925 }
1926 }
1927
1928 static ficlWord *args_keys_paren;
1929 static ficlWord *args_optional_paren;
1930 static ficlWord *local_paren;
1931
1932 #define FICL_EVAL_STRING_AND_THROW(Vm, Buffer) do { \
1933 int status; \
1934 \
1935 status = ficlVmEvaluate(Vm, fth_string_ref(Buffer)); \
1936 if (status == FICL_VM_STATUS_ERROR_EXIT) \
1937 ficlVmThrowError(Vm, "can't execute %S", Buffer); \
1938 } while (0)
1939
1940 #define FTH_OPTKEY_ERROR_THROW(Desc) \
1941 fth_throw(FTH_OPTKEY_ERROR, "%s: wrong optkey array, %S", \
1942 RUNNING_WORD(), Desc)
1943
1944 static void
ficl_args_keys_paren_co(ficlVm * vm)1945 ficl_args_keys_paren_co(ficlVm *vm)
1946 {
1947 FTH keys;
1948 ficlInteger req, i, len;
1949
1950 FTH_STACK_CHECK(vm, 2, 0);
1951 req = ficlStackPopInteger(vm->dataStack);
1952 keys = fth_pop_ficl_cell(vm);
1953 FTH_ASSERT_ARGS(FTH_ARRAY_P(keys), keys, FTH_ARG1, "an array");
1954 len = fth_array_length(keys);
1955 FTH_STACK_CHECK(vm, req, len);
1956
1957 for (i = 0; i < len; i++) {
1958 FTH key, val, arg, tmp;
1959 int j, depth;
1960
1961 arg = fth_array_fast_ref(keys, i);
1962
1963 if (fth_array_length(arg) != 2)
1964 FTH_OPTKEY_ERROR_THROW(keys);
1965
1966 key = fth_keyword(fth_string_ref(fth_array_ref(arg, 0L)));
1967 val = fth_array_ref(arg, 1L);
1968 FICL_EVAL_STRING_AND_THROW(vm, val);
1969 depth = FTH_STACK_DEPTH(vm);
1970
1971 for (j = 2; j < depth; j++) {
1972 tmp = STACK_FTH_INDEX_REF(vm->dataStack, j);
1973
1974 if (FTH_KEYWORD_P(tmp) && tmp == key) {
1975 ficlStackRoll(vm->dataStack, j);
1976 ficlStackDrop(vm->dataStack, 1);
1977 ficlStackRoll(vm->dataStack, j - 1);
1978
1979 /*
1980 * If user specified undef, drop that and use
1981 * default value.
1982 */
1983 tmp = STACK_FTH_INDEX_REF(vm->dataStack, 0);
1984
1985 if (!FTH_UNDEF_P(tmp))
1986 ficlStackRoll(vm->dataStack, 1);
1987
1988 ficlStackDrop(vm->dataStack, 1);
1989 break;
1990 }
1991 }
1992 }
1993 }
1994
1995 static void
ficl_args_optional_paren_co(ficlVm * vm)1996 ficl_args_optional_paren_co(ficlVm *vm)
1997 {
1998 FTH defs, fs, tmp;
1999 ficlInteger req, pos, i, j, len, depth;
2000
2001 FTH_STACK_CHECK(vm, 2, 0);
2002 req = ficlStackPopInteger(vm->dataStack);
2003 defs = fth_pop_ficl_cell(vm);
2004 len = fth_array_length(defs);
2005
2006 if (len == 0)
2007 return;
2008
2009 FTH_STACK_CHECK(vm, req, len);
2010 depth = FTH_STACK_DEPTH(vm) - req;
2011
2012 if (depth > len)
2013 depth = len;
2014
2015 for (i = 0, j = depth - 1, pos = req; i < len; i++, j--, pos++) {
2016 /* Replace undef with evaled default values. */
2017 if (FTH_UNDEF_P(STACK_FTH_INDEX_REF(vm->dataStack, j))) {
2018 fs = fth_array_fast_ref(defs, i);
2019 FICL_EVAL_STRING_AND_THROW(vm, fs);
2020 tmp = ficlStackPopFTH(vm->dataStack);
2021 STACK_FTH_INDEX_SET(vm->dataStack, j, tmp);
2022 }
2023 /* Missing args filled with evaled default values. */
2024 if (FTH_STACK_DEPTH(vm) <= pos) {
2025 fs = fth_array_fast_ref(defs, i);
2026 FICL_EVAL_STRING_AND_THROW(vm, fs);
2027 }
2028 }
2029 }
2030
2031 static void
ficl_empty_extended_args_co_im(ficlVm * vm)2032 ficl_empty_extended_args_co_im(ficlVm *vm)
2033 {
2034 #define h_empty_ext_args_co_im "( -- ) turn colon definition in proc\n\
2035 : we-dont-need-args <{}> ;\n\
2036 Turn current colon definition in a proc object. \
2037 This word is immediate and compile only and can only be used \
2038 in word definitions.\n\
2039 See also <{."
2040 ficlWord *smudge;
2041
2042 smudge = ficlVmGetDictionary(vm)->smudge;
2043
2044 if (!FTH_PROC_P(smudge))
2045 smudge = FICL_WORD_REF(fth_make_proc(smudge, 0, 0, 0));
2046
2047 if (FTH_FALSE_P(FICL_WORD_DOC(smudge)))
2048 fth_word_doc_set(smudge, "( -- )");
2049 }
2050
2051 static ficlString
get_string_from_tib(ficlVm * vm,int pos)2052 get_string_from_tib(ficlVm *vm, int pos)
2053 {
2054 char *trace, *stop, *tmp;
2055 int cur_pos;
2056 ficlString s;
2057
2058 trace = ficlVmGetInBuf(vm);
2059 stop = ficlVmGetInBufEnd(vm);
2060 tmp = trace;
2061 FICL_STRING_SET_POINTER(s, trace);
2062
2063 for (cur_pos = 0; trace != stop && cur_pos != pos; cur_pos++, trace++)
2064 if (*trace == '\n' || *trace == '\t')
2065 *tmp++ = ' ';
2066 else
2067 *tmp++ = *trace;
2068
2069 FICL_STRING_SET_LENGTH(s, tmp - s.text);
2070
2071 if (trace != stop && cur_pos == pos)
2072 trace++;
2073
2074 ficlVmUpdateTib(vm, trace);
2075 return (s);
2076 }
2077
2078 static void
ficl_extended_args_co_im(ficlVm * vm)2079 ficl_extended_args_co_im(ficlVm *vm)
2080 {
2081 #define h_extended_args_co_im "( -- ) turn colon definition into a proc\n\
2082 : optkey-test\n\
2083 <{ a b c\n\
2084 :key d 10 e 20\n\
2085 :optional f 30 g 40 -- ary }>\n\
2086 #( a b c d e f g )\n\
2087 ;\n\
2088 1 2 3 optkey-test => #( 1 2 3 10 20 30 40 )\n\
2089 :d 11 1 :e 22 2 3 4 optkey-test => #( 1 2 3 11 22 4 40 )\n\
2090 Turn current colon definition into a proc object. \
2091 Take tokens up to closing '}>' as local variables, \
2092 '--' start a comment ignoring rest to closing '}>'. \
2093 In addition to other local variable words like { } and {{ }} \
2094 this form handles two keywords, :key and :optional. \
2095 Variable names are taken from keyword and optional names. \
2096 This word can span over more than one lines but without \
2097 empty lines or comments in between. \
2098 If :key and :optional is used together, :key must come first. \
2099 All keyword and optional variables must have default values. \
2100 This word is immediate and compile only and can only be used \
2101 in word definitions.\n\
2102 See also <{}>, get-optkey, get-optart, get-optkeys, get-optargs."
2103 ficlDictionary *dict;
2104 ficlWord *word;
2105 ficlInteger i, len, req, opt, in_lst;
2106 ficlUnsigned u;
2107 int keyslen, defslen;
2108 int key_p, opt_p;
2109 char *buffer, *s;
2110 FTH arg, arg1, arg2, keys, defs, args, fs;
2111
2112 u = (ficlUnsigned) ficlInstructionLiteralParen;
2113 req = opt = 0;
2114 key_p = opt_p = 0;
2115 dict = ficlVmGetDictionary(vm);
2116 word = dict->smudge;
2117 keys = fth_make_empty_array();
2118 defs = fth_make_empty_array();
2119 buffer = parse_tib_with_restart(vm, "}>", 2, get_string_from_tib);
2120 args = fth_string_split(fth_make_string(buffer), FTH_FALSE);
2121 FTH_FREE(buffer);
2122 fth_array_pop(args); /* eliminate delimiter `}>' */
2123 len = fth_array_length(args);
2124
2125 /*-
2126 * Use local variables and optional values as stack effect for
2127 * building a default doc string:
2128 *
2129 * : clm-mix <{ infile :key output #f output-frame 0 frames #f -- }>
2130 * ...
2131 * ;
2132 *
2133 * automatically create this doc string:
2134 *
2135 * clm-mix <{ infile :key output #f output-frame 0 frames #f -- }>
2136 */
2137 fs = fth_make_string("<{ ");
2138
2139 for (i = 0; i < len; i++)
2140 fth_string_sformat(fs, "%S ", fth_array_fast_ref(args, i));
2141
2142 fth_string_sformat(fs, "}>");
2143 fth_word_doc_set(word, fth_string_ref(fs));
2144
2145 /*
2146 * Eliminate elements after `--'.
2147 */
2148 for (i = 0; i < len; i++)
2149 if (strncmp(fth_string_ref(fth_array_fast_ref(args, i)),
2150 "--", 2L) == 0) {
2151 if (i == 0)
2152 args = fth_make_empty_array();
2153 else
2154 args = fth_array_subarray(args, 0L, i);
2155 break;
2156 }
2157
2158 /*-
2159 * Count required arguments and push their local variable names on
2160 * stack.
2161 *
2162 * Example: name <{ a b :key c 1 :optional d 2 -- }>
2163 *
2164 * After processing the next while-loop the result would be req = 2
2165 * with variable names 'a' and 'b'. The array 'args' contains
2166 * ':key c 1 :optional d 2'.
2167 */
2168 while (FTH_NOT_FALSE_P(arg = fth_array_shift(args))) {
2169 s = fth_string_ref(arg);
2170
2171 if (s != NULL && strncmp(s, ":key", 4L) == 0) {
2172 key_p = 1;
2173 break;
2174 }
2175 if (s != NULL && strncmp(s, ":optional", 9L) == 0) {
2176 opt_p = 1;
2177 break;
2178 }
2179
2180 /*
2181 * Push local variable name on stack.
2182 */
2183 push_forth_string(vm, s);
2184 req++;
2185 }
2186 #define LIST_START_P(Str) \
2187 ((Str) != NULL && strlen(Str) == 2 && \
2188 Str[1] == '(' && (Str[0] == '#' || Str[0] == '\''))
2189
2190 /*
2191 * Keyword arguments.
2192 */
2193 if (key_p) {
2194 while (FTH_NOT_FALSE_P(arg1 = fth_array_shift(args))) {
2195 s = fth_string_ref(arg1);
2196
2197 if (s != NULL && strncmp(s, ":optional", 9L) == 0) {
2198 opt_p = 1;
2199 break;
2200 }
2201
2202 /*
2203 * Push local variable name on stack.
2204 */
2205 push_forth_string(vm, s);
2206 arg2 = fth_array_shift(args);
2207
2208 if (FTH_FALSE_P(arg2)) {
2209 FTH_OPTKEY_ERROR_THROW(args);
2210 /* NOTREACHED */
2211 return;
2212 }
2213 s = fth_string_ref(arg2);
2214
2215 if (LIST_START_P(s)) {
2216 in_lst = 1;
2217
2218 do {
2219 fs = fth_array_shift(args);
2220 s = fth_string_ref(fs);
2221 if (s == NULL) {
2222 FTH_OPTKEY_ERROR_THROW(args);
2223 /* NOTREACHED */
2224 return;
2225 }
2226 if (LIST_START_P(s))
2227 in_lst++;
2228 if (*s == ')')
2229 in_lst--;
2230 fth_string_sformat(arg2, " %s", s);
2231 } while (in_lst);
2232 }
2233 fth_array_push(keys, fth_make_array_var(2, arg1, arg2));
2234 }
2235
2236 /*-
2237 * keys postpone literal
2238 * req postpone literal
2239 * postpone (args-keys)
2240 */
2241 ficlDictionaryAppendUnsigned(dict, u);
2242 ficlDictionaryAppendFTH(dict, keys);
2243 ficlDictionaryAppendUnsigned(dict, u);
2244 ficlDictionaryAppendInteger(dict, req);
2245 ficlDictionaryAppendPointer(dict, args_keys_paren);
2246 keyslen = fth_array_length(keys);
2247
2248 for (i = 0; i < keyslen; i++)
2249 ficlVmExecuteXT(vm, local_paren);
2250 }
2251
2252 /*
2253 * Optional arguments.
2254 */
2255 if (opt_p) {
2256 while (FTH_NOT_FALSE_P(arg1 = fth_array_shift(args))) {
2257 /*
2258 * Push local variable name on stack.
2259 */
2260 push_forth_string(vm, fth_string_ref(arg1));
2261 opt++;
2262 arg2 = fth_array_shift(args);
2263
2264 if (FTH_FALSE_P(arg2)) {
2265 FTH_OPTKEY_ERROR_THROW(args);
2266 /* NOTREACHED */
2267 return;
2268 }
2269 s = fth_string_ref(arg2);
2270
2271 if (LIST_START_P(s)) {
2272 in_lst = 1;
2273
2274 do {
2275 fs = fth_array_shift(args);
2276 s = fth_string_ref(fs);
2277 if (s == NULL) {
2278 FTH_OPTKEY_ERROR_THROW(args);
2279 /* NOTREACHED */
2280 return;
2281 }
2282 if (LIST_START_P(s))
2283 in_lst++;
2284 if (*s == ')')
2285 in_lst--;
2286 fth_string_sformat(arg2, " %s", s);
2287 } while (in_lst);
2288 }
2289 fth_array_push(defs, arg2);
2290 }
2291
2292 /*-
2293 * defs postpone literal
2294 * req postpone literal
2295 * postpone (args-optional)
2296 */
2297 ficlDictionaryAppendUnsigned(dict, u);
2298 ficlDictionaryAppendFTH(dict, defs);
2299 ficlDictionaryAppendUnsigned(dict, u);
2300 ficlDictionaryAppendInteger(dict, req);
2301 ficlDictionaryAppendPointer(dict, args_optional_paren);
2302 defslen = fth_array_length(defs);
2303
2304 for (i = 0; i < defslen; i++)
2305 ficlVmExecuteXT(vm, local_paren);
2306 }
2307
2308 /* Takes local variable names from stack in reverse order. */
2309 for (i = 0; i < req; i++)
2310 ficlVmExecuteXT(vm, local_paren);
2311
2312 ficlStackPushInteger(vm->dataStack, 0L);
2313 ficlStackPushInteger(vm->dataStack, 0L);
2314 ficlVmExecuteXT(vm, local_paren); /* 0 0 (local) */
2315
2316 if (!FTH_PROC_P(word))
2317 fth_make_proc(word, (int) req, (int) opt, key_p);
2318 }
2319
2320 /* from ficl/primitive.c */
2321 static char colon_tag[] = "colon";
2322 static char locals_dummy[] = " ___dummy___ ";
2323
2324 /*-
2325 * Creates a dummy local variable in ":", "lambda:", and "does>". If
2326 * the first local variable of a word definition was created in a loop,
2327 * it wasn't handled correctly. ficl_init_locals solves this issue.
2328 *
2329 * called in:
2330 * src/proc.c ficl_begin_definition -- ":"
2331 * ficl_lambda_definition -- "lambda:"
2332 * ficl/primitives.c ficlPrimitiveDoesCoIm -- "does>"
2333 */
2334 void
ficl_init_locals(ficlVm * vm,ficlDictionary * dict)2335 ficl_init_locals(ficlVm *vm, ficlDictionary *dict)
2336 {
2337 ficlUnsigned u;
2338
2339 /*-
2340 * 0 postpone literal ( dummy value for dummy variable )
2341 * s" ___dummy___" (local)
2342 * 0 0 (local)
2343 */
2344 u = (ficlUnsigned) ficlInstructionLiteralParen;
2345 ficlDictionaryAppendUnsigned(dict, u);
2346 ficlDictionaryAppendUnsigned(dict, 0UL);
2347 push_forth_string(vm, locals_dummy);
2348 ficlVmExecuteXT(vm, local_paren);
2349 ficlStackPushInteger(vm->dataStack, 0L);
2350 ficlStackPushInteger(vm->dataStack, 0L);
2351 ficlVmExecuteXT(vm, local_paren);
2352 }
2353
2354 /*-
2355 * Redefinition of ':' (colon)
2356 *
2357 * The stack-effect comment or a normal comment after the word name
2358 * will be used as a simple documentation entry.
2359 *
2360 * : new-word1 ( a b c -- d ) ... ;
2361 * help new-word1 => new-word1 ( a b c -- d )
2362 *
2363 * : new-word2 \ here comes some comment
2364 * ...
2365 * ;
2366 * help new-word2 => new-word2 \ here comes some comment
2367 */
2368 static void
ficl_begin_definition(ficlVm * vm)2369 ficl_begin_definition(ficlVm *vm)
2370 {
2371 #define h_begin_definition "( \"name\" -- ) start colon definition\n\
2372 : plus ( n1 n2 -- n3 ) + ;\n\
2373 help plus => plus ( n1 n2 -- n3 )\n\
2374 : mult \\ multiplies two args\n\
2375 *\n\
2376 ;\n\
2377 help mult => mult \\ multiplies two args\n\
2378 Redefinition of standard colon `:'. \
2379 Start word definition and set variable LATESTXT to word. \
2380 In addition to standard colon `:' \
2381 stack-effect comment or normal comment immediately after the word name \
2382 will be used as documentation.\n\
2383 See also lambda:."
2384 ficlDictionary *dict;
2385 ficlString s;
2386 ficlPrimitive code;
2387 ficlUnsigned flag;
2388 ficlWord *word;
2389
2390 dict = ficlVmGetDictionary(vm);
2391 s = ficlVmGetWord(vm);
2392 code = (ficlPrimitive) ficlInstructionColonParen;
2393 flag = FICL_WORD_DEFAULT | FICL_WORD_SMUDGED;
2394 vm->state = FICL_VM_STATE_COMPILE;
2395 ficlStackPushPointer(vm->dataStack, colon_tag);
2396 word = ficlDictionaryAppendWord(dict, s, code, flag);
2397 vm->callback.system->localsCount = 0;
2398 word->primitive_p = 0;
2399 word_documentation(vm, word);
2400 fth_latest_xt = word;
2401 ficl_init_locals(vm, dict);
2402 }
2403
2404 static void
ficl_lambda_definition(ficlVm * vm)2405 ficl_lambda_definition(ficlVm *vm)
2406 {
2407 #define h_lambda_definition "( -- xt ) start word definition\n\
2408 lambda: ( a b -- c ) + ; value plus\n\
2409 1 2 plus execute => 3\n\
2410 1 2 lambda: ( a b -- c ) * ; execute => 2\n\
2411 Start nameless word definition and set variable LATESTXT to word. \
2412 Stack-effect or normal comment immediately at the beginning \
2413 will be used as documentation. \
2414 Return xt (after closing semicolon `;') and set variable LATESTXT to xt.\n\
2415 See also `:'."
2416 ficlDictionary *dict;
2417 ficlPrimitive code;
2418 ficlUnsigned flag;
2419 ficlWord *word;
2420 ficlString name;
2421
2422 dict = ficlVmGetDictionary(vm);
2423 code = (ficlPrimitive) ficlInstructionColonParen;
2424 flag = FICL_WORD_DEFAULT | FICL_WORD_SMUDGED;
2425 vm->state = FICL_VM_STATE_COMPILE;
2426 FICL_STRING_SET_LENGTH(name, 0);
2427 FICL_STRING_SET_POINTER(name, NULL);
2428 word = ficlDictionaryAppendWord(dict, name, code, flag);
2429 vm->callback.system->localsCount = 0;
2430 ficlStackPushPointer(vm->dataStack, word);
2431 ficlStackPushPointer(vm->dataStack, colon_tag);
2432 word->primitive_p = 0;
2433 word_documentation(vm, word);
2434 fth_latest_xt = word;
2435 ficl_init_locals(vm, dict);
2436 }
2437
2438 static void
ficl_proc_create_co(ficlVm * vm)2439 ficl_proc_create_co(ficlVm *vm)
2440 {
2441 #define h_proc_create "( arity -- prc ) create nameless proc\n\
2442 : input-fn ( gen -- proc; dir self -- r )\n\
2443 { gen }\n\
2444 1 proc-create \\ return proc with one required argument\n\
2445 gen , \\ store gen for later use in DOES part\n\
2446 does> { dir self -- r } \\ dir (ignored here) self (address)\n\
2447 self @ \\ return our gen\n\
2448 readin \\ return readin value\n\
2449 ;\n\
2450 Return nameless proc object with ARITY. \
2451 Like CREATE it goes with DOES>.\n\
2452 This word is compile only and can only be used in word definitions."
2453 ficlDictionary *dict;
2454 ficlPrimitive code;
2455 ficlUnsigned flag;
2456 ficlWord *word;
2457 ficlString name;
2458 FTH prc;
2459 int arity;
2460
2461 dict = ficlVmGetDictionary(vm);
2462 code = (ficlPrimitive) ficlInstructionCreateParen;
2463 flag = FICL_WORD_DEFAULT;
2464 FICL_STRING_SET_LENGTH(name, 0);
2465 FICL_STRING_SET_POINTER(name, NULL);
2466 word = ficlDictionaryAppendWord(dict, name, code, flag);
2467 word->primitive_p = 0;
2468 fth_latest_xt = word;
2469 FTH_STACK_CHECK(vm, 1, 1);
2470 arity = (int) ficlStackPopInteger(vm->dataStack);
2471 prc = fth_make_proc(word, arity, 0, 0);
2472 ficlStackPushFTH(vm->dataStack, prc);
2473 ficlVmDictionaryAllotCells(dict, 1);
2474 }
2475
2476 static void
ficl_word_create_co(ficlVm * vm)2477 ficl_word_create_co(ficlVm *vm)
2478 {
2479 #define h_word_create "( name -- ) create word NAME\n\
2480 : make-setter ( name -- ; hs val self -- )\n\
2481 { name }\n\
2482 name \"!\" $+ word-create\n\
2483 name ,\n\
2484 does> { hs val self -- }\n\
2485 self @ { slot }\n\
2486 hs slot val hash-set!\n\
2487 ;\n\
2488 \"user-time\" make-setter\n\
2489 \\ creates word user-time!\n\
2490 #{} value hs\n\
2491 hs 3.2 user-time!\n\
2492 hs => #{ 'user-time => 3.2 }\n\
2493 Create word NAME in dictionary with DOES>-part as body.\n\
2494 See also proc-create."
2495 ficlDictionary *dict;
2496 ficlPrimitive code;
2497 ficlUnsigned flag;
2498 ficlWord *word;
2499 char *name;
2500 FTH fs;
2501
2502 FTH_STACK_CHECK(vm, 1, 0);
2503 fs = fth_pop_ficl_cell(vm);
2504 dict = ficlVmGetDictionary(vm);
2505 code = (ficlPrimitive) ficlInstructionCreateParen;
2506 flag = FICL_WORD_DEFAULT;
2507 FTH_ASSERT_ARGS(FTH_STRING_P(fs), fs, FTH_ARG1, "a string");
2508 name = fth_string_ref(fs);
2509 word = ficlDictionaryAppendPrimitive(dict, name, code, flag);
2510 word->primitive_p = 0;
2511 fth_latest_xt = word;
2512 ficlVmDictionaryAllotCells(dict, 1);
2513 }
2514
2515 static void
ficl_constant(ficlVm * vm)2516 ficl_constant(ficlVm *vm)
2517 {
2518 #define h_constant "( val \"name\" -- ) set constant\n\
2519 #( \"behemoth\" \"pumpkin\" \"mugli\" ) constant hosts\n\
2520 Redefinition of Ficl's CONSTANT (parse word). \
2521 In addition protect permanently VAL from garbage collection.\n\
2522 See also value."
2523 FTH obj;
2524
2525 FTH_STACK_CHECK(vm, 1, 0);
2526 ficlVmGetWordToPad(vm);
2527 obj = fth_pop_ficl_cell(vm);
2528 fth_define(vm->pad, obj);
2529 }
2530
2531 static void
ficl_value(ficlVm * vm)2532 ficl_value(ficlVm *vm)
2533 {
2534 #define h_value "( val \"name\" -- ) set value\n\
2535 #( \"behemoth\" \"pumpkin\" \"mugli\" ) value hosts\n\
2536 Redefinition of Ficl's VALUE (parse word). \
2537 In addition protect temporarily VAL from garbage collection.\n\
2538 See also constant."
2539 FTH obj;
2540
2541 FTH_STACK_CHECK(vm, 1, 0);
2542 ficlVmGetWordToPad(vm);
2543 obj = fth_pop_ficl_cell(vm);
2544 fth_define_variable(vm->pad, obj, NULL);
2545 }
2546
2547 static ficlWord *local_vars_paren;
2548
2549 static FTH
local_vars_cb(FTH key,FTH value,FTH data)2550 local_vars_cb(FTH key, FTH value, FTH data)
2551 {
2552 ficlInteger offset;
2553 ficlCell *frame;
2554
2555 (void) key;
2556 offset = (ficlInteger) value;
2557 frame = ((ficlCell *) (data)) + offset;
2558 return (ficl_to_fth(CELL_FTH_REF(frame)));
2559 }
2560
2561 static void
ficl_local_variables_paren_co(ficlVm * vm)2562 ficl_local_variables_paren_co(ficlVm *vm)
2563 {
2564 FTH vars, frm, res;
2565
2566 FTH_STACK_CHECK(vm, 1, 1);
2567 vars = ficlStackPopFTH(vm->dataStack);
2568 frm = (FTH) (vm->returnStack->frame);
2569 res = fth_hash_map(vars, local_vars_cb, frm);
2570 ficlStackPushFTH(vm->dataStack, res);
2571 }
2572
2573 static void
ficl_local_variables_co_im(ficlVm * vm)2574 ficl_local_variables_co_im(ficlVm *vm)
2575 {
2576 #define h_lvars "( -- vars ) return local variables\n\
2577 : word-with-locals { foo -- }\n\
2578 10 { bar }\n\
2579 local-variables each .$ space end-each\n\
2580 ;\n\
2581 20 word-with-locals => #{ \"bar\" => 10 \"foo\" => 20 }\n\
2582 Return a hash of local variable name-value pairs up to \
2583 the location in definition. \
2584 This word is immediate and compile only and can only \
2585 be used in word definitions."
2586 ficlDictionary *dict, *locals;
2587 ficlSystem *sys;
2588 ficlHash *hash;
2589 ficlWord *word;
2590 ficlInteger i;
2591 ficlUnsigned u;
2592 FTH vars, name, offset;
2593
2594 vars = fth_make_hash();
2595 sys = vm->callback.system;
2596
2597 if (sys->localsCount == 0)
2598 goto finish;
2599
2600 /*
2601 * At compile time we can only collect the names and the
2602 * offset to frame of every local variable. At interpret
2603 * time we can find the current values on frame + offset (in
2604 * ficl_local_variables_paren_co).
2605 */
2606 locals = ficlSystemGetLocals(sys);
2607 hash = locals->wordlists[0];
2608
2609 while (hash != NULL) {
2610 for (i = (int) hash->size - 1; i >= 0; i--) {
2611 word = hash->table[i];
2612 while (word != NULL) {
2613 if (strcmp(word->name, locals_dummy) == 0) {
2614 word = word->link;
2615 continue;
2616 }
2617
2618 /*-
2619 * key: FTH (name)
2620 * val: ficlInteger (offset)
2621 */
2622 name = FTH_WORD_NAME(word);
2623 offset = (FTH) FICL_WORD_PARAM(word);
2624 fth_hash_set(vars, name, offset);
2625 word = word->link;
2626 }
2627 }
2628 hash = hash->link;
2629 }
2630
2631 finish:
2632 dict = ficlVmGetDictionary(vm);
2633 u = (ficlUnsigned) ficlInstructionLiteralParen;
2634 ficlDictionaryAppendUnsigned(dict, u);
2635 ficlDictionaryAppendFTH(dict, vars);
2636 ficlDictionaryAppendPointer(dict, local_vars_paren);
2637 }
2638
2639 FTH
proc_from_proc_or_xt(FTH proc_or_xt,int req,int opt,int rest)2640 proc_from_proc_or_xt(FTH proc_or_xt, int req, int opt, int rest)
2641 {
2642 if (FTH_PROC_P(proc_or_xt)) {
2643 if ((FICL_WORD_REQ(proc_or_xt) != req) ||
2644 (FICL_WORD_OPT(proc_or_xt) != opt) ||
2645 (FICL_WORD_REST(proc_or_xt) != rest))
2646 FTH_BAD_ARITY_ERROR_ARGS(FTH_ARG1, proc_or_xt,
2647 req, opt, rest,
2648 FICL_WORD_REQ(proc_or_xt),
2649 FICL_WORD_OPT(proc_or_xt),
2650 FICL_WORD_REST(proc_or_xt));
2651 return (proc_or_xt);
2652 }
2653 if (FICL_WORD_P(proc_or_xt)) {
2654 FTH prc;
2655
2656 prc = fth_make_proc(FICL_WORD_REF(proc_or_xt), req, opt, rest);
2657 return (prc);
2658 }
2659 return (FTH_FALSE);
2660 }
2661
2662 /*
2663 * Return name of word with possible source filename and source line
2664 * number of the definition as FTH String if defined in the dictionary
2665 * or "unknown word 0xxxxxxxx".
2666 */
2667 FTH
fth_word_inspect(FTH obj)2668 fth_word_inspect(FTH obj)
2669 {
2670 FTH fs, cfs, msg;
2671
2672 if (obj == 0)
2673 return (FTH_FALSE);
2674
2675 if (FICL_INSTRUCTION_P(obj))
2676 return (fth_make_string(ficlDictionaryInstructionNames[obj]));
2677
2678 if (!FICL_WORD_DEFINED_P(obj))
2679 return (fth_make_string_format("unknown word 0x%X", obj));
2680
2681 fs = FTH_WORD_NAME(obj);
2682
2683 if (FTH_FALSE_P(fs))
2684 fs = fth_make_string("noname");
2685
2686 if (FICL_WORD_REF(obj) != FICL_WORD_CURRENT_WORD(obj)) {
2687 cfs = FTH_WORD_NAME(FICL_WORD_CURRENT_WORD(obj));
2688
2689 if (FTH_FALSE_P(cfs))
2690 fth_string_sformat(fs, " in noname");
2691 else
2692 fth_string_sformat(fs, " in %S", cfs);
2693
2694 if (FICL_WORD_CURRENT_LINE(obj) > 0)
2695 fth_string_sformat(fs, " (%S:%ld)",
2696 FICL_WORD_CURRENT_FILE(obj),
2697 FICL_WORD_CURRENT_LINE(obj));
2698 } else if (FICL_WORD_LINE(obj) > 0)
2699 fth_string_sformat(fs, " (%S:%ld)",
2700 FICL_WORD_FILE(obj),
2701 FICL_WORD_LINE(obj));
2702
2703 if (FICL_VARIABLES_P(obj))
2704 fth_string_sformat(fs, " (%S)", FTH_WORD_PARAM(obj));
2705 else if (FTH_EXCEPTION_P(obj)) {
2706 msg = fth_exception_last_message_ref(obj);
2707
2708 if (FTH_NOT_FALSE_P(msg))
2709 fth_string_sformat(fs, " (%S)", msg);
2710 }
2711 return (fs);
2712 }
2713
2714 /*
2715 * Return name of word as FTH String if defined in the dictionary, or
2716 * FTH_FALSE.
2717 */
2718 FTH
fth_word_to_string(FTH obj)2719 fth_word_to_string(FTH obj)
2720 {
2721 if (obj == 0)
2722 return (FTH_FALSE);
2723
2724 if (FICL_INSTRUCTION_P(obj))
2725 return (fth_make_string(ficlDictionaryInstructionNames[obj]));
2726
2727 if (FICL_WORD_DEFINED_P(obj)) {
2728 if (FICL_WORD_REF(obj)->length > 0)
2729 return (FTH_WORD_NAME(obj));
2730 return (fth_make_string("noname"));
2731 }
2732 return (FTH_FALSE);
2733 }
2734
2735 /*
2736 * Return source of word as FTH String if defined in the dictionary.
2737 * If no source was found, try to return at least the name of word as
2738 * FTH String.
2739 */
2740 FTH
fth_word_dump(FTH obj)2741 fth_word_dump(FTH obj)
2742 {
2743 FTH src;
2744
2745 src = fth_source_ref(obj);
2746
2747 if (FTH_FALSE_P(src))
2748 return (fth_word_to_string(obj));
2749
2750 return (src);
2751 }
2752
2753 /* === Define (constant, variable) === */
2754
2755 /*
2756 * Return true if NAME is defined in the dictionary, otherwise false.
2757 */
2758
2759 int
fth_defined_p(const char * name)2760 fth_defined_p(const char *name)
2761 {
2762 return (name != NULL && FICL_NAME_DEFINED_P(name));
2763 }
2764
2765 static void
ficl_defined_p(ficlVm * vm)2766 ficl_defined_p(ficlVm *vm)
2767 {
2768 #define h_defined_p "( \"name\" -- f ) test if NAME is defined\n\
2769 defined? 10 => #f\n\
2770 defined? nil => #t\n\
2771 defined? + => #t\n\
2772 Return #t if NAME is defined in the dictionary, otherwise #f."
2773 ficlVmGetWordToPad(vm);
2774 ficlStackPushBoolean(vm->dataStack, fth_defined_p(vm->pad));
2775 }
2776
2777 /*
2778 * Define constant NAME to VALUE which can be a FTH Fixnum (in contrast
2779 * to fth_define_constant below) or any other FTH object. Return
2780 * VALUE.
2781 */
2782 FTH
fth_define(const char * name,FTH value)2783 fth_define(const char *name, FTH value)
2784 {
2785 FTH_CONSTANT_SET(name, fth_to_ficl(value));
2786 return (fth_gc_permanent(value));
2787 }
2788
2789 /*
2790 * Define constant NAME to VALUE which can be a C integer (in contrast
2791 * to fth_define above) or any other FTH object. DOC can be NULL or
2792 * a description of the constant for the 'help' word. Return VALUE
2793 * where C integers are converted to FTH Fixnums, any other objects
2794 * remain untouched.
2795 */
2796 FTH
fth_define_constant(const char * name,FTH value,const char * doc)2797 fth_define_constant(const char *name, FTH value, const char *doc)
2798 {
2799 FTH_CONSTANT_SET_WITH_DOC(name, value, doc);
2800 return (fth_gc_permanent(ficl_to_fth(value)));
2801 }
2802
2803 /*
2804 * Define global variable NAME to VALUE which can be a FTH Fixnum or
2805 * any other FTH object, see the similar function fth_define for
2806 * constants above. DOC can be NULL or a description of the variable
2807 * for the 'help' word. Return VALUE.
2808 */
2809 FTH
fth_define_variable(const char * name,FTH value,const char * doc)2810 fth_define_variable(const char *name, FTH value, const char *doc)
2811 {
2812 FTH_CONSTANT_SET_WITH_DOC(name, fth_to_ficl(value), doc);
2813 return (fth_gc_protect(value));
2814 }
2815
2816 /*
2817 * Return FTH value from global variable or constant NAME.
2818 */
2819 FTH
fth_variable_ref(const char * name)2820 fth_variable_ref(const char *name)
2821 {
2822 return (fth_var_ref((FTH) FICL_WORD_NAME_REF(name)));
2823 }
2824
2825 /*
2826 * Set (or create if not existing) global variable NAME to VALUE.
2827 * Return VALUE.
2828 */
2829 FTH
fth_variable_set(const char * name,FTH value)2830 fth_variable_set(const char *name, FTH value)
2831 {
2832 ficlWord *word;
2833
2834 word = FICL_WORD_NAME_REF(name);
2835
2836 if (word != NULL)
2837 return (fth_var_set((FTH) word, value));
2838
2839 return (fth_define_variable(name, value, NULL));
2840 }
2841
2842 FTH
fth_var_ref(FTH obj)2843 fth_var_ref(FTH obj)
2844 {
2845 if (FICL_VARIABLES_P(obj))
2846 return (FTH_WORD_PARAM(obj));
2847 return (FTH_FALSE);
2848 }
2849
2850 FTH
fth_var_set(FTH obj,FTH value)2851 fth_var_set(FTH obj, FTH value)
2852 {
2853 FTH out;
2854
2855 if (FICL_VARIABLES_P(obj)) {
2856 out = FTH_WORD_PARAM(obj);
2857 FICL_WORD_PARAM(obj) = fth_to_ficl(value);
2858 fth_gc_protect_set(out, value);
2859 }
2860 return (value);
2861 }
2862
2863 /*-
2864 * Trace global variable:
2865 *
2866 * TRACE-VAR Installs a hook on the specified global variable and adds
2867 * procs with stack effect ( val -- res ). The hook will be executed
2868 * after every variable set via TO.
2869 *
2870 * UNTRACE-VAR removes the hook.
2871 *
2872 * 8 value *clm-array-print-length*
2873 * <'> *clm-array-print-length* lambda: <{ val -- res }>
2874 * val set-mus-array-print-length
2875 * ; trace-var
2876 * ...
2877 * <'> *clm-array-print-length* untrace-var
2878 *
2879 */
2880 void
fth_trace_var(FTH obj,FTH proc_or_xt)2881 fth_trace_var(FTH obj, FTH proc_or_xt)
2882 {
2883 #define h_trace_var "( var proc-or-xt -- ) install trace xt\n\
2884 8 value *clm-array-print-length*\n\
2885 <'> *clm-array-print-length* lambda: <{ val -- res }>\n\
2886 val set-mus-array-print-length\n\
2887 ; trace-var\n\
2888 24 to *clm-array-print-length*\n\
2889 *clm-array-print-length* => 24\n\
2890 mus-array-print-length => 24\n\
2891 <'> *clm-array-print-length* untrace-var\n\
2892 Add PROC-OR-XT to global VAR hook which is utilized on every call of TO. \
2893 The stack effect of PROC-OR-XT must be ( val -- res ).\n\
2894 See also untrace-var."
2895 FTH hook;
2896
2897 if (!FICL_VARIABLES_P(obj)) {
2898 FTH_ASSERT_ARGS(FICL_VARIABLES_P(obj), obj, FTH_ARG1,
2899 "a global variable");
2900 /* NOTREACHED */
2901 return;
2902 }
2903 hook = fth_word_property_ref(obj, FTH_SYMBOL_TRACE_VAR);
2904
2905 if (!FTH_HOOK_P(hook))
2906 hook = fth_make_simple_hook(1);
2907
2908 fth_add_hook(hook, proc_or_xt);
2909 fth_word_property_set(obj, FTH_SYMBOL_TRACE_VAR, hook);
2910 FICL_WORD_TYPE(obj) = FW_TRACE_VAR;
2911 }
2912
2913 void
fth_untrace_var(FTH obj)2914 fth_untrace_var(FTH obj)
2915 {
2916 #define h_untrace_var "( var -- ) remove trace xt\n\
2917 8 value *clm-array-print-length*\n\
2918 <'> *clm-array-print-length* lambda: <{ val -- res }>\n\
2919 val set-mus-array-print-length\n\
2920 ; trace-var\n\
2921 24 to *clm-array-print-length*\n\
2922 *clm-array-print-length* => 24\n\
2923 mus-array-print-length => 24\n\
2924 <'> *clm-array-print-length* untrace-var\n\
2925 Remove previously installed hook from VAR.\n\
2926 See also trace-var."
2927 if (!FTH_TRACE_VAR_P(obj)) {
2928 FTH_ASSERT_ARGS(FTH_TRACE_VAR_P(obj), obj, FTH_ARG1,
2929 "a global traced variable");
2930 /* NOTREACHED */
2931 return;
2932 }
2933 fth_word_property_set(obj, FTH_SYMBOL_TRACE_VAR, FTH_FALSE);
2934 FICL_WORD_TYPE(obj) = FW_VARIABLE;
2935 }
2936
2937 FTH
fth_trace_var_execute(ficlWord * word)2938 fth_trace_var_execute(ficlWord *word)
2939 {
2940 FTH hook, res, args;
2941
2942 if (!FTH_TRACE_VAR_P(word)) {
2943 FTH_ASSERT_ARGS(FTH_TRACE_VAR_P(word),
2944 (FTH) word, FTH_ARG1, "a global traced variable");
2945 /* NOTREACHED */
2946 return (FTH_FALSE);
2947 }
2948 hook = fth_word_property_ref((FTH) word, FTH_SYMBOL_TRACE_VAR);
2949
2950 if (!FTH_HOOK_P(hook))
2951 return (FTH_FALSE);
2952
2953 args = fth_make_array_var(1, FTH_WORD_PARAM(word));
2954 res = fth_hook_apply(hook, args, RUNNING_WORD());
2955 return (res);
2956 }
2957
2958 void
init_proc(void)2959 init_proc(void)
2960 {
2961 ficlString s;
2962
2963 FICL_STRING_SET_FROM_CSTRING(s, "(local)");
2964 local_paren = ficlDictionaryLookup(FTH_FICL_DICT(), s);
2965
2966 /* proc */
2967 FTH_PRI1("proc?", ficl_proc_p, h_proc_p);
2968 FTH_PRI1("thunk?", ficl_thunk_p, h_thunk_p);
2969 FTH_PRI1("xt?", ficl_xt_p, h_xt_p);
2970 FTH_PRI1("word?", ficl_word_p, h_word_p);
2971 FTH_PRI1("make-proc", ficl_make_proc, h_make_proc);
2972 FTH_PRI1(".proc", ficl_print_proc, h_print_proc);
2973 FTH_PRI1("proc-arity", ficl_proc_arity, h_proc_arity);
2974 FTH_PRI1("proc-name", ficl_proc_name, h_proc_name);
2975 FTH_PROC("proc-source-ref", fth_proc_source_ref,
2976 1, 0, 0, h_proc_source_ref);
2977 FTH_VOID_PROC("proc-source-set!", fth_proc_source_set,
2978 2, 0, 0, h_proc_source_set);
2979 FTH_PRI1("proc->xt", ficl_proc_to_xt, h_proc_to_xt);
2980 FTH_PRI1("proc-apply", ficl_proc_apply, h_proc_apply);
2981 FTH_PRI1("run-proc", ficl_proc_apply, h_proc_apply);
2982 FTH_PRIM_IM("<'set>", ficl_tick_set_im, h_tick_set_im);
2983 FTH_PRIM_IM("set!", ficl_set_bang_im, h_set_bang_im);
2984 FTH_PRI1("set-xt", ficl_set_xt, h_set_xt);
2985 FTH_PRI1("set-execute", ficl_set_execute, h_set_execute);
2986 FTH_PRI1("xt->name", ficl_xt_to_name, h_xt_to_name);
2987 FTH_PRI1("xt->origin", ficl_xt_to_origin, h_xt_to_origin);
2988 FTH_PRI1("help", ficl_get_help, h_get_help);
2989 FTH_PRI1("help-ref", ficl_help_ref, h_help_ref);
2990 FTH_PRI1("help-set!", ficl_help_set, h_help_set);
2991 FTH_PRI1("help-add!", ficl_help_add, h_help_add);
2992 FTH_PROC("documentation-ref", fth_documentation_ref,
2993 1, 0, 0, h_doc_ref);
2994 FTH_VOID_PROC("documentation-set!", fth_documentation_set,
2995 2, 0, 0, h_doc_set);
2996 FTH_PROC("source-ref", fth_source_ref, 1, 0, 0, h_source_ref);
2997 FTH_VOID_PROC("source-set!", fth_source_set, 2, 0, 0, h_source_set);
2998 FTH_PROC("source-file", fth_source_file, 1, 0, 0, h_source_file);
2999 FTH_PROC("source-line", fth_source_line, 1, 0, 0, h_source_line);
3000
3001 /* ficl system */
3002 FTH_PRI1("see2", ficl_see, h_see);
3003 FTH_PRI1("latestxt", ficl_latestxt, h_latestxt);
3004 FTH_PRIM_CO_IM("running-word", ficl_latestxt_co_im, h_latestxt_co_im);
3005 FTH_PRIM_CO_IM("get-func-name", ficl_get_func_name_co_im,
3006 h_get_func_name_co_im);
3007 FTH_PRIM_IM("*filename*", ficl_filename_im, h_filename_im);
3008 FTH_PRIM_IM("*lineno*", ficl_lineno_im, h_lineno_im);
3009 FTH_PRIM_CO_IM("doc\"", ficl_doc_quote_co_im, h_doc_quote_co_im);
3010 FTH_PRI1("get-optkey", ficl_get_optkey, h_get_optkey);
3011 FTH_PRI1("get-optarg", ficl_get_optarg, h_get_optarg);
3012 FTH_PRI1("get-optkeys", ficl_get_optkeys, h_get_optkeys);
3013 FTH_PRI1("get-optargs", ficl_get_optargs, h_get_optargs);
3014 FTH_PRIM_CO_IM("<{}>", ficl_empty_extended_args_co_im,
3015 h_empty_ext_args_co_im);
3016 FTH_PRIM_CO_IM("<{", ficl_extended_args_co_im,
3017 h_extended_args_co_im);
3018 args_keys_paren = FTH_PRIM_CO("(args-keys)",
3019 ficl_args_keys_paren_co, NULL);
3020 args_optional_paren = FTH_PRIM_CO("(args-optional)",
3021 ficl_args_optional_paren_co, NULL);
3022
3023 /* redefinition of colon (:) */
3024 FTH_PRIMITIVE_SET(":", ficl_begin_definition,
3025 FICL_WORD_DEFAULT, h_begin_definition);
3026 FTH_PRI1("lambda:", ficl_lambda_definition, h_lambda_definition);
3027 FTH_PRIM_CO("proc-create", ficl_proc_create_co, h_proc_create);
3028 FTH_PRIM_CO("word-create", ficl_word_create_co, h_word_create);
3029
3030 /* redefinition of constant and value with gc protection */
3031 FTH_PRIMITIVE_SET("constant", ficl_constant,
3032 FICL_WORD_DEFAULT, h_constant);
3033 FTH_PRIMITIVE_SET("value", ficl_value, FICL_WORD_DEFAULT, h_value);
3034 local_vars_paren = FTH_PRIM_CO("(local-variables)",
3035 ficl_local_variables_paren_co, NULL);
3036 FTH_PRIM_CO_IM("local-variables", ficl_local_variables_co_im, h_lvars);
3037 FTH_PRI1("defined?", ficl_defined_p, h_defined_p);
3038 FTH_VOID_PROC("trace-var", fth_trace_var, 2, 0, 0, h_trace_var);
3039 FTH_VOID_PROC("untrace-var", fth_untrace_var, 1, 0, 0, h_untrace_var);
3040 FTH_ADD_FEATURE_AND_INFO(FTH_STR_PROC, h_list_of_proc_functions);
3041 }
3042
3043 /*
3044 * proc.c ends here
3045 */
3046