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
27 #if !defined(lint)
28 const char libfth_sccsid[] = "@(#)misc.c 2.56 12/8/19";
29 #endif /* not lint */
30
31 #define FTH_DATE "2019/12/08"
32
33 #if defined(HAVE_CONFIG_H)
34 #include "config.h"
35 #endif
36
37 #include "fth.h"
38 #include "utils.h"
39
40 #if defined(HAVE_SYS_WAIT_H)
41 #include <sys/wait.h>
42 #endif
43 #if defined(HAVE_FCNTL_H)
44 #include <fcntl.h>
45 #endif
46 #if defined(HAVE_SYS_STAT_H)
47 #include <sys/stat.h>
48 #endif
49 #if defined(HAVE_DLFCN_H)
50 #include <dlfcn.h>
51 #endif
52 #if defined(HAVE_SYS_TIME_H)
53 #include <sys/time.h>
54 #endif
55 #if defined(HAVE_TIME_H)
56 #include <time.h>
57 #endif
58 #if defined(HAVE_SYS_TIMES_H)
59 #include <sys/times.h>
60 #endif
61 #if defined(HAVE_NETINET_IN_H)
62 #include <netinet/in.h>
63 #endif
64 #if defined(HAVE_SIGNAL_H)
65 #include <signal.h>
66 #endif
67
68 #define FTH_INIT_FILE ".fthrc"
69 #define FTH_PATH_SEPARATOR ":"
70
71 #define FTH_GLOBAL_INIT_FILE FTH_PREFIX_PATH "/etc/fth.conf"
72 #define FTH_SO_LIB_PATH FTH_PREFIX_PATH "/lib/" FTH_PROG_NAME
73
74 #define FTH_SHARE_PATH FTH_PREFIX_PATH "/share/" FTH_PROG_NAME
75 #define FTH_FS_LIB_PATH FTH_SHARE_PATH "/fth-lib"
76 #define FTH_SITE_FTH_PATH FTH_SHARE_PATH "/site-fth"
77
78 static int apropos(ficlWord *, FTH);
79 static FTH at_exit_each(FTH, FTH);
80 static void ficl_add_feature(ficlVm *);
81 static void ficl_add_load_lib_path(ficlVm *);
82 static void ficl_add_load_path(ficlVm *);
83 static void ficl_at_exit(ficlVm *);
84 static void ficl_catch(ficlVm *);
85 static void ficl_config_cflags(ficlVm *);
86 static void ficl_config_libs(ficlVm *);
87 static void ficl_config_prefix(ficlVm *);
88 static void ficl_configure_args(ficlVm *);
89 static void ficl_current_time(ficlVm *);
90 static void ficl_date(ficlVm *);
91 static void ficl_dl_load(ficlVm *);
92 static void ficl_dot_cflags(ficlVm *);
93 static void ficl_dot_libs(ficlVm *);
94 static void ficl_dot_lversion(ficlVm *);
95 static void ficl_dot_prefix(ficlVm *);
96 static void ficl_dot_version(ficlVm *);
97 static void ficl_environ(ficlVm *);
98 static void ficl_exec(ficlVm *);
99 static void ficl_exit(ficlVm *);
100 static void ficl_features(ficlVm *);
101 static void ficl_fetch_paren(ficlVm *);
102 static void ficl_fork(ficlVm *);
103 static void ficl_getegid(ficlVm *);
104 static void ficl_getenv(ficlVm *);
105 static void ficl_geteuid(ficlVm *);
106 static void ficl_getgid(ficlVm *);
107 static void ficl_gethostname(ficlVm *);
108 static void ficl_getlogin(ficlVm *);
109 static void ficl_getopt(ficlVm *);
110 static void ficl_getopt_long(ficlVm *);
111 static void ficl_getpid(ficlVm *);
112 static void ficl_getppid(ficlVm *);
113 static void ficl_getservbyname(ficlVm *);
114 static void ficl_getservbyport(ficlVm *);
115 static void ficl_getuid(ficlVm *);
116 static void ficl_gmtime(ficlVm *);
117 static void ficl_include_file(ficlVm *);
118 static void ficl_kill(ficlVm *);
119 static void ficl_load_init_file(ficlVm *);
120 static void ficl_localtime(ficlVm *);
121 static void ficl_mktime(ficlVm *);
122 static void ficl_provided_p(ficlVm *);
123 static void ficl_putenv(ficlVm *);
124 static void ficl_raise(ficlVm *);
125 static void ficl_require_file(ficlVm *);
126 static void ficl_reset_each_paren(ficlVm *);
127 static void ficl_reset_map_paren(ficlVm *);
128 static void ficl_set_begin_paren(ficlVm *);
129 static void ficl_set_each_loop_paren(ficlVm *);
130 static void ficl_set_end_paren(ficlVm *);
131 static void ficl_set_map_loop_paren(ficlVm *);
132 static void ficl_setegid(ficlVm *);
133 static void ficl_seteuid(ficlVm *);
134 static void ficl_setgid(ficlVm *);
135 static void ficl_sethostname(ficlVm *);
136 static void ficl_setuid(ficlVm *);
137 static void ficl_show_memory(ficlVm *);
138 static void ficl_signal(ficlVm *);
139 static void ficl_signal_handler(ficlVm *);
140 static void ficl_sleep(ficlVm *);
141 static void ficl_stack_reset(ficlVm *);
142 static void ficl_store_paren(ficlVm *);
143 static void ficl_strftime(ficlVm *);
144 static void ficl_strptime(ficlVm *);
145 static void ficl_throw(ficlVm *);
146 static void ficl_time(ficlVm *);
147 static void ficl_time_reset(ficlVm *);
148 static void ficl_time_to_string(ficlVm *);
149 static void ficl_unshift_load_lib_path(ficlVm *);
150 static void ficl_unshift_load_path(ficlVm *);
151 static void ficl_utime(ficlVm *);
152 static void ficl_values_end(ficlVm *);
153 static void ficl_version(ficlVm *);
154 static void ficl_wait(ficlVm *);
155 static void ficl_waitpid(ficlVm *);
156 static int find_in_wordlist(ficlWord *, FTH);
157 static void forth_pre_init(void);
158 static RETSIGTYPE fth_toplevel_handler(int);
159 static void handler_exec(int sig);
160 static FTH load_file(const char *, const char *);
161 #if defined(HAVE_DLOPEN)
162 static FTH load_lib(const char *, const char *, const char *);
163 #endif
164 static void run_at_exit(void);
165 static void set_and_show_signal_backtrace(int);
166
167 /* global ficl variable; access via FTH_FICL_VAR() etc (fth.h) */
168 Ficl *fth_ficl = NULL;
169
170 /*
171 * exit callback void (*)(int);
172 * snd/xen.c use it.
173 */
174 exit_cb fth_exit_hook;
175
176 /* === Init FTH === */
177
178 #if !defined(_WIN32)
179 sigjmp_buf fth_sig_toplevel;
180
181 static RETSIGTYPE
fth_toplevel_handler(int sig)182 fth_toplevel_handler(int sig)
183 {
184 siglongjmp(fth_sig_toplevel, sig);
185 }
186 #endif
187
188 #if !defined(HAVE_SIG_T)
189 typedef void (*sig_t) (int sig);
190 #endif
191
192 #if !defined(SIG_DFL)
193 #define SIG_DFL ((sig_t)0)
194 #endif
195 #if !defined(SIG_IGN)
196 #define SIG_IGN ((sig_t)1)
197 #endif
198 #if !defined(SIG_ERR)
199 #define SIG_ERR ((sig_t)-1)
200 #endif
201
202 /* required in object.c */
203 int fth_signal_caught_p;
204
205 #if !defined(_WIN32)
206 static void
set_and_show_signal_backtrace(int kind)207 set_and_show_signal_backtrace(int kind)
208 {
209 fth_set_backtrace(FTH_SIGNAL_CAUGHT);
210 fth_show_backtrace(1);
211
212 switch (kind) {
213 case EXIT_SUCCESS:
214 case EXIT_FAILURE:
215 fth_exit(kind);
216 break;
217 case EXIT_ABORT:
218 default:
219 if (fth_die_on_signal_p || !fth_interactive_p)
220 abort();
221 break;
222 }
223 }
224
225 void
signal_check(int sig)226 signal_check(int sig)
227 {
228 char *func;
229 sig_t cb;
230
231 func = RUNNING_WORD();
232 cb = signal(sig, SIG_DFL);
233
234 switch (sig) {
235 case SIGINT: /* C-c break */
236 fth_printf("\n#<%s: break (C-c)>\n", func);
237 if (!fth_interactive_p)
238 set_and_show_signal_backtrace(EXIT_SUCCESS);
239 break;
240 case SIGUSR1: /* C-g abort */
241 fth_printf("\n#<%s: abort (C-g)>\n", func);
242 if (!fth_interactive_p)
243 set_and_show_signal_backtrace(EXIT_SUCCESS);
244 break;
245 case SIGQUIT: /* C-\ quit */
246 fth_printf("\n#<%s: quit (C-\\)>\n", func);
247 fth_exit(EXIT_SUCCESS);
248 break;
249 case SIGFPE:
250 fth_warning("%s => %s", func, strsignal(sig));
251 #if defined(FTH_DEBUG)
252 set_and_show_signal_backtrace(EXIT_ABORT);
253 #endif
254 break;
255 default:
256 fth_signal_caught_p = 1;
257 fth_errorf("#<%s: %s>\n", func, strsignal(sig));
258 set_and_show_signal_backtrace(EXIT_ABORT);
259 /*
260 * Skip reset signal handler if not aborted.
261 */
262 return;
263 break;
264 }
265 fth_signal_caught_p = 0;
266 signal(sig, cb);
267 }
268
269 #define FTH_SIGNALS 7
270 static int fth_signals[] = {
271 SIGINT, SIGQUIT, SIGILL, SIGSEGV, SIGBUS, SIGFPE, SIGUSR1
272 };
273 #endif /* !_WIN32 */
274
275 #define INIT_ASSERT(Cond) \
276 if (!(Cond)) { \
277 fprintf(stderr, "fth: init failed in %s[%d]\n", \
278 __FILE__, __LINE__); \
279 abort(); \
280 }
281
282 void
fth_make_ficl(unsigned int dict_size,unsigned int stack_size,unsigned int return_size,unsigned int locals_size)283 fth_make_ficl(unsigned int dict_size, unsigned int stack_size,
284 unsigned int return_size, unsigned int locals_size)
285 {
286 #if !defined(_WIN32)
287 int i;
288 #endif
289
290 if (FTH_FICL_VAR() == NULL) {
291 ficlSystemInformation fsi;
292 ficlSystem *sys;
293 ficlVm *vm;
294
295 FTH_FICL_VAR() = FTH_MALLOC(sizeof(Ficl));
296 fth_last_exception = 0L;
297 fth_current_file = 0L;
298 fth_current_line = -1;
299 fth_print_p = 0;
300 fth_eval_p = 0;
301 fth_hit_error_p = 0;
302 fth_true_repl_p = 1;
303 fth_die_on_signal_p = 0;
304 fth_interactive_p = 0;
305 fth_signal_caught_p = 0;
306 ficlSystemInformationInitialize(&fsi);
307 fsi.context = NULL;
308 fsi.dictionarySize = dict_size;
309 fsi.stackSize = stack_size;
310 fsi.returnSize = return_size;
311 fsi.localsSize = locals_size;
312 fsi.environmentSize = FICL_DEFAULT_ENVIRONMENT_SIZE;
313 /* we use our own io-functions from port.c */
314 fsi.textIn = NULL;
315 fsi.textOut = NULL;
316 fsi.errorOut = NULL;
317 /* unistd.h */
318 fsi.stdin_fileno = STDIN_FILENO;
319 fsi.stdout_fileno = STDOUT_FILENO;
320 fsi.stderr_fileno = STDERR_FILENO;
321 /* stdio.h */
322 fsi.stdin_ptr = stdin;
323 fsi.stdout_ptr = stdout;
324 fsi.stderr_ptr = stderr;
325 sys = ficlSystemCreate(&fsi);
326 INIT_ASSERT(sys);
327 FTH_FICL_SYSTEM() = sys;
328 vm = ficlSystemCreateVm(sys);
329 INIT_ASSERT(vm);
330 FTH_FICL_VM() = vm;
331 INIT_ASSERT(FTH_FICL_DICT());
332 INIT_ASSERT(FTH_FICL_ENV());
333 INIT_ASSERT(FTH_FICL_STACK());
334 fth_set_read_cb(NULL);
335 fth_set_print_cb(NULL);
336 fth_set_error_cb(NULL);
337 }
338 #if !defined(_WIN32)
339 for (i = 0; i < FTH_SIGNALS; i++)
340 signal(fth_signals[i], fth_toplevel_handler);
341 #endif
342 }
343
344 static FTH load_path;
345 static FTH load_lib_path;
346 static FTH loaded_files;
347 static FTH before_load_hook;
348 static FTH after_load_hook;
349 static FTH eval_string;
350 static FTH fth_at_exit_procs;
351 static simple_array *depth_array;
352 static simple_array *loop_array;
353
354 static char misc_scratch[MAXPATHLEN];
355 static char misc_scratch_02[MAXPATHLEN];
356 static char misc_scratch_03[MAXPATHLEN];
357 static char misc_scratch_04[MAXPATHLEN];
358
359 /*
360 * Boolean and Nil object types.
361 */
362 static void init_boolean_type(void);
363 static FTH bl_inspect(FTH self);
364 static FTH bl_to_string(FTH self);
365
366 enum {
367 BOOLEAN_FALSE,
368 BOOLEAN_TRUE,
369 BOOLEAN_NIL,
370 BOOLEAN_UNDEF
371 };
372
373 #define B_ISTR_FALSE "#f"
374 #define B_ISTR_TRUE "#t"
375 #define B_ISTR_NIL "nil"
376 #define B_ISTR_UNDEF "undef"
377 #define B_SSTR_NIL "#<" B_ISTR_NIL ">"
378 #define B_SSTR_UNDEF "#<" B_ISTR_UNDEF ">"
379
380 static FTH b_istr_false;
381 static FTH b_istr_true;
382 static FTH b_istr_nil;
383 static FTH b_istr_undef;
384 static FTH b_sstr_nil;
385 static FTH b_sstr_undef;
386
387 static FTH
bl_inspect(FTH self)388 bl_inspect(FTH self)
389 {
390 FTH fs;
391
392 fs = fth_make_string(FTH_INSTANCE_NAME(self));
393
394 switch (FTH_INT_OBJECT(self)) {
395 case BOOLEAN_FALSE:
396 return (fth_string_sformat(fs, ": %S", b_istr_false));
397 break;
398 case BOOLEAN_TRUE:
399 return (fth_string_sformat(fs, ": %S", b_istr_true));
400 break;
401 case BOOLEAN_NIL:
402 return (fth_string_sformat(fs, ": %S", b_istr_nil));
403 break;
404 case BOOLEAN_UNDEF:
405 default:
406 return (fth_string_sformat(fs, ": %S", b_istr_undef));
407 break;
408 }
409 }
410
411 static FTH
bl_to_string(FTH self)412 bl_to_string(FTH self)
413 {
414 switch (FTH_INT_OBJECT(self)) {
415 case BOOLEAN_FALSE:
416 return (b_istr_false);
417 break;
418 case BOOLEAN_TRUE:
419 return (b_istr_true);
420 break;
421 case BOOLEAN_NIL:
422 return (b_sstr_nil);
423 break;
424 case BOOLEAN_UNDEF:
425 default:
426 return (b_sstr_undef);
427 break;
428 }
429 }
430
431 static void
init_boolean_type(void)432 init_boolean_type(void)
433 {
434 FTH boolean_tag;
435 FTH nil_tag;
436
437 boolean_tag = make_object_type(FTH_STR_BOOLEAN, FTH_BOOLEAN_T);
438 fth_set_object_inspect(boolean_tag, bl_inspect);
439 fth_set_object_to_string(boolean_tag, bl_to_string);
440
441 /*
442 * Boolean object type (#t, #f)
443 */
444 FTH_FALSE = fth_make_instance(boolean_tag, NULL);
445 FTH_INT_OBJECT_SET(FTH_FALSE, BOOLEAN_FALSE);
446 FTH_TRUE = fth_make_instance(boolean_tag, NULL);
447 FTH_INT_OBJECT_SET(FTH_TRUE, BOOLEAN_TRUE);
448
449 /*
450 * Nil object type (nil, undef)
451 */
452 nil_tag = make_object_type(FTH_STR_NIL, FTH_NIL_T);
453 fth_set_object_inspect(nil_tag, bl_inspect);
454 fth_set_object_to_string(nil_tag, bl_to_string);
455 FTH_NIL = fth_make_instance(nil_tag, NULL);
456 FTH_INT_OBJECT_SET(FTH_NIL, BOOLEAN_NIL);
457 FTH_UNDEF = fth_make_instance(nil_tag, NULL);
458 FTH_INT_OBJECT_SET(FTH_UNDEF, BOOLEAN_UNDEF);
459
460 /*
461 * #f, #t, nil, undef
462 */
463 fth_define(B_ISTR_FALSE, FTH_FALSE);
464 fth_define(B_ISTR_TRUE, FTH_TRUE);
465 fth_define(B_ISTR_NIL, FTH_NIL);
466 fth_define(B_ISTR_UNDEF, FTH_UNDEF);
467 }
468
469 static void
forth_pre_init(void)470 forth_pre_init(void)
471 {
472 INIT_ASSERT(FTH_FICL_VAR());
473 /*
474 * Theses object types are required before defining further
475 * functions.
476 */
477 init_gc();
478 init_boolean_type();
479 init_array_type();
480 init_hash_type();
481 init_io_type();
482 init_hook_type();
483 init_string_type();
484 init_regexp_type();
485 init_number_types();
486 b_istr_false = fth_gc_permanent(fth_make_string(B_ISTR_FALSE));
487 b_istr_true = fth_gc_permanent(fth_make_string(B_ISTR_TRUE));
488 b_istr_nil = fth_gc_permanent(fth_make_string(B_ISTR_NIL));
489 b_istr_undef = fth_gc_permanent(fth_make_string(B_ISTR_UNDEF));
490 b_sstr_nil = fth_gc_permanent(fth_make_string(B_SSTR_NIL));
491 b_sstr_undef = fth_gc_permanent(fth_make_string(B_SSTR_UNDEF));
492 fth_current_file = FTH_FALSE;
493 fth_last_exception = FTH_FALSE;
494 fth_at_exit_procs = FTH_FALSE;
495 /* global Forth variables, protected with fth_define_variable() */
496 loaded_files = fth_make_empty_array();
497 load_path = fth_make_empty_array();
498 load_lib_path = fth_make_empty_array();
499 /* global C variables */
500 depth_array = make_simple_array(8);
501 loop_array = make_simple_array(8);
502 /* fth_current_file in fth_eval() */
503 eval_string = fth_make_string("eval");
504
505 {
506 char *libs, *pname;
507
508 /* Set path for Forth script files: */
509 libs = fth_getenv(FTH_ENV_FTHPATH, NULL);
510
511 if (libs != NULL)
512 while ((pname = strsep(&libs, FTH_PATH_SEPARATOR)))
513 if (pname[0] != '\0')
514 fth_add_load_path(pname);
515
516 fth_add_load_path(FTH_FS_LIB_PATH);
517 fth_add_load_path(FTH_SITE_FTH_PATH);
518
519 /* Set path for C dynamic so libraries: */
520 libs = fth_getenv(FTH_ENV_LIBPATH, NULL);
521
522 if (libs != NULL)
523 while ((pname = strsep(&libs, FTH_PATH_SEPARATOR)))
524 if (pname[0] != '\0')
525 fth_add_load_lib_path(pname);
526
527 fth_add_load_lib_path(FTH_SO_LIB_PATH);
528 }
529
530 /* variables */
531 fth_define_variable("*load-path*", load_path,
532 "( -- load-path-array )");
533 fth_define_variable("*load-lib-path*", load_lib_path,
534 "( -- load-path-lib-array )");
535 fth_define_variable("*loaded-files*", loaded_files,
536 "( -- files-array )");
537 before_load_hook = fth_make_hook("before-load-hook", 1,
538 "( filename -- f ) \
539 Called before loading FILENAME. \
540 If hook returns #f, FILENAME won't be loaded.\n\
541 before-load-hook lambda: <{ fname -- f }>\n\
542 \"\\\\ loading %s\\n\" #( fname ) fth-print\n\
543 #t\n\
544 ; add-hook!");
545 after_load_hook = fth_make_hook("after-load-hook", 1,
546 "( filename -- ) \
547 Called after loading FILENAME and updating global variable *loaded-files*.\n\
548 after-load-hook lambda: <{ fname -- }>\n\
549 \"\\\\ %s loaded\\n\" #( fname ) fth-print\n\
550 ; add-hook!");
551 #if defined(FTH_STATIC)
552 fth_add_feature("static");
553 #endif
554 fth_add_feature(FTH_STR_BOOLEAN);
555 fth_add_feature(FTH_STR_NIL);
556 fth_add_feature(FICL_NAME);
557 fth_add_feature(FICL_FORTH_NAME);
558 fth_add_feature(FTH_TARGET_CPU);
559
560 {
561 char *s, *p, *r;
562
563 s = misc_scratch;
564 fth_strcpy(s, sizeof(misc_scratch), FTH_TARGET_OS);
565 p = s;
566 /*-
567 * Operating system name without version number.
568 * 'minix provided? if
569 * ...
570 * else
571 * 'netbsd provided? if ... else ... then
572 * then
573 */
574 r = strsep(&p, "0123456789-_");
575 if (r != NULL)
576 fth_add_feature(r);
577 }
578
579 ficlSystemCompileCore(FTH_FICL_SYSTEM());
580 ficlSystemCompilePrefix(FTH_FICL_SYSTEM());
581 ficlSystemCompilePlatform(FTH_FICL_SYSTEM());
582 ficlSystemAddPrimitiveParseStep(FTH_FICL_SYSTEM(),
583 "?word", ficlVmParseWord);
584 ficlSystemAddPrimitiveParseStep(FTH_FICL_SYSTEM(),
585 "?prefix", ficlVmParsePrefix);
586 ficlSystemAddPrimitiveParseStep(FTH_FICL_SYSTEM(),
587 "?number", ficl_parse_number);
588 #if HAVE_COMPLEX
589 ficlSystemAddPrimitiveParseStep(FTH_FICL_SYSTEM(),
590 "?complex", ficl_parse_complex);
591 #endif
592 ficlSystemAddPrimitiveParseStep(FTH_FICL_SYSTEM(),
593 "?ratio", ficl_parse_ratio);
594 ficlSystemAddPrimitiveParseStep(FTH_FICL_SYSTEM(),
595 "?bignum", ficl_parse_bignum);
596 init_object();
597 init_proc();
598 init_array();
599 init_hash();
600 init_io();
601 init_file();
602 init_port();
603 init_number();
604 init_hook();
605 init_string();
606 init_regexp();
607 init_symbol();
608 init_utils();
609 fth_define_variable("*fth-verbose*", FTH_FALSE, NULL);
610 fth_define_variable("*fth-debug*", FTH_FALSE, NULL);
611 fth_current_file = fth_make_string("-");
612 fth_current_line = -1;
613 }
614
615 /*-
616 * Shell environment variables.
617 *
618 * $FTH_DICTIONARY_SIZE
619 * $FTH_STACK_SIZE
620 * $FTH_RETURN_SIZE
621 * $FTH_LOCALS_SIZE
622 */
623
624 /* splitted init function for fth.c */
625 void
forth_init_before_load(void)626 forth_init_before_load(void)
627 {
628 unsigned int dict_size, stack_size, return_size, locals_size;
629 char *env;
630
631 dict_size = FICL_DEFAULT_DICTIONARY_SIZE;
632 stack_size = FICL_DEFAULT_STACK_SIZE;
633 return_size = FICL_DEFAULT_RETURN_SIZE;
634 locals_size = FICL_MAX_LOCALS;
635 env = fth_getenv(FTH_ENV_DICTIONARY_SIZE, NULL);
636
637 if (env != NULL)
638 dict_size = (unsigned int) strtol(env, NULL, 10);
639
640 env = fth_getenv(FTH_ENV_STACK_SIZE, NULL);
641
642 if (env != NULL)
643 stack_size = (unsigned int) strtol(env, NULL, 10);
644
645 env = fth_getenv(FTH_ENV_RETURN_SIZE, NULL);
646
647 if (env != NULL)
648 return_size = (unsigned int) strtol(env, NULL, 10);
649
650 env = fth_getenv(FTH_ENV_LOCALS_SIZE, NULL);
651
652 if (env != NULL)
653 locals_size = (unsigned int) strtol(env, NULL, 10);
654
655 fth_make_ficl(dict_size, stack_size, return_size, locals_size);
656 forth_pre_init();
657 }
658
659 /*-
660 * Init libfth.so.
661 *
662 * This function must be called before any libfth.so action.
663 * Used for example in snd.c and xen.c (snd(1)).
664 */
665 void
fth_init(void)666 fth_init(void)
667 {
668 forth_init_before_load();
669 forth_init();
670 }
671
672 void
fth_reset(void)673 fth_reset(void)
674 {
675 #if !defined(_WIN32)
676 int i;
677
678 for (i = 0; i < FTH_SIGNALS; i++)
679 signal(fth_signals[i], SIG_DFL);
680 #endif
681 ficlVmDestroy(FTH_FICL_VM());
682 FTH_FICL_VAR() = NULL;
683 fth_init();
684 }
685
686 void
fth_exit(int n)687 fth_exit(int n)
688 {
689 if (fth_exit_hook != NULL)
690 (*fth_exit_hook) (n);
691 exit(n);
692 }
693
694 /* === EVAL === */
695
696 int
fth_catch_exec(ficlWord * word)697 fth_catch_exec(ficlWord *word)
698 {
699 int status;
700
701 if (word == NULL)
702 return (FTH_OKAY);
703
704 gc_push(word);
705 status = ficlVmExecuteXT(FTH_FICL_VM(), word);
706 gc_pop();
707
708 switch (status) {
709 case FICL_VM_STATUS_INNER_EXIT:
710 case FICL_VM_STATUS_OUT_OF_TEXT:
711 case FICL_VM_STATUS_RESTART:
712 case FICL_VM_STATUS_BREAK:
713 case FICL_VM_STATUS_ABORT:
714 case FICL_VM_STATUS_ABORTQ:
715 case FICL_VM_STATUS_QUIT:
716 return (FTH_OKAY);
717 break;
718 case FICL_VM_STATUS_USER_EXIT:
719 return (FTH_BYE);
720 break;
721 case FICL_VM_STATUS_ERROR_EXIT:
722 default:
723 return (FTH_ERROR);
724 break;
725 }
726 }
727
728 int
fth_catch_eval(const char * buffer)729 fth_catch_eval(const char *buffer)
730 {
731 int status;
732 ficlCell id;
733 ficlString s;
734 ficlVm *vm;
735 char *buf;
736
737 if (buffer == NULL)
738 return (FTH_OKAY);
739
740 vm = FTH_FICL_VM();
741 id = vm->sourceId;
742 CELL_INT_SET(&vm->sourceId, -1);
743 buf = FTH_STRDUP(buffer);
744 FICL_STRING_SET_FROM_CSTRING(s, buf);
745 gc_push(vm->runningWord);
746 status = ficlVmExecuteString(vm, s);
747 gc_pop();
748 FTH_FREE(buf);
749 vm->sourceId = id;
750
751 switch (status) {
752 case FICL_VM_STATUS_INNER_EXIT:
753 case FICL_VM_STATUS_OUT_OF_TEXT:
754 case FICL_VM_STATUS_RESTART:
755 case FICL_VM_STATUS_BREAK:
756 case FICL_VM_STATUS_ABORT:
757 case FICL_VM_STATUS_ABORTQ:
758 case FICL_VM_STATUS_QUIT:
759 return (FTH_OKAY);
760 break;
761 case FICL_VM_STATUS_USER_EXIT:
762 return (FTH_BYE);
763 break;
764 case FICL_VM_STATUS_ERROR_EXIT:
765 default:
766 return (FTH_ERROR);
767 break;
768 }
769 }
770
771 /*-
772 * Evaluate C string BUFFER.
773 * If BUFFER is NULL,
774 * return #<undef>,
775 * if BUFFER evaluates to FTH_BYE,
776 * exit program,
777 * if BUFFER evaluates to no value,
778 * return #<undef>,
779 * if BUFFER evaluates to a single value,
780 * remove it from stack and return it,
781 * if BUFFER evaluates to multiple values,
782 * remove them from stack and return them all in an array.
783 */
784 FTH
fth_eval(const char * buffer)785 fth_eval(const char *buffer)
786 {
787 static ficlInteger lineno = 0;
788 ficlInteger old_line, new_depth, i;
789 ficlVm *vm;
790 FTH val, old_file;
791 int depth;
792
793 if (buffer == NULL)
794 return (FTH_UNDEF);
795
796 old_line = fth_current_line;
797 old_file = fth_current_file;
798 vm = FTH_FICL_VM();
799 depth = FTH_STACK_DEPTH(vm);
800 fth_eval_p = 1;
801 fth_current_file = eval_string;
802 fth_current_line = ++lineno;
803
804 if (fth_catch_eval(buffer) == FTH_BYE)
805 fth_exit(EXIT_SUCCESS);
806
807 vm = FTH_FICL_VM();
808 new_depth = FTH_STACK_DEPTH(vm) - depth;
809
810 switch (new_depth) {
811 case 0:
812 val = FTH_UNDEF;
813 break;
814 case 1:
815 val = fth_pop_ficl_cell(vm);
816 break;
817 default:
818 val = fth_make_array_len(new_depth);
819 for (i = 0; i < new_depth; i++)
820 fth_array_set(val, i, fth_pop_ficl_cell(vm));
821 break;
822 }
823
824 fth_current_file = old_file;
825 fth_current_line = old_line;
826 fth_eval_p = 0;
827 return (val);
828 }
829
830 /*
831 * Push C string NAME to environment word list for later review with
832 * provided? and *features*.
833 */
834 void
fth_add_feature(const char * name)835 fth_add_feature(const char *name)
836 {
837 if (fth_strlen(name) > 0)
838 ficlDictionaryAppendConstant(FTH_FICL_ENV(),
839 (char *) name,
840 (ficlInteger) fth_symbol(name));
841 }
842
843 static void
ficl_add_feature(ficlVm * vm)844 ficl_add_feature(ficlVm *vm)
845 {
846 #define h_add_feature "( obj -- ) add feature\n\
847 'snd add-feature\n\
848 Add OBJ, a string or symbol, to *features* list.\n\
849 See also provided? and *features*."
850 FTH obj;
851
852 FTH_STACK_CHECK(vm, 1, 0);
853 obj = fth_pop_ficl_cell(vm);
854 FTH_ASSERT_ARGS(fth_string_or_symbol_p(obj), obj, FTH_ARG1,
855 "a string or a symbol");
856 fth_add_feature(fth_string_or_symbol_ref(obj));
857 }
858
859 /*
860 * Test if feature NAME exists in environment word list.
861 */
862 int
fth_provided_p(const char * name)863 fth_provided_p(const char *name)
864 {
865 if (fth_strlen(name) > 0) {
866 ficlString s;
867
868 FICL_STRING_SET_FROM_CSTRING(s, name);
869 return (ficlDictionaryLookup(FTH_FICL_ENV(), s) != NULL);
870 }
871 return (0);
872 }
873
874 static void
ficl_provided_p(ficlVm * vm)875 ficl_provided_p(ficlVm *vm)
876 {
877 #define h_provided_p "( obj -- f ) test if OBJ already exist\n\
878 'fth provided? => #t\n\
879 'foo provided? => #f\n\
880 Return #t if OBJ, a string or symbol, exists in *features* list, \
881 otherwise #f.\n\
882 See also add-feature and *features*."
883 FTH obj;
884 int flag;
885
886 FTH_STACK_CHECK(vm, 1, 1);
887 obj = fth_pop_ficl_cell(vm);
888 FTH_ASSERT_ARGS(fth_string_or_symbol_p(obj), obj, FTH_ARG1,
889 "a string or a symbol");
890 flag = fth_provided_p(fth_string_or_symbol_ref(obj));
891 ficlStackPushBoolean(vm->dataStack, flag);
892 }
893
894 static void
ficl_features(ficlVm * vm)895 ficl_features(ficlVm *vm)
896 {
897 #define h_features "( -- ary ) return feature array\n\
898 *features* => #( \"timer\" \"exception\" ...)\n\
899 Return array of all features.\n\
900 See also add-feature and provided?."
901 ficlHash *hash;
902 ficlWord *word;
903 unsigned int i;
904 FTH features;
905
906 FTH_STACK_CHECK(vm, 0, 1);
907 hash = ficlSystemGetEnvironment(vm->callback.system)->forthWordlist;
908 features = fth_make_empty_array();
909
910 for (i = 0; i < hash->size; i++)
911 for (word = hash->table[i]; word != NULL; word = word->link)
912 fth_array_push(features,
913 fth_make_string(FICL_WORD_NAME(word)));
914
915 ficlStackPushFTH(vm->dataStack, features);
916 }
917
918 /* === Load Files === */
919
920 char *
fth_basename(const char * path)921 fth_basename(const char *path)
922 {
923 char *base;
924
925 if (path == NULL)
926 return ("");
927
928 return ((base = strrchr(path, '/')) ? ++base : (char *) path);
929 }
930
931 /*
932 * Add PATH with array-function KIND to load-path LP removing a trailing
933 * slash if any.
934 */
935 #define ADD_TO_LOAD_PATH(Lp, Kind, Path) \
936 ssize_t len; \
937 \
938 len = fth_strlen(Path); \
939 if (len > 0) { \
940 FTH fs; \
941 char *s; \
942 \
943 s = (char *)Path; \
944 len -= 1; \
945 \
946 if (s[len] == '/') \
947 s[len] = '\0'; \
948 \
949 fs = fth_make_string(s); \
950 \
951 if (!fth_array_member_p(Lp, fs)) \
952 fth_array_ ## Kind(Lp, fs); \
953 } \
954
955 /*
956 * Push PATH at the end of global array variable *load-path* if not already
957 * there.
958 */
959 void
fth_add_load_path(const char * path)960 fth_add_load_path(const char *path)
961 {
962 ADD_TO_LOAD_PATH(load_path, push, path);
963 }
964
965 /*
966 * Prepend PATH to the beginning of global array variable *load-path* if not
967 * already there.
968 */
969 void
fth_unshift_load_path(const char * path)970 fth_unshift_load_path(const char *path)
971 {
972 ADD_TO_LOAD_PATH(load_path, unshift, path);
973 }
974
975 /*
976 * Push PATH at the end of global array variable *load-lib-path* if not
977 * already there.
978 */
979 void
fth_add_load_lib_path(const char * path)980 fth_add_load_lib_path(const char *path)
981 {
982 ADD_TO_LOAD_PATH(load_lib_path, push, path);
983 }
984
985 /*
986 * Prepend PATH to the beginning of global array variable *load-lib-path* if
987 * not already there.
988 */
989 void
fth_unshift_load_lib_path(const char * path)990 fth_unshift_load_lib_path(const char *path)
991 {
992 ADD_TO_LOAD_PATH(load_lib_path, unshift, path);
993 }
994
995 /*
996 * Push FILE at the end of global array variable *loaded-files* if not
997 * already there.
998 */
999 void
fth_add_loaded_files(const char * file)1000 fth_add_loaded_files(const char *file)
1001 {
1002 ADD_TO_LOAD_PATH(loaded_files, push, file);
1003 }
1004
1005 static void
ficl_add_load_path(ficlVm * vm)1006 ficl_add_load_path(ficlVm *vm)
1007 {
1008 #define h_add_load_path "( path -- ) add PATH to *load-path*\n\
1009 \"/home/mike/share/fth\" add-load-path\n\
1010 Add string PATH to *load-path* array if not already there."
1011 FTH_STACK_CHECK(vm, 1, 0);
1012 fth_add_load_path(pop_cstring(vm));
1013 }
1014
1015 static void
ficl_unshift_load_path(ficlVm * vm)1016 ficl_unshift_load_path(ficlVm *vm)
1017 {
1018 #define h_uns_load_path "( path -- ) prepend PATH to *load-path*\n\
1019 \"/home/mike/share/fth\" unshift-load-path\n\
1020 Prepend string PATH to *load-path* array if not already there."
1021 FTH_STACK_CHECK(vm, 1, 0);
1022 fth_unshift_load_path(pop_cstring(vm));
1023 }
1024
1025 static void
ficl_add_load_lib_path(ficlVm * vm)1026 ficl_add_load_lib_path(ficlVm *vm)
1027 {
1028 #define h_add_load_lib_path "( path -- ) add PATH to *load-lib-path*\n\
1029 \"/home/mike/lib/fth\" add-load-lib-path\n\
1030 Add string PATH to *load-lib-path* array if not already there."
1031 FTH_STACK_CHECK(vm, 1, 0);
1032 fth_add_load_lib_path(pop_cstring(vm));
1033 }
1034
1035 static void
ficl_unshift_load_lib_path(ficlVm * vm)1036 ficl_unshift_load_lib_path(ficlVm *vm)
1037 {
1038 #define h_uns_load_lib_path "( path -- ) prepend PATH to *load-lib-path*\n\
1039 \"/home/mike/lib/fth\" unshift-load-lib-path\n\
1040 Prepend string PATH to *load-lib-path* array if not already there."
1041 FTH_STACK_CHECK(vm, 1, 0);
1042 fth_unshift_load_lib_path(pop_cstring(vm));
1043 }
1044
1045 #define FINISH_LOAD() do { \
1046 vm->sourceId = old_source_id; \
1047 fth_current_file = old_file; \
1048 fth_current_line = old_line; \
1049 } while (0)
1050
1051 /*-
1052 * load_file(name, caller)
1053 *
1054 * Two load hooks:
1055 *
1056 * before_load_hook ( fname -- val )
1057 * after_load_hook ( fname -- val )
1058 *
1059 * Return values:
1060 *
1061 * #f if before_load_hook returned #f
1062 * #t if load was successful
1063 * throw exception if something went wrong
1064 */
1065 static FTH
load_file(const char * name,const char * caller)1066 load_file(const char *name, const char *caller)
1067 {
1068 ficlVm *vm;
1069 ficlInteger old_line, len, i, status;
1070 FTH fname, old_file, content, ret, fs;
1071 ficlCell old_source_id;
1072 ficlString s;
1073
1074 if (name == NULL)
1075 return (FTH_FALSE);
1076
1077 fname = fth_make_string(name);
1078
1079 if (!fth_hook_empty_p(before_load_hook)) {
1080 ret = fth_run_hook_bool(before_load_hook, 1, fname);
1081 if (FTH_FALSE_P(ret))
1082 return (FTH_FALSE);
1083 }
1084 old_line = fth_current_line;
1085 old_file = fth_current_file;
1086 content = fth_readlines(name);
1087 len = fth_array_length(content);
1088 vm = FTH_FICL_VM();
1089 old_source_id = vm->sourceId;
1090 fth_current_file = fname;
1091 CELL_VOIDP_SET(&vm->sourceId, name);
1092 fth_add_loaded_files(name);
1093
1094 for (i = 0; i < len; i++) {
1095 fth_current_line = i + 1;
1096 FICL_STRING_SET_FROM_CSTRING(s,
1097 fth_string_ref(fth_array_fast_ref(content, i)));
1098 status = ficlVmExecuteString(vm, s);
1099
1100 switch (status) {
1101 case FICL_VM_STATUS_INNER_EXIT:
1102 case FICL_VM_STATUS_OUT_OF_TEXT:
1103 case FICL_VM_STATUS_RESTART:
1104 case FICL_VM_STATUS_BREAK:
1105 case FICL_VM_STATUS_QUIT:
1106 continue;
1107 break;
1108 case FICL_VM_STATUS_SKIP_FILE:
1109 FINISH_LOAD();
1110 return (FTH_TRUE);
1111 break;
1112 case FICL_VM_STATUS_USER_EXIT:
1113 FINISH_LOAD();
1114 fth_exit(EXIT_SUCCESS);
1115 break;
1116 default:
1117 fs = fth_make_string_format("%S at line %ld",
1118 fth_current_file, fth_current_line);
1119 FINISH_LOAD();
1120 fth_throw(ficl_ans_real_exc((int) status),
1121 "%s: can't load file %S", caller, fs);
1122 /* NOTREACHED */
1123 return (FTH_FALSE);
1124 break;
1125 }
1126 }
1127
1128 CELL_INT_SET(&vm->sourceId, -1);
1129 FICL_STRING_SET_FROM_CSTRING(s, "");
1130 ficlVmExecuteString(vm, s);
1131
1132 if (!fth_hook_empty_p(after_load_hook))
1133 fth_run_hook(after_load_hook, 1, fname);
1134
1135 FINISH_LOAD();
1136 return (FTH_TRUE);
1137 }
1138
1139 /*-
1140 * fth_load_file(name)
1141 *
1142 * Two load hooks:
1143 *
1144 * before_load_hook ( fname -- val )
1145 * after_load_hook ( fname -- val )
1146 *
1147 * Return values:
1148 *
1149 * #f if before_load_hook returned #f
1150 * #t if load was successful
1151 * throw exception if something went wrong
1152 *
1153 * Load C string NAME as Fth source file and add NAME to global array
1154 * *loaded-files*. Before loading source file run hook before-load-hook
1155 * if not empty. If this hook returns #f, return immediately without
1156 * loading the source file and return FTH_FALSE. If loading finishes
1157 * successfully, return FTH_TRUE, otherwise return error string. After
1158 * loading source file run hook after-load-hook if not empty. If NAME
1159 * has no file extension, FTH_FILE_EXTENSION ('.fs') will be added.
1160 * If NAME or NAME plus FTH_FILE_EXTENSION doesn't exist, try all path
1161 * names from *load-path* with NAME.
1162 */
1163 FTH
fth_load_file(const char * name)1164 fth_load_file(const char *name)
1165 {
1166 char *func, *path, *tname, *fname;
1167 ficlInteger i, alen, slen;
1168 size_t size;
1169 FTH fs;
1170
1171 if (name == NULL)
1172 return (FTH_TRUE);
1173
1174 func = RUNNING_WORD();
1175
1176 if (fth_file_exists_p(name))
1177 return (load_file(name, func));
1178
1179 /*
1180 * If first char is a dot ('.') or slash ('/') or NAME contains a dot
1181 * ('name.fs'), the name is complete, otherwise add file extension
1182 * ".fs".
1183 */
1184 tname = misc_scratch;
1185 size = sizeof(misc_scratch);
1186 fth_strcpy(tname, size, name);
1187
1188 if (*name != '.' && *name != '/' && !strchr(name, '.'))
1189 fth_strcat(tname, size, "." FTH_FILE_EXTENSION);
1190
1191 if (fth_file_exists_p(tname))
1192 return (load_file(tname, func));
1193
1194 /*
1195 * If not found, try every path from load_path with NAME and probably
1196 * added file extension to find source file in Fth's environment.
1197 */
1198 alen = fth_array_length(load_path);
1199 fname = misc_scratch_02;
1200 fth_strcpy(fname, size, tname);
1201
1202 for (i = 0; i < alen; i++) {
1203 fs = fth_array_fast_ref(load_path, i);
1204 slen = fth_string_length(fs);
1205
1206 if (slen <= 0)
1207 continue;
1208
1209 path = fth_string_ref(fs);
1210 fth_strcpy(tname, size, path);
1211
1212 if (path[slen - 1] != '/')
1213 fth_strcat(tname, size, "/");
1214
1215 fth_strcat(tname, size, fname);
1216
1217 if (fth_file_exists_p(tname))
1218 return (load_file(tname, func));
1219 }
1220
1221 fth_throw(FTH_NO_SUCH_FILE, "%s: \"%s\" not found", func, name);
1222 /* NOTREACHED */
1223 return (FTH_TRUE);
1224 }
1225
1226 static void
ficl_include_file(ficlVm * vm)1227 ficl_include_file(ficlVm *vm)
1228 {
1229 #define h_include_file "( \"name\" -- ) load filename (parse word)\n\
1230 include hello\n\
1231 Load Forth source file NAME and add NAME to *loaded-files* \
1232 if it wasn't already there. \
1233 If file extension wasn't specified, use \".fs\". \
1234 If NAME doesn't exist, try each entry of *load-path* with NAME. \
1235 With INCLUDE one can load a file more than once.\n\
1236 Before loading NAME, run hook before-load-hook ( fname -- f ). \
1237 After loading NAME, run hook after-load-hook ( fname -- ). \
1238 Raise NO-SUCH-FILE exception if file doesn't exist. \
1239 Raise LOAD-ERROR if an error occured during load.\n\
1240 See also require, before-load-hook and after-load-hook."
1241 ficlVmGetWordToPad(vm);
1242 fth_load_file(vm->pad);
1243 }
1244
1245 /*-
1246 * fth_require_file(name)
1247 *
1248 * Two load hooks:
1249 *
1250 * before_load_hook ( fname -- val )
1251 * after_load_hook ( fname -- val )
1252 *
1253 * Return values:
1254 *
1255 * #f if before_load_hook returned #f
1256 * #t if load was successful
1257 * throw exception if something went wrong
1258 *
1259 * Load C string NAME as Fth source file if not already loaded and add
1260 * NAME to global array *loaded-files*. Before loading source file
1261 * run hook before-load-hook if not empty. If this hook returns #f,
1262 * return immediately without loading the source file and return
1263 * FTH_FALSE. If loading finishes successfully, return FTH_TRUE,
1264 * otherwise return error string. After loading source file run hook
1265 * after-load-hook if not empty. If NAME has no file extension,
1266 * FTH_FILE_EXTENSION ('.fs') will be added. If NAME or NAME plus
1267 * FTH_FILE_EXTENSION doesn't exist, try all path names from *load-path*
1268 * with NAME.
1269 */
1270 FTH
fth_require_file(const char * name)1271 fth_require_file(const char *name)
1272 {
1273 FTH fs;
1274
1275 if (name == NULL)
1276 return (FTH_TRUE);
1277
1278 fs = fth_make_string(name);
1279
1280 if (fth_array_member_p(loaded_files, fs))
1281 return (FTH_TRUE);
1282
1283 /*
1284 * If first char is a dot ('.') or slash ('/') or 'name' contains a
1285 * dot, the name is complete, otherwise, add file extension '.fs'.
1286 */
1287 if (*name != '.' && *name != '/' && !strchr(name, '.'))
1288 fth_string_scat(fs, "." FTH_FILE_EXTENSION);
1289
1290 if (fth_array_member_p(loaded_files, fs))
1291 return (FTH_TRUE);
1292
1293 if (FTH_STRING_P(fth_find_file(fs)))
1294 return (FTH_TRUE);
1295
1296 return (fth_load_file(name));
1297 }
1298
1299 static void
ficl_require_file(ficlVm * vm)1300 ficl_require_file(ficlVm *vm)
1301 {
1302 #define h_require_file "( \"name\" -- ) load filename (parse word)\n\
1303 require hello\n\
1304 If Forth source file NAME doesn't exist in the array *loaded-files*, \
1305 load it and add NAME to *loaded-files*. \
1306 If file extension wasn't specified, use \".fs\". \
1307 If NAME doesn't exist, try each entry of *load-path* with NAME. \
1308 With REQUIRE one can load a file only one time.\n\
1309 Before loading NAME, run hook before-load-hook ( fname -- f ). \
1310 After loading NAME, run hook after-load-hook ( fname -- ). \
1311 Raise NO-SUCH-FILE exception if file doesn't exist. \
1312 Raise LOAD-ERROR if an error occured during load.\n\
1313 See also include, before-load-hook and after-load-hook."
1314 ficlVmGetWordToPad(vm);
1315 fth_require_file(vm->pad);
1316 }
1317
1318 /*-
1319 * fth_load_init_file(init_file)
1320 *
1321 * if init file ~/.fthrc or $FTH_INIT_FILE exists:
1322 *
1323 * before_load_hook ( fname -- val )
1324 * after_load_hook ( fname -- val )
1325 *
1326 * #f if before_load_hook returned false
1327 * #t if loaded successful
1328 * error string if something went wrong
1329 *
1330 * #t if init file doesn't exist
1331 *
1332 * Load C string INIT_FILE as Forth source file if it exists, otherwise
1333 * do nothing. If INIT_FILE is NULL, try to load ${FTH_INIT_FILE}.
1334 * If ${FTH_INIT_FILE} is not set, try to load ${HOME}/.fthrc instead.
1335 * Run before-load-hook and after-load-hook if not empty.
1336 */
1337 FTH
fth_load_init_file(const char * init_file)1338 fth_load_init_file(const char *init_file)
1339 {
1340 /* If no filename was given ... */
1341 if (init_file == NULL) {
1342 /* ... and no environment variable was set ... */
1343 init_file = fth_getenv(FTH_ENV_INIT_FILE, NULL);
1344
1345 if (init_file == NULL) {
1346 char *home, *file;
1347 size_t size;
1348
1349 /* ... take ${HOME}/.fthrc */
1350 home = fth_getenv("HOME", "/tmp");
1351 file = misc_scratch;
1352 size = sizeof(misc_scratch);
1353 fth_strcpy(file, size, home);
1354 fth_strcat(file, size, "/" FTH_INIT_FILE);
1355 init_file = file;
1356 }
1357 }
1358 if (fth_file_exists_p(init_file))
1359 return (load_file(init_file, RUNNING_WORD()));
1360
1361 /* If no file exists, do nothing and pretend all is okay. */
1362 return (FTH_TRUE);
1363 }
1364
1365 /*-
1366 * fth_load_global_init_file()
1367 *
1368 * if init file ${prefix}/etc/fth.conf exists:
1369 *
1370 * before_load_hook ( fname -- val )
1371 * after_load_hook ( fname -- val )
1372 *
1373 * #f if before_load_hook returned false
1374 * #t if loaded successful
1375 * error string if something went wrong
1376 *
1377 * #t if init file doesn't exist
1378 *
1379 * Load FTH_GLOBAL_INIT_FILE (${prefix}/etc/fthrc) as Forth source
1380 * file if it exists, otherwise do nothing. Run before-load-hook and
1381 * after-load-hook if not empty.
1382 */
1383 FTH
fth_load_global_init_file(void)1384 fth_load_global_init_file(void)
1385 {
1386 if (fth_file_exists_p(FTH_GLOBAL_INIT_FILE))
1387 return (load_file(FTH_GLOBAL_INIT_FILE, RUNNING_WORD()));
1388 return (FTH_TRUE);
1389 }
1390
1391 static void
ficl_load_init_file(ficlVm * vm)1392 ficl_load_init_file(ficlVm *vm)
1393 {
1394 #define h_load_init_file "( file -- ) load init file\n\
1395 \".my-fth-init\" load-init-file\n\
1396 If Forth source FILE exists in current or $HOME dir, load it, \
1397 otherwise do nothing.\n\
1398 See also include and require."
1399 char *str, *file, *home;
1400 size_t size;
1401 FTH fs;
1402
1403 FTH_STACK_CHECK(vm, 1, 0);
1404 fs = fth_pop_ficl_cell(vm);
1405 FTH_ASSERT_ARGS(FTH_STRING_P(fs), fs, FTH_ARG1, "a string");
1406 str = fth_string_ref(fs);
1407
1408 if (str == NULL)
1409 return;
1410
1411 file = str;
1412
1413 if (fth_file_exists_p(file)) {
1414 load_file(file, RUNNING_WORD_VM(vm));
1415 return;
1416 }
1417 file = misc_scratch;
1418 size = sizeof(misc_scratch);
1419 fth_strcpy(file, size, "./");
1420 fth_strcat(file, size, str);
1421
1422 if (fth_file_exists_p(file)) {
1423 load_file(file, RUNNING_WORD_VM(vm));
1424 return;
1425 }
1426 home = fth_getenv("HOME", "/tmp");
1427
1428 if (home == NULL)
1429 return;
1430
1431 fth_strcpy(file, size, home);
1432 fth_strcat(file, size, "/");
1433 fth_strcat(file, size, str);
1434
1435 if (fth_file_exists_p(file))
1436 load_file(file, RUNNING_WORD_VM(vm));
1437 }
1438
1439 #if defined(HAVE_DLOPEN)
1440
1441 /*-
1442 * load_lib(name, func, caller)
1443 *
1444 * before_load_hook ( fname -- val )
1445 * after_load_hook ( fname -- val )
1446 *
1447 * #f if before_load_hook returned false
1448 * #t if loaded successful
1449 * *so-file-error* exception if something went wrong
1450 *
1451 */
1452 static FTH
load_lib(const char * name,const char * func,const char * caller)1453 load_lib(const char *name, const char *func, const char *caller)
1454 {
1455 FTH fname, old_file;
1456 void *handle;
1457 void (*init_fnc) (void);
1458 ficlVm *vm;
1459 ficlInteger old_line;
1460 ficlCell old_source_id;
1461
1462 handle = (void *) dlopen(name, RTLD_LAZY | RTLD_GLOBAL);
1463
1464 if (handle == NULL) {
1465 fth_throw(FTH_SO_FILE_ERROR, "%s: %s", caller, dlerror());
1466 /* NOTREACHED */
1467 return (FTH_FALSE);
1468 }
1469 fname = fth_make_string(name);
1470
1471 if (!fth_hook_empty_p(before_load_hook) &&
1472 FTH_FALSE_P(fth_run_hook_bool(before_load_hook, 1, fname))) {
1473 dlclose(handle);
1474 return (FTH_FALSE);
1475 }
1476 init_fnc = (void (*) (void)) dlsym(handle, func);
1477
1478 if (init_fnc == NULL) {
1479 dlclose(handle);
1480 fth_throw(FTH_SO_FILE_ERROR, "%s: %s", caller, dlerror());
1481 /* NOTREACHED */
1482 return (FTH_FALSE);
1483 }
1484 old_file = fth_current_file;
1485 old_line = fth_current_line;
1486 vm = FTH_FICL_VM();
1487 old_source_id = vm->sourceId;
1488 CELL_VOIDP_SET(&vm->sourceId, name);
1489 fth_current_file = fname;
1490 fth_current_line = 0;
1491 fth_add_loaded_files(name);
1492 /* Calling Init_dbm() etc. */
1493 (*init_fnc) ();
1494
1495 if (!fth_hook_empty_p(after_load_hook))
1496 fth_run_hook(after_load_hook, 1, fname);
1497
1498 FINISH_LOAD();
1499 return (FTH_TRUE);
1500 }
1501
1502 /*-
1503 * fth_dl_load(name, func)
1504 *
1505 * before_load_hook ( fname -- val )
1506 * after_load_hook ( fname -- val )
1507 *
1508 * #f if before_load_hook returned false
1509 * #t if loaded successful or file already loaded
1510 * *so-file-error* exception if something went wrong
1511 *
1512 * Load C string NAME as dynamic library if not already loaded and add
1513 * NAME to global array *loaded-files*. C string FUNC will be called
1514 * after load was successful. Before loading the dynamic library run
1515 * hook before-load-hook if not empty. If this hook returns #f, return
1516 * immediately without loading the library and return FTH_FALSE. If
1517 * loading finishes successfully or library was already loaded, return
1518 * FTH_TRUE, otherwise raise SO_FILE_ERROR exception. After loading
1519 * the dynamic library run hook after-load-hook if not empty. If NAME
1520 * has no file extension, '.so' will be added. If NAME or NAME plus
1521 * '.so' doesn't exist, try all path names from *load-lib-path* with
1522 * NAME.
1523 */
1524 FTH
fth_dl_load(const char * name,const char * func)1525 fth_dl_load(const char *name, const char *func)
1526 {
1527 char *caller, *path, *tname, *fname;
1528 ficlInteger i, alen, slen;
1529 size_t size;
1530 FTH fs;
1531
1532 tname = misc_scratch;
1533 fname = misc_scratch_02;
1534 size = sizeof(misc_scratch);
1535 caller = RUNNING_WORD();
1536 fth_strcpy(tname, size, name);
1537
1538 if (strstr(name, ".so") == NULL)
1539 fth_strcat(tname, size, ".so");
1540
1541 if (fth_array_member_p(loaded_files, fth_make_string(tname)))
1542 return (FTH_TRUE);
1543
1544 if (fth_file_exists_p(tname))
1545 return (load_lib(tname, func, caller));
1546
1547 alen = fth_array_length(load_lib_path);
1548
1549 for (i = 0; i < alen; i++) {
1550 fs = fth_array_fast_ref(load_lib_path, i);
1551 slen = fth_string_length(fs);
1552
1553 if (slen <= 0)
1554 continue;
1555
1556 path = fth_string_ref(fs);
1557 fth_strcpy(fname, size, path);
1558
1559 if (path[slen - 1] != '/')
1560 fth_strcat(fname, size, "/");
1561
1562 fth_strcat(fname, size, tname);
1563
1564 if (fth_array_member_p(loaded_files, fth_make_string(fname)))
1565 return (FTH_TRUE);
1566
1567 if (fth_file_exists_p(fname))
1568 return (load_lib(fname, func, caller));
1569 }
1570
1571 fth_throw(FTH_NO_SUCH_FILE, "%s: \"%s\" not found", caller, name);
1572 /* NOTREACHED */
1573 return (FTH_TRUE);
1574 }
1575
1576 #else /* !HAVE_DLOPEN */
1577
1578 /* ARGSUSED */
1579 FTH
fth_dl_load(const char * name,const char * func)1580 fth_dl_load(const char *name, const char *func)
1581 {
1582 (void) name;
1583 (void) func;
1584 FTH_NOT_IMPLEMENTED_ERROR(dlopen);
1585 return (FTH_FALSE);
1586 }
1587
1588 #endif /* HAVE_DLOPEN */
1589
1590 static void
ficl_dl_load(ficlVm * vm)1591 ficl_dl_load(ficlVm *vm)
1592 {
1593 #define h_dl_load "( \"lib\" \"func\" -- ) load dynamic lib (parse word)\n\
1594 dl-load dbm Init_dbm\n\
1595 Load dynamic library LIB and call its function FUNC.\n\
1596 See also include and require."
1597 char *lib, *fnc;
1598 ficlString s;
1599 size_t size;
1600
1601 lib = misc_scratch_03;
1602 fnc = misc_scratch_04;
1603 size = sizeof(misc_scratch_03);
1604 s = ficlVmGetWord0(vm);
1605 fth_strncpy(lib, size, s.text, s.length);
1606 s = ficlVmGetWord0(vm);
1607 fth_strncpy(fnc, size, s.text, s.length);
1608 #if defined(FTH_STATIC)
1609 return;
1610 #endif
1611 if (!fth_provided_p(fth_basename(lib)))
1612 fth_dl_load(lib, fnc);
1613 }
1614
1615 #if !defined(_WIN32)
1616 void
fth_install_file(FTH fname)1617 fth_install_file(FTH fname)
1618 {
1619 #define h_install_file "( file -- ) install library\n\
1620 \"snd-test.fs\" install-file\n\
1621 \"sndlib.so\" install-file\n\
1622 Install FILE in first writeable path \
1623 found in *load-path* (*.fs[m]) or *load-lib-path* (*.so). \
1624 A warning is given if no writable path was found.\n\
1625 See also install and file-install."
1626 char *lname, *pname, *tname;
1627 FTH path_array, fs;
1628 mode_t mode;
1629 size_t size;
1630 ficlInteger i, alen, slen;
1631
1632 FTH_ASSERT_ARGS(FTH_STRING_P(fname), fname, FTH_ARG1, "a string");
1633 lname = fth_string_ref(fname);
1634 slen = fth_string_length(fname);
1635
1636 if (lname == NULL)
1637 return;
1638
1639 if (!fth_file_exists_p(lname)) {
1640 fth_warning("%s: file \"%s\" does not exist, nothing done",
1641 RUNNING_WORD(), lname);
1642 return;
1643 }
1644 if (strncmp(lname + slen - 3, ".fs", 3L) == 0 ||
1645 strncmp(lname + slen - 4, ".fsm", 4L) == 0) {
1646 /* forth-source.fs */
1647 /* mode = 0644 */
1648 mode = S_IRUSR | S_IWUSR | S_IRGRP | S_IROTH;
1649 path_array = load_path;
1650 } else if (strncmp(lname + slen - 3, ".so", 3L) == 0) {
1651 /* c-library.so */
1652 /* mode = 0755 */
1653 mode = S_IXUSR | S_IRUSR | S_IWUSR | S_IXGRP | S_IRGRP |
1654 S_IXOTH | S_IROTH;
1655 path_array = load_lib_path;
1656 } else {
1657 fth_warning("%s: \"%s\" not a library, nothing done",
1658 RUNNING_WORD(), lname);
1659 return;
1660 }
1661 alen = fth_array_length(path_array);
1662 tname = misc_scratch;
1663 size = sizeof(misc_scratch);
1664
1665 for (i = 0; i < alen; i++) {
1666 fs = fth_array_fast_ref(path_array, i);
1667 slen = fth_string_length(fs);
1668
1669 if (slen <= 0)
1670 continue;
1671
1672 pname = fth_string_ref(fs);
1673
1674 if (*pname == '.' || !fth_file_writable_p(pname))
1675 continue;
1676
1677 fth_strcpy(tname, size, pname);
1678
1679 if (pname[slen - 1] != '/')
1680 fth_strcat(tname, size, "/");
1681
1682 fth_strcat(tname, size, fth_basename(lname));
1683
1684 if (fth_file_install(lname, tname, mode))
1685 if (FTH_TO_BOOL(fth_variable_ref("*fth-verbose*")))
1686 fth_printf("\\ %s --> %04o %s\n",
1687 lname, mode, tname);
1688
1689 return;
1690 }
1691
1692 fth_warning("%s: no path found for \"%s\", nothing done",
1693 RUNNING_WORD(), lname);
1694 }
1695
1696 void
fth_install(void)1697 fth_install(void)
1698 {
1699 #define h_install "( \"file\" -- ) install library (parse word)\n\
1700 install snd-test.fs\n\
1701 install sndlib.so\n\
1702 fth -ve 'install sndlib.so' -e ''\n\
1703 Install FILE in first writeable path found \
1704 in *load-path* (*.fs[m]) or *load-lib-path* (*.so).\n\
1705 In the last example the trailing \"-e ''\" is necessary \
1706 because the last occurrence of \"-e pattern\" will be compiled. \
1707 INSTALL is a parse word and won't work in compile state.\n\
1708 See also install-file and file-install."
1709 ficlVmGetWordToPad(FTH_FICL_VM());
1710 fth_install_file(fth_make_string(FTH_FICL_VM()->pad));
1711 }
1712 #endif /* !_WIN32 */
1713
1714 /*
1715 * Return full path of NAME or #f.
1716 */
1717 FTH
fth_find_file(FTH name)1718 fth_find_file(FTH name)
1719 {
1720 ficlInteger i , alen;
1721 FTH fp, fn, fs;
1722
1723 FTH_ASSERT_ARGS(FTH_STRING_P(name), name, FTH_ARG1, "a string");
1724 alen = fth_array_length(load_path);
1725
1726 for (i = 0; i < alen; i++) {
1727 fp = fth_array_fast_ref(load_path, i);
1728 fn = fth_make_string_format("%S/%S", fp, name);
1729 fs = fth_array_find(loaded_files, fn);
1730
1731 if (FTH_STRING_P(fs))
1732 return (fs);
1733 }
1734
1735 return (FTH_FALSE);
1736 }
1737
1738 /*
1739 * Find NAME in Forth dictionary and return ficlWord.
1740 */
1741 FTH
fth_word_ref(const char * name)1742 fth_word_ref(const char *name)
1743 {
1744 return ((FTH) FICL_WORD_NAME_REF(name));
1745 }
1746
1747 /*
1748 * Used by snd/snd-help.c and repl/repl.c.
1749 */
1750 char *
fth_parse_word(void)1751 fth_parse_word(void)
1752 {
1753 ficlVm *vm;
1754 ficlWord *w;
1755
1756 vm = FTH_FICL_VM();
1757 ficlVmGetWordToPad(vm);
1758 w = FICL_WORD_NAME_REF(vm->pad);
1759
1760 if (w != NULL)
1761 return (w->name);
1762
1763 if (fth_strlen(vm->pad) > 0)
1764 return (vm->pad);
1765
1766 return (NULL);
1767 }
1768
1769 FTH
fth_wordlist_each(int (* func)(ficlWord * word,FTH data),FTH data)1770 fth_wordlist_each(int (*func) (ficlWord *word, FTH data), FTH data)
1771 {
1772 FTH ret;
1773 ficlDictionary *dict;
1774 ficlHash *hash;
1775 ficlWord *word;
1776 int i, j;
1777
1778 dict = FTH_FICL_SYSTEM()->dictionary;
1779 ret = fth_make_empty_array();
1780
1781 for (i = (int) dict->wordlistCount - 1; i >= 0; i--)
1782 for (hash = dict->wordlists[i];
1783 hash != NULL;
1784 hash = hash->link)
1785 for (j = (int) hash->size - 1; j >= 0; j--)
1786 for (word = hash->table[j];
1787 word != NULL;
1788 word = word->link)
1789 if ((*func) (word, data))
1790 fth_array_push(ret,
1791 FTH_WORD_NAME(word));
1792
1793 return (fth_array_uniq(ret));
1794 }
1795
1796 static int
find_in_wordlist(ficlWord * word,FTH data)1797 find_in_wordlist(ficlWord *word, FTH data)
1798 {
1799 char *text = (char *) data;
1800
1801 return (word->length > 0 &&
1802 ficlStrincmp(word->name, text, fth_strlen(text)) == 0);
1803 }
1804
1805 FTH
fth_find_in_wordlist(const char * text)1806 fth_find_in_wordlist(const char *text)
1807 {
1808 if (text != NULL && *text != '\0')
1809 return (fth_wordlist_each(find_in_wordlist, (FTH) text));
1810 return (fth_make_empty_array());
1811 }
1812
1813 static int
apropos(ficlWord * word,FTH data)1814 apropos(ficlWord *word, FTH data)
1815 {
1816 if (word->length > 0)
1817 return (fth_regexp_match(data, FTH_WORD_NAME(word)) >= 0);
1818 return (0);
1819 }
1820
1821 FTH
fth_apropos(FTH regexp)1822 fth_apropos(FTH regexp)
1823 {
1824 #define h_apropos "( obj -- ary ) search in wordlist\n\
1825 /do/ apropos => #( \"doLocal\" ... )\n\
1826 Return array of dictionary entries matching regexpression or string OBJ."
1827 return (fth_wordlist_each(apropos, regexp));
1828 }
1829
1830 /* === MISCELLANEOUS === */
1831
1832 /* partly stolen from ficl/primitive.c, ficlPrimitiveCatch() */
1833 static void
ficl_catch(ficlVm * vm)1834 ficl_catch(ficlVm *vm)
1835 {
1836 #define h_fth_catch "( ?? proc-or-xt|#f exc|#t arg -- ?? #f|exc|arg ) catch\n\
1837 3 :initial-element 0.3 make-array value ary\n\
1838 ary .array => #( 0.3 0.3 0.3 )\n\
1839 ary 2 <'> array-ref #t nil fth-catch => 0.3 #f\n\
1840 ary 4 <'> array-ref 'out-of-range #t fth-catch => #( 0.3 0.3 0.3 ) 4 #t\n\
1841 : ary-handler { retval -- val }\n\
1842 \"from handler: %S\\n\" #( retval ) fth-print\n\
1843 #t ( return value )\n\
1844 ;\n\
1845 ary 4 0.4 <'> array-set! 'out-of-range <'> ary-handler fth-catch\n\
1846 => from handler: \\\n\
1847 #( 'out-of-range \"array-set! (ary_set) arg 2: 4 is out of range\" )\n\
1848 0.4 #t\n\
1849 ary 2 0.4 <'> array-set! 'out-of-range <'> ary-handler fth-catch => #f\n\
1850 Run PROC-OR-XT in save environment. \
1851 If PROC-OR-XT fails with an exception, \
1852 data and return stack environments are recovered \
1853 to the state before execution.\n\
1854 PROC-OR-XT:\n\
1855 If PROC-OR-XT is #f, FTH-CATCH finishs immediately and returns #f.\n\
1856 EXC:\n\
1857 The second argument EXC may be a symbol, an exception, or #t. \
1858 If it's a symbol or an exception, this will be catched, \
1859 if it's #t, all exceptions will be catched.\n\
1860 ARG:\n\
1861 The third argument ARG may be NIL or a return value. \
1862 If ARG is NIL, the catched exception or #f will be returned, \
1863 if ARG is any other than NIL, ARG will be returned instead \
1864 of the catched exception; \
1865 if ARG is a proc or xt, this will be executed instead of simply returned. \
1866 The stack effect must be ( retval -- val ).\n\
1867 See also fth-throw and fth-raise."
1868 FTH prc, obj;
1869 volatile FTH arg;
1870 jmp_buf jmp_env;
1871 ficlWord *volatile word;
1872 volatile ficlVm vm_copy;
1873 volatile ficlStack data_stack_copy;
1874 volatile ficlStack return_stack_copy;
1875 volatile FTH exc, rval, result;
1876
1877 FTH_STACK_CHECK(vm, 3, 1);
1878 arg = fth_pop_ficl_cell(vm);
1879 obj = fth_pop_ficl_cell(vm);
1880 prc = fth_pop_ficl_cell(vm);
1881
1882 if (FTH_FALSE_P(prc)) {
1883 ficlStackPushBoolean(vm->dataStack, 0);
1884 return;
1885 }
1886 FTH_ASSERT_ARGS(FICL_WORD_P(prc), prc, FTH_ARG1, "a proc or an xt");
1887 exc = FTH_TRUE_P(obj) ? obj : fth_symbol_or_exception_ref(obj);
1888 FTH_ASSERT_ARGS(FTH_NOT_FALSE_P(exc), obj, FTH_ARG2,
1889 "a symbol, an exception, or #t");
1890 word = FICL_WORD_REF(prc);
1891 memcpy((void *) &vm_copy, vm, sizeof(ficlVm));
1892 memcpy((void *) &data_stack_copy, vm->dataStack, sizeof(ficlStack));
1893 memcpy((void *) &return_stack_copy, vm->returnStack, sizeof(ficlStack));
1894 vm->exceptionHandler = &jmp_env;
1895 vm->fth_catch_p = 1;
1896 result = FTH_FALSE;
1897
1898 switch (setjmp(jmp_env)) {
1899 case 0:
1900 ficlVmPushIP(vm, &(vm->callback.system->exitInnerWord));
1901 ficlVmInnerLoop(vm, word);
1902 ficlVmInnerLoop(vm, 0);
1903 break;
1904 case FICL_VM_STATUS_INNER_EXIT: /* okay => return #f */
1905 ficlVmPopIP(vm);
1906 vm->exceptionHandler = vm_copy.exceptionHandler;
1907 vm->fth_catch_p = 0;
1908 result = FTH_FALSE;
1909 break;
1910 default: /* exception */
1911 memcpy(vm, (void *) &vm_copy, sizeof(ficlVm));
1912 memcpy(vm->dataStack, (void *) &data_stack_copy,
1913 sizeof(ficlStack));
1914 memcpy(vm->returnStack, (void *) &return_stack_copy,
1915 sizeof(ficlStack));
1916 vm->exceptionHandler = vm_copy.exceptionHandler;
1917 vm->fth_catch_p = 0;
1918
1919 if (FTH_TRUE_P(exc)) {
1920 FTH ex, fs;
1921
1922 ex = fth_variable_ref("*last-exception*");
1923 fs = fth_exception_last_message_ref(ex);
1924 rval = FTH_LIST_2(ex, fs);
1925 } else {
1926 FTH fs;
1927
1928 fs = fth_exception_last_message_ref(exc);
1929 rval = FTH_LIST_2(exc, fs);
1930 }
1931 if (FTH_TRUE_P(exc) ||
1932 fth_exception_equal_p(fth_car(rval), exc)) {
1933 if (FICL_WORD_P(arg)) {
1934 FTH a;
1935
1936 a = proc_from_proc_or_xt(arg, 1, 0, 0);
1937
1938 if (FTH_PROC_P(a))
1939 result = fth_proc_call(a,
1940 RUNNING_WORD_VM(vm), 1, rval);
1941 else
1942 result = rval;
1943 } else
1944 result = FTH_NIL_P(arg) ? rval : arg;
1945 } else {
1946 if (fth_object_length(rval) > 1)
1947 fth_throw_error(fth_car(rval), fth_cdr(rval));
1948 else
1949 fth_throw_error(fth_car(rval), rval);
1950 }
1951 break;
1952 }
1953
1954 fth_push_ficl_cell(vm, result);
1955 }
1956
1957 static void
ficl_throw(ficlVm * vm)1958 ficl_throw(ficlVm *vm)
1959 {
1960 #define h_fth_throw "( exc args -- ) throw exception\n\
1961 \\ any object\n\
1962 'bad-arity proc fth-throw\n\
1963 => #<bad-arity in test-proc>\n\
1964 \\ nil or #()\n\
1965 'bad-arity nil fth-throw\n\
1966 => #<bad-arity: proc has bad arity>\n\
1967 \\ #( string )\n\
1968 'bad-arity #( \"test-proc\" ) fth-throw\n\
1969 => #<bad-arity in test-proc>\n\
1970 \\ #( fmt arg1 arg2 arg3 )\n\
1971 'bad-arity #( \"%s: %s args required, got %s\"\n\
1972 proc\n\
1973 2\n\
1974 3 ) fth-throw\n\
1975 => #<bad-arity in test-proc: 2 args required, got 3>\n\
1976 Throw exception EXC with text built from ARGS. \
1977 If ARGS is not an array, ARGS's string representation is used. \
1978 If ARGS is NIL or an empty array, a default string is used. \
1979 If ARGS is an array with one element, this string is used. \
1980 If ARGS is an array and its first element is a format string with N \
1981 %s-format signs, ARGS should have N more elements with corresponding values.\n\
1982 See also fth-raise and fth-catch."
1983 FTH obj, args;
1984
1985 FTH_STACK_CHECK(vm, 2, 0);
1986 args = fth_pop_ficl_cell(vm);
1987 obj = fth_pop_ficl_cell(vm);
1988 /* Set to calling word. */
1989 vm->runningWord = vm->runningWord->current_word;
1990 fth_throw_error(obj, args);
1991 }
1992
1993 static void
ficl_raise(ficlVm * vm)1994 ficl_raise(ficlVm *vm)
1995 {
1996 #define h_fth_raise "( exc fmt args -- ) raise exception\n\
1997 'bad-arity \"%s: %s args require, got %s\" #( proc 3 2 ) fth-raise\n\
1998 => #<bad-arity in test-proc: 3 args required, got 2>\n\
1999 #f #f #f fth-raise => reraise last exception\n\
2000 Raise exception EXC with text built from FMT and ARGS. \
2001 If FMT is a format string with N %s-format signs, \
2002 ARGS should have N elements with corresponding values. \
2003 If EXC is #f, reraise last exception.\n\
2004 See also fth-throw and fth-catch."
2005 FTH exc, fmt, args;
2006
2007 FTH_STACK_CHECK(vm, 3, 0);
2008 args = fth_pop_ficl_cell(vm);
2009 fmt = fth_pop_ficl_cell(vm);
2010 exc = fth_pop_ficl_cell(vm);
2011
2012 if (FTH_NOT_FALSE_P(exc)) {
2013 /* Set to calling word. */
2014 vm->runningWord = vm->runningWord->current_word;
2015 fth_throw(exc, "%S", fth_string_format(fmt, args));
2016 /* NOTREACHED */
2017 }
2018
2019 /*
2020 * #f #f #f fth-raise: status-error with last exception info
2021 */
2022 if (FTH_EXCEPTION_P(fth_last_exception)) {
2023 FTH fs;
2024
2025 fs = fth_exception_last_message_ref(fth_last_exception);
2026
2027 if (FTH_FALSE_P(fs)) {
2028 char *s;
2029
2030 s = fth_exception_ref(fth_last_exception);
2031 fth_errorf("#<%s>\n", s);
2032 } else
2033 fth_errorf("#<%S>\n", fs);
2034 } else
2035 fth_errorf("#<no last exception found>\n");
2036 fth_show_backtrace(0);
2037 errno = 0;
2038 fth_reset_loop_and_depth();
2039 ficlVmReset(vm);
2040 ficlVmThrow(vm, FICL_VM_STATUS_ERROR_EXIT);
2041 }
2042
2043 static void
ficl_stack_reset(ficlVm * vm)2044 ficl_stack_reset(ficlVm *vm)
2045 {
2046 #define h_stack_reset "( ?? -- ) reset stack\n\
2047 stack-reset\n\
2048 Reset the data stack to initial state."
2049 ficlStackReset(vm->dataStack);
2050 }
2051
2052 #if defined(HAVE_GETTIMEOFDAY)
2053 static struct timeval fth_timeval_tv;
2054
2055 static void
ficl_time(ficlVm * vm)2056 ficl_time(ficlVm *vm)
2057 {
2058 #define h_time "( -- r ) return time\n\
2059 time => 4055.3\n\
2060 Return real time, a ficlFloat.\n\
2061 See gettimeofday(2) for more information.\n\
2062 See also reset-time."
2063 struct timeval tv;
2064 double f;
2065
2066 FTH_STACK_CHECK(vm, 0, 1);
2067 tv.tv_sec = 0;
2068 tv.tv_usec = 0;
2069
2070 if (gettimeofday(&tv, NULL) == -1)
2071 FTH_SYSTEM_ERROR_THROW(gettimeofday);
2072
2073 f = (double) tv.tv_sec - (double) fth_timeval_tv.tv_sec;
2074 f += ((double) tv.tv_usec - (double) fth_timeval_tv.tv_usec) * 1e-6;
2075 ficlStackPushFloat(vm->dataStack, f);
2076 }
2077
2078 /* ARGSUSED */
2079 static void
ficl_time_reset(ficlVm * vm)2080 ficl_time_reset(ficlVm *vm)
2081 {
2082 #define h_time_reset "( -- ) reset time\n\
2083 time-reset\n\
2084 Set global timeval struct variable to current time.\n\
2085 See gettimeofday(2) for more information.\n\
2086 See also time."
2087 (void) vm;
2088 if (gettimeofday(&fth_timeval_tv, NULL) == -1)
2089 FTH_SYSTEM_ERROR_THROW(gettimeofday);
2090 }
2091 #endif /* HAVE_GETTIMEOFDAY */
2092
2093 static void
ficl_utime(ficlVm * vm)2094 ficl_utime(ficlVm *vm)
2095 {
2096 #define h_utime "( -- utime stime ) return user and system time\n\
2097 utime => 0.171875 0.0234375\n\
2098 Return user and system time as ficlFloats. \
2099 Raise NOT-IMPLEMENTED exception if times(3) is not available.\n\
2100 See times(3) for more information."
2101 double hertz;
2102
2103 #if defined(HAVE_TIMES) && defined(HAVE_STRUCT_TMS)
2104 struct tms buf;
2105
2106 #if defined(HAVE_SYSCONF) && defined(HAVE_DECL__SC_CLK_TCK)
2107 hertz = (double) sysconf(_SC_CLK_TCK);
2108 #else /* !HAVE_SYSCONF */
2109 #if !defined(HZ)
2110 #if defined(CLK_TCK)
2111 #define HZ CLK_TCK
2112 #else /* !CLK_TCK */
2113 #define HZ 60
2114 #endif /* CLK_TCK */
2115 #endif /* !HZ */
2116 hertz = (double) HZ;
2117 #endif /* HAVE_SYSCONF */
2118 if (hertz < 0.0)
2119 FTH_SYSTEM_ERROR_THROW(sysconf);
2120 times(&buf);
2121 ficlStackPushFloat(vm->dataStack, (double) buf.tms_utime / hertz);
2122 ficlStackPushFloat(vm->dataStack, (double) buf.tms_stime / hertz);
2123 #else /* !HAVE_TIMES */
2124 FTH_NOT_IMPLEMENTED_ERROR(times);
2125 #endif /* HAVE_TIMES */
2126 }
2127
2128 static void
ficl_current_time(ficlVm * vm)2129 ficl_current_time(ficlVm *vm)
2130 {
2131 #define h_current_time "( -- time-count ) return seconds since 1970\n\
2132 currnet-time => 1326505228\n\
2133 current-time time->string => \"Sat Jan 14 02:40:28 CET 2012\"\n\
2134 Return time in seconds since 1970/01/01 as ficl2Unsigned.\n\
2135 See time(3) for more information.\n\
2136 See also strftime, strptime and time->string."
2137 FTH_STACK_CHECK(vm, 0, 1);
2138 ficlStackPush2Unsigned(vm->dataStack, (ficl2Unsigned) time(NULL));
2139 }
2140
2141 static void
ficl_time_to_string(ficlVm * vm)2142 ficl_time_to_string(ficlVm *vm)
2143 {
2144 #define h_time_to_string "( secs -- str ) convert number to string\n\
2145 current-time time->string => \"Sat Jan 14 02:40:28 CET 2012\"\n\
2146 Convert ficl2Unsigned SECS in a date string in current local time.\n\
2147 See also strftime, strptime and current-time."
2148 time_t tp;
2149
2150 FTH_STACK_CHECK(vm, 1, 1);
2151 tp = (time_t) ficlStackPop2Unsigned(vm->dataStack);
2152 strftime(vm->pad, sizeof(vm->pad), "%a %b %d %H:%M:%S %Z %Y",
2153 localtime(&tp));
2154 push_cstring(vm, vm->pad);
2155 }
2156
2157 static void
ficl_strftime(ficlVm * vm)2158 ficl_strftime(ficlVm *vm)
2159 {
2160 #define h_strftime "( fmt secs -- str ) convert TIME according to FMT\n\
2161 \"%a %b %d %H:%M:%S %Z %Y\" current-time strftime\n\
2162 => \"Sat Jan 14 02:40:28 CET 2012\"\n\
2163 Convert ficl2Unsigned SECS in a date string corresponding to FMT. \
2164 The FMT string will be interpreted by strftime(3).\n\
2165 See strftime(3) for more information.\n\
2166 See also strptime, time->string and current-time."
2167 FTH fmt;
2168 time_t tp;
2169
2170 FTH_STACK_CHECK(vm, 2, 1);
2171 tp = (time_t) ficlStackPop2Unsigned(vm->dataStack);
2172 fmt = fth_pop_ficl_cell(vm);
2173 FTH_ASSERT_ARGS(FTH_STRING_P(fmt), fmt, FTH_ARG1, "a string");
2174 strftime(vm->pad, sizeof(vm->pad), fth_string_ref(fmt), localtime(&tp));
2175 push_cstring(vm, vm->pad);
2176 }
2177
2178 static void
ficl_strptime(ficlVm * vm)2179 ficl_strptime(ficlVm *vm)
2180 {
2181 #define h_strptime "( str fmt -- secs ) parse STR according to FMT\n\
2182 \"2012 01 14\" \"%Y %m %d\" strptime time->string\n\
2183 => \"Sat Jan 14 02:40:28 CET 2012\"\n\
2184 Parse STR according to FMT and return TIME as ficl2Unsigned.\n\
2185 See strptime(3) for more information.\n\
2186 See also strftime, time->string and current-time."
2187 FTH fmt, str;
2188 time_t tp;
2189 struct tm *tm;
2190
2191 FTH_STACK_CHECK(vm, 2, 1);
2192 fmt = fth_pop_ficl_cell(vm);
2193 str = fth_pop_ficl_cell(vm);
2194 FTH_ASSERT_ARGS(FTH_STRING_P(str), str, FTH_ARG1, "a string");
2195 FTH_ASSERT_ARGS(FTH_STRING_P(fmt), fmt, FTH_ARG2, "a string");
2196 tp = time(NULL);
2197 tm = gmtime(&tp);
2198 #if defined(HAVE_STRPTIME)
2199 if (strptime(fth_string_ref(str), fth_string_ref(fmt), tm) == NULL)
2200 FTH_SYSTEM_ERROR_ARG_THROW(strptime, fth_string_ref(str));
2201 #endif
2202 ficlStackPush2Unsigned(vm->dataStack, (ficl2Unsigned) mktime(tm));
2203 }
2204
2205 static void
ficl_localtime(ficlVm * vm)2206 ficl_localtime(ficlVm *vm)
2207 {
2208 #define h_localtime "( secs -- ary ) return SECS as local time array\n\
2209 current-time localtime => #( 28 40 2 14 0 112 6 13 #f 3600 \"CET\" )\n\
2210 Return array of eleven elements with SECS converted to local time:\n\
2211 sec -- seconds after minute [0-60]\n\
2212 min -- minutes after the hour [0-59]\n\
2213 hour -- hours since midnight [0-23]\n\
2214 mday -- day of the month [1-31]\n\
2215 mon -- months since January [0-11]\n\
2216 year -- years since 1900\n\
2217 wday -- days since Sunday [0-6]\n\
2218 yday -- days since January 1 [0-365]\n\
2219 isdst -- Daylight Savings Time flag\n\
2220 tm_gmtoff -- offset from UTC in seconds\n\
2221 tm_zone -- timezone abbreviation\n\
2222 See localtime(3) for more information.\n\
2223 See also gmtime, mktime, strftime, strptime, time->string and current-time."
2224 FTH array;
2225 time_t tp;
2226 struct tm *tm;
2227
2228 FTH_STACK_CHECK(vm, 1, 1);
2229 tp = (time_t) ficlStackPop2Unsigned(vm->dataStack);
2230 tm = localtime(&tp);
2231 array = fth_make_array_var(11,
2232 INT_TO_FIX(tm->tm_sec), /* seconds after minute [0-60] */
2233 INT_TO_FIX(tm->tm_min), /* minutes after the hour [0-59] */
2234 INT_TO_FIX(tm->tm_hour), /* hours since midnight [0-23] */
2235 INT_TO_FIX(tm->tm_mday), /* day of the month [1-31] */
2236 INT_TO_FIX(tm->tm_mon), /* months since January [0-11] */
2237 INT_TO_FIX(tm->tm_year), /* years since 1900 */
2238 INT_TO_FIX(tm->tm_wday), /* days since Sunday [0-6] */
2239 INT_TO_FIX(tm->tm_yday), /* days since January 1 [0-365] */
2240 BOOL_TO_FTH(tm->tm_isdst), /* Daylight Savings Time flag */
2241 #if defined(HAVE_STRUCT_TM_TM_GMTOFF)
2242 /* offset from UTC in seconds */
2243 fth_make_long_long((ficl2Integer) tm->tm_gmtoff),
2244 #else
2245 FTH_FALSE,
2246 #endif
2247 #if defined(HAVE_STRUCT_TM_TM_ZONE)
2248 fth_make_string(tm->tm_zone)
2249 #else
2250 FTH_FALSE
2251 #endif
2252 ); /* timezone abbreviation */
2253 ficlStackPushFTH(vm->dataStack, array);
2254 }
2255
2256 static void
ficl_gmtime(ficlVm * vm)2257 ficl_gmtime(ficlVm *vm)
2258 {
2259 #define h_gmtime "( secs -- ary ) return TIME as an array in GMT\n\
2260 current-time gmtime => #( 28 40 1 14 0 112 6 13 #f 0 \"UTC\" )\n\
2261 Return array of eleven elements with SECS converted to Greenwich Mean Time:\n\
2262 sec -- seconds after minute [0-60]\n\
2263 min -- minutes after the hour [0-59]\n\
2264 hour -- hours since midnight [0-23]\n\
2265 mday -- day of the month [1-31]\n\
2266 mon -- months since January [0-11]\n\
2267 year -- years since 1900\n\
2268 wday -- days since Sunday [0-6]\n\
2269 yday -- days since January 1 [0-365]\n\
2270 isdst -- Daylight Savings Time flag\n\
2271 tm_gmtoff -- offset from UTC in seconds\n\
2272 tm_zone -- timezone abbreviation\n\
2273 See gmtime(3) for more information.\n\
2274 See also localtime, mktime, strftime, strptime, time->string and current-time."
2275 FTH array;
2276 time_t tp;
2277 struct tm *tm;
2278
2279 FTH_STACK_CHECK(vm, 1, 1);
2280 tp = (time_t) ficlStackPop2Unsigned(vm->dataStack);
2281 tm = gmtime(&tp);
2282 array = fth_make_array_var(11,
2283 INT_TO_FIX(tm->tm_sec), /* seconds after minute [0-60] */
2284 INT_TO_FIX(tm->tm_min), /* minutes after the hour [0-59] */
2285 INT_TO_FIX(tm->tm_hour), /* hours since midnight [0-23] */
2286 INT_TO_FIX(tm->tm_mday), /* day of the month [1-31] */
2287 INT_TO_FIX(tm->tm_mon), /* months since January [0-11] */
2288 INT_TO_FIX(tm->tm_year), /* years since 1900 */
2289 INT_TO_FIX(tm->tm_wday), /* days since Sunday [0-6] */
2290 INT_TO_FIX(tm->tm_yday), /* days since January 1 [0-365] */
2291 BOOL_TO_FTH(tm->tm_isdst), /* Daylight Savings Time flag */
2292 #if defined(HAVE_STRUCT_TM_TM_GMTOFF)
2293 /* offset from UTC in seconds */
2294 fth_make_long_long((ficl2Integer) tm->tm_gmtoff),
2295 #else
2296 FTH_FALSE,
2297 #endif
2298 #if defined(HAVE_STRUCT_TM_TM_ZONE)
2299 fth_make_string(tm->tm_zone) /* timezone abbreviation */
2300 #else
2301 FTH_FALSE
2302 #endif
2303 );
2304 ficlStackPushFTH(vm->dataStack, array);
2305 }
2306
2307 enum {
2308 TM_SEC,
2309 TM_MIN,
2310 TM_HOUR,
2311 TM_MDAY,
2312 TM_MON,
2313 TM_YEAR,
2314 TM_WDAY,
2315 TM_YDAY,
2316 TM_ISDST,
2317 TM_GMTOFF,
2318 TM_ZONE
2319 };
2320
2321 static void
ficl_mktime(ficlVm * vm)2322 ficl_mktime(ficlVm *vm)
2323 {
2324 #define h_mktime "( ary -- secs ) return time in seconds\n\
2325 #( 28 40 2 14 0 112 6 13 #f 3600 \"CET\" ) mktime => 1326505228\n\
2326 Return time constructed from values of ARY. \
2327 ARY may be #f or an array of up to eleven elements \
2328 where single elements may be #f.\n\
2329 sec -- seconds after minute [0-60]\n\
2330 min -- minutes after the hour [0-59]\n\
2331 hour -- hours since midnight [0-23]\n\
2332 mday -- day of the month [1-31]\n\
2333 mon -- months since January [0-11]\n\
2334 year -- years since 1900\n\
2335 wday -- days since Sunday [0-6]\n\
2336 yday -- days since January 1 [0-365]\n\
2337 isdst -- Daylight Savings Time flag\n\
2338 tm_gmtoff -- offset from UTC in seconds\n\
2339 tm_zone -- timezone abbreviation\n\
2340 See mktime(3) for more information.\n\
2341 See also localtime, gmtime, strftime, strptime, \
2342 time->string and current-time."
2343 FTH array, el;
2344 ficlInteger len;
2345 struct tm tm;
2346
2347 FTH_STACK_CHECK(vm, 1, 1);
2348 array = fth_pop_ficl_cell(vm);
2349 len = fth_array_length(array);
2350 if (len > TM_SEC) {
2351 el = fth_array_fast_ref(array, (ficlInteger) TM_SEC);
2352
2353 if (FTH_NOT_FALSE_P(el))
2354 tm.tm_sec = FIX_TO_INT32(el);
2355 }
2356 if (len > TM_MIN) {
2357 el = fth_array_fast_ref(array, (ficlInteger) TM_MIN);
2358
2359 if (FTH_NOT_FALSE_P(el))
2360 tm.tm_min = FIX_TO_INT32(el);
2361 }
2362 if (len > TM_HOUR) {
2363 el = fth_array_fast_ref(array, (ficlInteger) TM_HOUR);
2364
2365 if (FTH_NOT_FALSE_P(el))
2366 tm.tm_hour = FIX_TO_INT32(el);
2367 }
2368 if (len > TM_MDAY) {
2369 el = fth_array_fast_ref(array, (ficlInteger) TM_MDAY);
2370
2371 if (FTH_NOT_FALSE_P(el))
2372 tm.tm_mday = FIX_TO_INT32(el);
2373 }
2374 if (len > TM_MON) {
2375 el = fth_array_fast_ref(array, (ficlInteger) TM_MON);
2376
2377 if (FTH_NOT_FALSE_P(el))
2378 tm.tm_mon = FIX_TO_INT32(el);
2379 }
2380 if (len > TM_YEAR) {
2381 el = fth_array_fast_ref(array, (ficlInteger) TM_YEAR);
2382
2383 if (FTH_NOT_FALSE_P(el))
2384 tm.tm_year = FIX_TO_INT32(el);
2385 }
2386 if (len > TM_WDAY) {
2387 el = fth_array_fast_ref(array, (ficlInteger) TM_WDAY);
2388
2389 if (FTH_NOT_FALSE_P(el))
2390 tm.tm_wday = FIX_TO_INT32(el);
2391 }
2392 if (len > TM_YDAY) {
2393 el = fth_array_fast_ref(array, (ficlInteger) TM_YDAY);
2394
2395 if (FTH_NOT_FALSE_P(el))
2396 tm.tm_yday = FIX_TO_INT32(el);
2397 }
2398 if (len > TM_ISDST) {
2399 el = fth_array_fast_ref(array, (ficlInteger) TM_ISDST);
2400 tm.tm_isdst = FTH_TO_BOOL(el);
2401 }
2402 #if defined(HAVE_STRUCT_TM_TM_GMTOFF)
2403 if (len > TM_GMTOFF) {
2404 el = fth_array_fast_ref(array, (ficlInteger) TM_GMTOFF);
2405
2406 if (FTH_NOT_FALSE_P(el))
2407 tm.tm_gmtoff = (long) fth_long_long_ref(el);
2408 }
2409 #endif
2410 #if defined(HAVE_STRUCT_TM_TM_ZONE)
2411 if (len > TM_ZONE) {
2412 el = fth_array_fast_ref(array, (ficlInteger) TM_ZONE);
2413
2414 if (FTH_NOT_FALSE_P(el))
2415 tm.tm_zone = fth_string_ref(el);
2416 }
2417 #endif
2418 ficlStackPush2Unsigned(vm->dataStack, (ficl2Unsigned) mktime(&tm));
2419 }
2420
2421 static void
ficl_getenv(ficlVm * vm)2422 ficl_getenv(ficlVm *vm)
2423 {
2424 #define h_getenv "( name -- value|#f ) return environment variable\n\
2425 \"HOME\" getenv => /home/mike\n\
2426 Return content of shell environment variable NAME as string \
2427 or #f if variable is not defined.\n\
2428 See getenv(3) for more information.\n\
2429 See also putenv and environ."
2430 char *val = NULL;
2431
2432 FTH_STACK_CHECK(vm, 1, 1);
2433 val = fth_getenv(pop_cstring(vm), NULL);
2434
2435 if (val != NULL)
2436 push_cstring(vm, val);
2437 else
2438 ficlStackPushBoolean(vm->dataStack, 0);
2439 }
2440
2441 static void
ficl_putenv(ficlVm * vm)2442 ficl_putenv(ficlVm *vm)
2443 {
2444 #define h_putenv "( name value -- ) set environment variable\n\
2445 \"my_var\" 10 putenv\n\
2446 \"my_var\" getenv => 10\n\
2447 Set VALUE to shell environment variable NAME.\n\
2448 See putenv(3) for more information.\n\
2449 See also getenv and environ."
2450 char *name, *val;
2451
2452 FTH_STACK_CHECK(vm, 2, 0);
2453 val = fth_to_c_string(fth_pop_ficl_cell(vm));
2454 name = pop_cstring(vm);
2455 #if defined(HAVE_SETENV)
2456 setenv(name, val, 1);
2457 #endif
2458 }
2459
2460 extern char **environ;
2461
2462 static void
ficl_environ(ficlVm * vm)2463 ficl_environ(ficlVm *vm)
2464 {
2465 #define h_environ "( -- ary ) return environment variables\n\
2466 environ => #{ \"HOME\" => \"/home/mike\" ... }\n\
2467 Return hash of all shell environment variables and their values.\n\
2468 See also getenv and putenv."
2469 char **env;
2470 FTH vals;
2471 ficlInteger sep;
2472
2473 env = environ;
2474 vals = fth_make_hash();
2475
2476 for (; *env; env++) {
2477 sep = strchr(*env, '=') - *env;
2478 fth_hash_set(vals,
2479 fth_make_string_len(*env, sep),
2480 fth_make_string(*env + sep + 1));
2481 }
2482
2483 ficlStackPushFTH(vm->dataStack, vals);
2484 }
2485
2486 static void
ficl_getpid(ficlVm * vm)2487 ficl_getpid(ficlVm *vm)
2488 {
2489 #define h_getpid "( -- id ) return PID\n\
2490 getpid => 49507\n\
2491 Return process id.\n\
2492 See getpid(2) for more information.\n\
2493 See also getppid."
2494 FTH_STACK_CHECK(vm, 0, 1);
2495 #if defined(HAVE_GETPID)
2496 ficlStackPushInteger(vm->dataStack, (ficlInteger) getpid());
2497 #else
2498 ficlStackPushInteger(vm->dataStack, -1);
2499 #endif
2500 }
2501
2502 static void
ficl_getppid(ficlVm * vm)2503 ficl_getppid(ficlVm *vm)
2504 {
2505 #define h_getppid "( -- id ) return parent PID\n\
2506 getppid => 49056\n\
2507 Return parent process id.\n\
2508 See getppid(2) for more information.\n\
2509 See also getpid."
2510 FTH_STACK_CHECK(vm, 0, 1);
2511 #if defined(HAVE_GETPPID)
2512 ficlStackPushInteger(vm->dataStack, (ficlInteger) getppid());
2513 #else
2514 ficlStackPushInteger(vm->dataStack, -1);
2515 #endif
2516 }
2517
2518 static void
ficl_getuid(ficlVm * vm)2519 ficl_getuid(ficlVm *vm)
2520 {
2521 #define h_getuid "( -- id ) return UID\n\
2522 getuid => 1001\n\
2523 Return real user id of calling process.\n\
2524 See getuid(2) for more information.\n\
2525 See also geteuid, getgid and getegid."
2526 FTH_STACK_CHECK(vm, 0, 1);
2527 #if defined(HAVE_GETUID)
2528 ficlStackPushInteger(vm->dataStack, (ficlInteger) getuid());
2529 #else
2530 ficlStackPushInteger(vm->dataStack, -1);
2531 #endif
2532 }
2533
2534 static void
ficl_geteuid(ficlVm * vm)2535 ficl_geteuid(ficlVm *vm)
2536 {
2537 #define h_geteuid "( -- id ) return effective UID\n\
2538 geteuid => 1001\n\
2539 Return effective user id of calling process.\n\
2540 See geteuid(2) for more information.\n\
2541 See also getuid, getgid and getegid."
2542 #if defined(HAVE_GETEUID)
2543 FTH_STACK_CHECK(vm, 0, 1);
2544 ficlStackPushInteger(vm->dataStack, (ficlInteger) geteuid());
2545 #else
2546 ficlStackPushInteger(vm->dataStack, -1);
2547 #endif
2548 }
2549
2550 static void
ficl_getgid(ficlVm * vm)2551 ficl_getgid(ficlVm *vm)
2552 {
2553 #define h_getgid "( -- id ) return GID\n\
2554 getgid => 1001\n\
2555 Return real group id of calling process.\n\
2556 See getgid(2) for more information.\n\
2557 See also getegid, getuid and geteuid."
2558 FTH_STACK_CHECK(vm, 0, 1);
2559 #if defined(HAVE_GETGID)
2560 ficlStackPushInteger(vm->dataStack, (ficlInteger) getgid());
2561 #else
2562 ficlStackPushInteger(vm->dataStack, -1);
2563 #endif
2564 }
2565
2566 static void
ficl_getegid(ficlVm * vm)2567 ficl_getegid(ficlVm *vm)
2568 {
2569 #define h_getegid "( -- id ) return effective GUI\n\
2570 getegid => 1001\n\
2571 Return effective group id of calling process.\n\
2572 See getegid(2) for more information.\n\
2573 See also getgid, getuid and geteuid."
2574 FTH_STACK_CHECK(vm, 0, 1);
2575 #if defined(HAVE_GETEGID)
2576 ficlStackPushInteger(vm->dataStack, (ficlInteger) getegid());
2577 #else
2578 ficlStackPushInteger(vm->dataStack, -1);
2579 #endif
2580 }
2581
2582 #if defined(HAVE_SETUID)
2583 static void
ficl_setuid(ficlVm * vm)2584 ficl_setuid(ficlVm *vm)
2585 {
2586 #define h_setuid "( id -- ) set UID\n\
2587 1001 setuid\n\
2588 Set real user ID. \
2589 This is only permitted if ID is equal real UID \
2590 or effective UID \
2591 or the effective UID is that of the super user.\n\
2592 See setuid(2) for more information.\n\
2593 See also seteuid, setgid and setegid."
2594 FTH_STACK_CHECK(vm, 1, 0);
2595
2596 if (setuid((uid_t) ficlStackPopInteger(vm->dataStack)) == -1)
2597 FTH_SYSTEM_ERROR_THROW(setuid);
2598 }
2599 #endif
2600
2601 #if defined(HAVE_SETEUID)
2602 static void
ficl_seteuid(ficlVm * vm)2603 ficl_seteuid(ficlVm *vm)
2604 {
2605 #define h_seteuid "( id -- ) set effective UID\n\
2606 1001 seteuid\n\
2607 Set effective user ID. \
2608 This is only permitted if ID is equal real UID \
2609 or effective UID \
2610 or the effective UID is that of the super user.\n\
2611 See seteuid(2) for more information.\n\
2612 See also setuid, setgid and setegid."
2613 FTH_STACK_CHECK(vm, 1, 0);
2614
2615 if (seteuid((uid_t) ficlStackPopInteger(vm->dataStack)) == -1)
2616 FTH_SYSTEM_ERROR_THROW(seteuid);
2617 }
2618 #endif
2619
2620 #if defined(HAVE_SETGID)
2621 static void
ficl_setgid(ficlVm * vm)2622 ficl_setgid(ficlVm *vm)
2623 {
2624 #define h_setgid "( id -- ) set GID\n\
2625 1001 setgid\n\
2626 Set real group ID. \
2627 This is only permitted if ID is equal real GID \
2628 or effective GID \
2629 or the effective UID is that of the super user.\n\
2630 See setgid(2) for more information.\n\
2631 See also setegid, setuid and seteuid."
2632 FTH_STACK_CHECK(vm, 1, 0);
2633
2634 if (setgid((gid_t) ficlStackPopInteger(vm->dataStack)) == -1)
2635 FTH_SYSTEM_ERROR_THROW(setgid);
2636 }
2637 #endif
2638
2639 #if defined(HAVE_SETEGID)
2640 static void
ficl_setegid(ficlVm * vm)2641 ficl_setegid(ficlVm *vm)
2642 {
2643 #define h_setegid "( id -- ) set effective GID\n\
2644 1001 setegid\n\
2645 Set effective group ID. \
2646 This is only permitted if ID is equal real GID \
2647 or effective GID \
2648 or the effective UID is that of the super user.\n\
2649 See setegid(2) for more information.\n\
2650 See also setgid, setuid and seteuid."
2651 FTH_STACK_CHECK(vm, 1, 0);
2652
2653 if (setegid((gid_t) ficlStackPopInteger(vm->dataStack)) == -1)
2654 FTH_SYSTEM_ERROR_THROW(setegid);
2655 }
2656 #endif
2657
2658 #define FTH_SIGNAL_HANDLER fth_symbol("signal-handler")
2659
2660 static ficlWord *sig_to_xt[40];
2661
2662 static void
handler_exec(int sig)2663 handler_exec(int sig)
2664 {
2665 ficlStackPushInteger(FTH_FICL_STACK(), (ficlInteger) sig);
2666 fth_execute_xt(FTH_FICL_VM(), sig_to_xt[sig]);
2667 }
2668
2669 /*-
2670 * old-handler ( sig -- )
2671 * A preserved old handler is wrapped in that XT.
2672 */
2673 static void
ficl_signal_handler(ficlVm * vm)2674 ficl_signal_handler(ficlVm *vm)
2675 {
2676 int sig;
2677 sig_t func;
2678
2679 FTH_STACK_CHECK(vm, 1, 0);
2680 sig = (int) ficlStackPopInteger(vm->dataStack);
2681 func = (sig_t) fth_word_property_ref((FTH) vm->runningWord,
2682 FTH_SIGNAL_HANDLER);
2683
2684 if (func && func != SIG_DFL && func != SIG_IGN && func != SIG_ERR)
2685 (*func) (sig);
2686 }
2687
2688 static void
ficl_signal(ficlVm * vm)2689 ficl_signal(ficlVm *vm)
2690 {
2691 #define h_signal "( sig xt -- old-xt ) install signal handler\n\
2692 SIGINT lambda: { sig -- }\n\
2693 .\" SIGINT received\" cr\n\
2694 ; signal value old-xt\n\
2695 \\ later on you can reset signal to the previous handler:\n\
2696 SIGINT old-xt signal drop\n\
2697 Install XT for signal SIG as an signal handler and return old handler. \
2698 XT must take one value from the stack, the signal, \
2699 and must not return any value; \
2700 its stack effect is ( sig -- ). \
2701 The old xt handler can be preserved for later use.\n\
2702 See signal(3) for more information."
2703 int sig;
2704 sig_t func;
2705 ficlWord *xt1, *xt2;
2706
2707 FTH_STACK_CHECK(vm, 2, 1);
2708 xt1 = ficlStackPopPointer(vm->dataStack);
2709 sig = (int) ficlStackPopInteger(vm->dataStack);
2710 sig_to_xt[sig] = xt1;
2711
2712 if (xt1 == (ficlWord *) SIG_DFL ||
2713 xt1 == (ficlWord *) SIG_IGN ||
2714 xt1 == (ficlWord *) SIG_ERR)
2715 func = signal(sig, (sig_t) xt1);
2716 else
2717 func = signal(sig, handler_exec);
2718
2719 /* If something went wrong, signal returns SIG_ERR and sets errno. */
2720 if (func == SIG_ERR && errno != 0)
2721 FTH_SYSTEM_ERROR_THROW(signal);
2722
2723 /* preserves old handler in xt2 */
2724 xt2 = FTH_PRI1("", ficl_signal_handler, NULL);
2725 fth_word_property_set((FTH) xt2, FTH_SIGNAL_HANDLER, (FTH) func);
2726 ficlStackPushPointer(vm->dataStack, xt2);
2727 }
2728
2729 #if defined(HAVE_KILL)
2730 static void
ficl_kill(ficlVm * vm)2731 ficl_kill(ficlVm *vm)
2732 {
2733 #define h_kill "( pid sig -- ) send SIGnal to PID\n\
2734 1234 SIGKILL kill\n\
2735 0 SIGUSR1 kill\n\
2736 Send signal SIG to process ID PID. \
2737 If PID is zero, send SIG to current process. \
2738 SIG is a number or a constant like SIGKILL.\n\
2739 See kill(2) for more information."
2740 pid_t pid;
2741 int sig;
2742
2743 FTH_STACK_CHECK(vm, 2, 0);
2744 sig = (int) ficlStackPopInteger(vm->dataStack);
2745 pid = (pid_t) ficlStackPopInteger(vm->dataStack);
2746
2747 if (kill(pid, sig) == -1)
2748 FTH_SYSTEM_ERROR_THROW(kill);
2749 }
2750 #endif
2751
2752 static void
ficl_wait(ficlVm * vm)2753 ficl_wait(ficlVm *vm)
2754 {
2755 #define h_wait "( -- pid ) wait for child\n\
2756 wait => 1234\n\
2757 Wait for child process and return its process ID. \
2758 Set global read only variable exit-status to wait status.\n\
2759 See wait(2) for more information."
2760 pid_t pid;
2761 int status;
2762
2763 FTH_STACK_CHECK(vm, 0, 1);
2764 status = 0;
2765 #if defined(HAVE_WAIT)
2766 pid = wait(&status);
2767
2768 if (pid == -1)
2769 FTH_SYSTEM_ERROR_THROW(wait);
2770 #else
2771 pid = 0;
2772 #endif
2773 fth_set_exit_status(status);
2774 ficlStackPushInteger(vm->dataStack, (ficlInteger) pid);
2775 }
2776
2777 static void
ficl_waitpid(ficlVm * vm)2778 ficl_waitpid(ficlVm *vm)
2779 {
2780 #define h_waitpid "( pid flags -- ) wait for specified child\n\
2781 1234 0 waitpid\n\
2782 1234 WNOHANG waitpid\n\
2783 1234 WNOHANG WUNTRACED or waitpid\n\
2784 Wait for child process PID. \
2785 Set global read only variable exit-status to wait status. \
2786 FLAGS may be 0, or WNOHANG and WUNTRACED ored.\n\
2787 See waitpid(2) for more information."
2788 pid_t pid;
2789 int status = 0, flags;
2790
2791 FTH_STACK_CHECK(vm, 2, 0);
2792 flags = (int) ficlStackPopInteger(vm->dataStack);
2793 pid = (pid_t) ficlStackPopInteger(vm->dataStack);
2794 #if defined(HAVE_WAITPID)
2795 if (waitpid(pid, &status, flags) == -1)
2796 FTH_SYSTEM_ERROR_THROW(waitpid);
2797 #endif
2798 fth_set_exit_status(status);
2799 }
2800
2801 #if defined(HAVE_FORK)
2802 static void
ficl_fork(ficlVm * vm)2803 ficl_fork(ficlVm *vm)
2804 {
2805 #define h_fork "( xt -- pid ) execute XT in a child process\n\
2806 lambda: <{}> \"ls -lAF\" exec ; fork value pid\n\
2807 pid SIGKILL kill\n\
2808 Create child process and execute XT in the child. \
2809 The child process returns nothing, parent returns child's process ID.\n\
2810 See fork(2) for more information.\n\
2811 See also exec."
2812 pid_t pid;
2813 FTH proc_or_xt, proc;
2814
2815 FTH_STACK_CHECK(vm, 1, 1);
2816 proc_or_xt = fth_pop_ficl_cell(vm);
2817 proc = proc_from_proc_or_xt(proc_or_xt, 0, 0, 0);
2818 FTH_ASSERT_ARGS(FTH_PROC_P(proc), proc, FTH_ARG1, "a proc");
2819 pid = fork();
2820
2821 if (pid == -1)
2822 FTH_SYSTEM_ERROR_THROW(fork);
2823
2824 if (pid == 0) /* child */
2825 fth_proc_call(proc, RUNNING_WORD_VM(vm), 0);
2826 else /* parent */
2827 ficlStackPushInteger(vm->dataStack, (ficlInteger) pid);
2828 }
2829 #endif
2830
2831 #if defined(HAVE_EXECLP) && defined(HAVE_EXECVP)
2832 static void
ficl_exec(ficlVm * vm)2833 ficl_exec(ficlVm *vm)
2834 {
2835 #define h_exec "( cmd -- ) replace current process by CMD\n\
2836 lambda: <{}> #( \"ls\" \"-lAF\" ) exec ; fork\n\
2837 lambda: <{}> \"ls -lAF [A-Z]*\" exec ; fork\n\
2838 Replace current process by running CMD as shell command. \
2839 If CMD is a string, shell expansion takes place and $SHELL--\
2840 or \"sh\" if $SHELL is empty--executes CMD. \
2841 If CMD is an array of strings, no shell expansion takes place \
2842 and \"CMD 0 array-ref\" should be a program name.\n\
2843 See exec(3) for more information.\n\
2844 See also fork."
2845 FTH cmd;
2846 char *prog;
2847
2848 FTH_STACK_CHECK(vm, 1, 0);
2849 cmd = fth_pop_ficl_cell(vm);
2850 FTH_ASSERT_ARGS(FTH_STRING_P(cmd) || FTH_ARRAY_P(cmd),
2851 cmd, FTH_ARG1, "a string or an array of strings");
2852
2853 /* cmd == string: execute shell expansion */
2854 if (FTH_STRING_P(cmd)) {
2855 char *shell;
2856
2857 prog = fth_string_ref(cmd);
2858 shell = fth_getenv("SHELL", "sh");
2859
2860 if (execlp(shell, shell, "-c", prog, NULL) == -1)
2861 FTH_SYSTEM_ERROR_ARG_THROW(execlp, prog);
2862 } else {
2863 ficlInteger argc;
2864
2865 argc = fth_array_length(cmd);
2866
2867 if (argc > 0) {
2868 ficlInteger i;
2869 int status;
2870 char **argv;
2871
2872 prog = fth_string_ref(fth_array_fast_ref(cmd, 0L));
2873 argv = FTH_MALLOC(sizeof(char *) * (size_t) (argc + 1));
2874
2875 for (i = 0; i < argc; i++)
2876 argv[i] =
2877 fth_string_ref(fth_array_fast_ref(cmd, i));
2878
2879 argv[i] = NULL;
2880 status = execvp(prog, argv);
2881 FTH_FREE(argv);
2882
2883 if (status == -1)
2884 FTH_SYSTEM_ERROR_ARG_THROW(execvp, prog);
2885 }
2886 }
2887 }
2888 #endif
2889
2890 static void
ficl_getlogin(ficlVm * vm)2891 ficl_getlogin(ficlVm *vm)
2892 {
2893 #define h_getlogin "( -- str ) return login name\n\
2894 getlogin => \"mike\"\n\
2895 Return name of user associated with current session.\n\
2896 See getlogin(2) for more information."
2897 char *name;
2898
2899 FTH_STACK_CHECK(vm, 0, 1);
2900 errno = 0;
2901 #if defined(HAVE_GETLOGIN)
2902 name = getlogin();
2903 if (name == NULL)
2904 #endif
2905 name = fth_getenv("LOGNAME", "anonymous");
2906 push_cstring(vm, name);
2907 }
2908
2909 static void
ficl_gethostname(ficlVm * vm)2910 ficl_gethostname(ficlVm *vm)
2911 {
2912 #define h_gethostname "( -- str ) return host name\n\
2913 gethostname => \"pumpkin.fth-devel.net\"\n\
2914 Return name of current host.\n\
2915 See gethostname(3) for more information."
2916 #if defined(HAVE_GETHOSTNAME)
2917 FTH_STACK_CHECK(vm, 0, 1);
2918
2919 if (gethostname(vm->pad, (size_t) FICL_PAD_SIZE) == -1)
2920 FTH_SYSTEM_ERROR_THROW(gethostname);
2921 push_cstring(vm, vm->pad);
2922 #else
2923 push_cstring(vm, "localhost");
2924 #endif
2925 }
2926
2927 static void
ficl_sethostname(ficlVm * vm)2928 ficl_sethostname(ficlVm *vm)
2929 {
2930 #define h_sethostname "( str -- ) set host name\n\
2931 \"pumpkin.fth-devel.net\" sethostname\n\
2932 Set name of current host to STR. \
2933 This call is restricted to the super-user. \
2934 Raise NOT-IMPLEMENTED exception if sethostname(3) is not available.\n\
2935 See sethostname(3) for more information."
2936 char *name;
2937
2938 FTH_STACK_CHECK(vm, 1, 0);
2939 name = pop_cstring(vm);
2940 #if defined(HAVE_SETHOSTNAME)
2941 #if defined(__FreeBSD__)
2942 /* int sethostname(const char *, int) */
2943 if (sethostname(name, (int) fth_strlen(name)) == -1)
2944 #else
2945 /* int sethostname(const char *, size_t) */
2946 if (sethostname(name, fth_strlen(name)) == -1)
2947 #endif
2948 FTH_SYSTEM_ERROR_ARG_THROW(sethostname, name);
2949 #else
2950 FTH_NOT_IMPLEMENTED_ERROR(sethostname);
2951 #endif
2952 }
2953
2954 #if defined(HAVE_NETDB_H)
2955 #include <netdb.h>
2956 #endif
2957
2958 static void
ficl_getservbyname(ficlVm * vm)2959 ficl_getservbyname(ficlVm *vm)
2960 {
2961 #define h_getservbyname "( str -- ary ) return service info array\n\
2962 \"smtp\" getservbyname => #( \"smtp\" #( \"mail\" ) 25 \"tcp\" )\n\
2963 Return array containing the service, an array of aliases, \
2964 the port number and the protocol. \
2965 Raise NOT-IMPLEMENTED exception if getservbyname(3) is not available.\n\
2966 See getservbyname(3) for more information."
2967 char *service, **s_aliases;
2968 struct servent *se;
2969 FTH aliases, res;
2970
2971 FTH_STACK_CHECK(vm, 1, 1);
2972 service = pop_cstring(vm);
2973 #if defined(HAVE_GETSERVBYNAME)
2974 se = getservbyname(service, NULL);
2975
2976 if (se == NULL) {
2977 if (errno != 0) {
2978 FTH_SYSTEM_ERROR_ARG_THROW(getservbyname, service);
2979 /* NOTREACHED */
2980 return;
2981 }
2982 ficlStackPushBoolean(vm->dataStack, 0);
2983 return;
2984 }
2985 aliases = fth_make_empty_array();
2986 s_aliases = se->s_aliases;
2987
2988 while (*s_aliases)
2989 fth_array_push(aliases, fth_make_string(*s_aliases++));
2990
2991 res = FTH_LIST_4(fth_make_string(se->s_name),
2992 aliases,
2993 INT_TO_FIX(ntohs((uint16_t) se->s_port)),
2994 fth_make_string(se->s_proto));
2995 ficlStackPushFTH(vm->dataStack, res);
2996 #else
2997 FTH_NOT_IMPLEMENTED_ERROR(getservbyname);
2998 #endif
2999 }
3000
3001 static void
ficl_getservbyport(ficlVm * vm)3002 ficl_getservbyport(ficlVm *vm)
3003 {
3004 #define h_getservbyport "( port -- ary ) return service info array\n\
3005 25 getservbyport => #( \"smtp\" #( \"mail\" ) 25 \"tcp\" )\n\
3006 Return array containing the service, an array of aliases, \
3007 the port number and the protocol. \
3008 Raise NOT-IMPLEMENTED exception if getservbyport(3) is not available.\n\
3009 See getservbyport(3) for more information."
3010 uint16_t port;
3011 struct servent *se;
3012 FTH aliases, res;
3013 char **s_aliases;
3014
3015 FTH_STACK_CHECK(vm, 1, 1);
3016 port = (uint16_t) ficlStackPopInteger(vm->dataStack);
3017 #if defined(HAVE_GETSERVBYPORT)
3018 se = getservbyport((int) htons(port), NULL);
3019
3020 if (se == NULL) {
3021 if (errno != 0) {
3022 FTH_SYSTEM_ERROR_THROW(getservbyport);
3023 /* NOTREACHED */
3024 return;
3025 }
3026 ficlStackPushBoolean(vm->dataStack, 0);
3027 return;
3028 }
3029 aliases = fth_make_empty_array();
3030 s_aliases = se->s_aliases;
3031
3032 while (*s_aliases)
3033 fth_array_push(aliases, fth_make_string(*s_aliases++));
3034
3035 res = FTH_LIST_4(fth_make_string(se->s_name),
3036 aliases,
3037 INT_TO_FIX(ntohs((uint16_t) se->s_port)),
3038 fth_make_string(se->s_proto));
3039 ficlStackPushFTH(vm->dataStack, res);
3040 #else
3041 FTH_NOT_IMPLEMENTED_ERROR(getservbyport);
3042 #endif
3043 }
3044
3045 static void
ficl_date(ficlVm * vm)3046 ficl_date(ficlVm *vm)
3047 {
3048 #define h_date "( -- str ) return date as string\n\
3049 date => Mon Nov 21 04:34:07 CET 2005\n\
3050 Return date in default Unix/C format as a string."
3051 time_t tp;
3052
3053 FTH_STACK_CHECK(vm, 0, 1);
3054 time(&tp);
3055 strftime(vm->pad, (size_t) FICL_PAD_SIZE,
3056 "%a %b %d %H:%M:%S %Z %Y", localtime(&tp));
3057 push_cstring(vm, vm->pad);
3058 }
3059
3060 #if defined(HAVE_SLEEP)
3061 static void
ficl_sleep(ficlVm * vm)3062 ficl_sleep(ficlVm *vm)
3063 {
3064 #define h_sleep "( secs -- ) wait for SECS seconds\n\
3065 3 sleep\n\
3066 Pause for SECS seconds.\n\
3067 See sleep(3) for more information."
3068 FTH_STACK_CHECK(vm, 1, 0);
3069 sleep((unsigned) ficlStackPopUnsigned(vm->dataStack));
3070 }
3071 #endif
3072
3073 /* === GETOPT === */
3074
3075 #include <getopt.h>
3076
3077 /*
3078 * external variables (unistd.h) for getopt(3)
3079 */
3080 extern char *optarg;
3081 extern int opterr;
3082 extern int optind;
3083 extern int optopt;
3084
3085 #define h_opterr "\
3086 If #t, the default, getopt print error message in case of an error, \
3087 if #f, no message will be printed. \
3088 See getopt(3) for more information."
3089
3090 #define h_optopt "\
3091 If getopt finds unknown options or getopt misses required arguments, \
3092 it stores that option in this variable. \
3093 See getopt(3) for more information."
3094
3095 #define h_optind "\
3096 Getopt set this variable to the index of the next \
3097 element of the *argv* array. \
3098 See getopt(3) for more information."
3099
3100 #define h_optarg "\
3101 Getopt set this variable to the option string of \
3102 an argument which accepts options, \
3103 otherwise to #f. \
3104 See getopt(3) for more information."
3105
3106 #define GETOPT_MAX_ARGS 24
3107
3108 static void
ficl_getopt(ficlVm * vm)3109 ficl_getopt(ficlVm *vm)
3110 {
3111 #define h_getopt "( argv opt-str -- c ) command line options\n\
3112 % cat ./getopt-test.fth\n\
3113 #! /usr/local/bin/fth -s\n\
3114 : main\n\
3115 #f #f { bflag ffile }\n\
3116 #t to opterr \\ getopt prints error messages\n\
3117 begin\n\
3118 *argv* \"bf:\" getopt ( ch ) dup\n\
3119 while ( ch )\n\
3120 case\n\
3121 <char> b of #t to bflag endof\n\
3122 <char> f of optarg to ffile endof\n\
3123 <char> ? of\n\
3124 $\" usage: [-b] [-f file]\\n\" #() fth-print\n\
3125 1 (bye) \\ exit with return code 1\n\
3126 endof\n\
3127 endcase\n\
3128 repeat ( ch ) drop\n\
3129 optind 0 ?do *argv* array-shift drop loop\n\
3130 *argv* array-length to *argc*\n\
3131 $\" -b: %s, -f: %s\\n\" #( bflag ffile ) fth-print\n\
3132 ;\n\
3133 main\n\
3134 0 (bye) \\ exit with return code 0\n\
3135 % ./getopt-test.fth => -b: #f, -f: #f\n\
3136 % ./getopt-test.fth -b => -b: #t, -f: #f\n\
3137 % ./getopt-test.fth -bf outfile => -b: #t, -f: outfile\n\
3138 % ./getopt-test.fth -f\n\
3139 => fth: option requires an argument -- f\n\
3140 => usage: [-b] [-f file]\n\
3141 % ./getopt-test.fth -h\n\
3142 => fth: illegal option -- h\n\
3143 => usage: [-b] [-f file]\n\
3144 Return next option character from command line options. \
3145 This is the example from getopt(3).\n\
3146 See getopt(3) for more information."
3147 FTH args;
3148 char *options, *argv[GETOPT_MAX_ARGS];
3149 ficlInteger i;
3150 int argc, c;
3151
3152 FTH_STACK_CHECK(vm, 2, 1);
3153 options = pop_cstring(vm);
3154 args = fth_pop_ficl_cell(vm);
3155
3156 /* prepare argv */
3157 argc = (int) fth_array_length(args);
3158 argc = FICL_MIN(GETOPT_MAX_ARGS - 1, argc);
3159
3160 for (i = 0; i < argc; i++)
3161 argv[i] = fth_string_ref(fth_array_fast_ref(args, i));
3162
3163 argv[i] = NULL;
3164 opterr = FTH_NOT_FALSE_P(fth_variable_ref("opterr"));
3165 optind = FIX_TO_INT32(fth_variable_ref("optind"));
3166
3167 if (optind < 1)
3168 optind = 1;
3169
3170 c = getopt(argc, argv, options);
3171
3172 if (c == -1) {
3173 optind = 1; /* reset getopt for further use */
3174 ficlStackPushBoolean(vm->dataStack, 0);
3175 } else {
3176 fth_variable_set("optind", INT_TO_FIX(optind));
3177 fth_variable_set("optopt",
3178 optopt ? INT_TO_FIX(optopt) : FTH_FALSE);
3179 fth_variable_set("optarg",
3180 optarg ? fth_make_string(optarg) : FTH_FALSE);
3181 ficlStackPushInteger(vm->dataStack, (ficlInteger) c);
3182 }
3183 }
3184
3185 static void
ficl_getopt_long(ficlVm * vm)3186 ficl_getopt_long(ficlVm *vm)
3187 {
3188 #define h_getopt_long "( argv opts long-opts -- c ) command line options\n\
3189 : long-test\n\
3190 #f #f { bflag ffile }\n\
3191 #f to opterr\n\
3192 #( #( \"flag\" no-argument <char> b )\n\
3193 #( \"file\" required-argument <char> f ) ) { opts }\n\
3194 begin\n\
3195 *argv* \"bf:\" opts getopt-long ( ch ) dup\n\
3196 while ( ch )\n\
3197 case\n\
3198 <char> b of #t to bflag endof\n\
3199 <char> f of optarg to ffile endof\n\
3200 <char> ? of\n\
3201 \"-%c requires an argument\" #( optopt ) fth-warning\n\
3202 endof\n\
3203 endcase\n\
3204 repeat\n\
3205 drop ( ch )\n\
3206 optind 0 ?do *argv* array-shift drop loop\n\
3207 *argv* array-length to *argc*\n\
3208 \"-b, --flag (default #f): %s\\n\" #( bflag ) fth-print\n\
3209 \"-f, --file (default #f): %s\\n\" #( ffile ) fth-print\n\
3210 ;\n\
3211 Return next option character from command line options. \
3212 The example may show differences and similarities to getopt_long(3).\n\
3213 See getopt_long(3) for more information."
3214 FTH args, long_args;
3215 char *options, *argv[GETOPT_MAX_ARGS];
3216 struct option opts[GETOPT_MAX_ARGS];
3217 int argc, optc, c;
3218 ficlInteger i;
3219
3220 FTH_STACK_CHECK(vm, 3, 1);
3221 long_args = fth_pop_ficl_cell(vm);
3222 options = pop_cstring(vm);
3223 args = fth_pop_ficl_cell(vm);
3224 argc = (int) fth_array_length(args);
3225 argc = FICL_MIN(GETOPT_MAX_ARGS - 1, argc);
3226 optc = (int) fth_array_length(long_args);
3227 optc = FICL_MIN(GETOPT_MAX_ARGS - 1, optc);
3228
3229 /* prepare argv */
3230 for (i = 0; i < argc; i++)
3231 argv[i] = fth_string_ref(fth_array_fast_ref(args, i));
3232
3233 argv[i] = NULL;
3234
3235 /* prepare opts */
3236 for (i = 0; i < optc; i++) {
3237 FTH opt;
3238
3239 opt = fth_array_fast_ref(long_args, i);
3240
3241 if (fth_array_length(opt) == 3) {
3242 opts[i].name =
3243 fth_string_ref(fth_array_fast_ref(opt, 0L));
3244 opts[i].has_arg =
3245 FIX_TO_INT32(fth_array_fast_ref(opt, 1L));
3246 opts[i].flag = NULL;
3247 opts[i].val =
3248 FIX_TO_INT32(fth_array_fast_ref(opt, 2L));
3249 } else
3250 FTH_ASSERT_ARGS(0, opt, FTH_ARG3,
3251 "an array of length 3");
3252 }
3253
3254 opts[i].name = 0;
3255 opts[i].has_arg = 0;
3256 opts[i].flag = 0;
3257 opts[i].val = 0;
3258 opterr = FTH_NOT_FALSE_P(fth_variable_ref("opterr"));
3259 optind = FIX_TO_INT32(fth_variable_ref("optind"));
3260
3261 if (optind < 1)
3262 optind = 1;
3263
3264 c = getopt_long(argc, argv, options, opts, NULL);
3265
3266 if (c == -1) {
3267 optind = 1; /* reset getopt for further use */
3268 ficlStackPushBoolean(vm->dataStack, 0);
3269 } else {
3270 fth_variable_set("optind", INT_TO_FIX(optind));
3271 fth_variable_set("optopt",
3272 optopt ? INT_TO_FIX(optopt) : FTH_FALSE);
3273 fth_variable_set("optarg",
3274 optarg ? fth_make_string(optarg) : FTH_FALSE);
3275 ficlStackPushInteger(vm->dataStack, (ficlInteger) c);
3276 }
3277 }
3278
3279 static void
ficl_show_memory(ficlVm * vm)3280 ficl_show_memory(ficlVm *vm)
3281 {
3282 #define h_show_memory "( -- ) print memory stats\n\
3283 .memory => 398461 cells used, 650115 cells free\n\
3284 Print used and free dictionary cells."
3285 fth_printf("%d cells used, %d cells free",
3286 ficlDictionaryCellsUsed(ficlVmGetDictionary(vm)),
3287 ficlDictionaryCellsAvailable(ficlVmGetDictionary(vm)));
3288 }
3289
3290 char *
fth_version(void)3291 fth_version(void)
3292 {
3293 if (strncmp("unknown", FTH_TARGET_VENDOR, 7L) == 0)
3294 return (FTH_PACKAGE_VERSION
3295 " (" FTH_DATE ") [" FTH_TARGET_CPU "-" FTH_TARGET_OS "]");
3296 return (FTH_PACKAGE_VERSION " (" FTH_DATE ") [" FTH_TARGET "]");
3297 }
3298
3299 char *
fth_short_version(void)3300 fth_short_version(void)
3301 {
3302 return (FTH_PACKAGE_VERSION " (" FTH_DATE ")");
3303 }
3304
3305 static void
ficl_version(ficlVm * vm)3306 ficl_version(ficlVm *vm)
3307 {
3308 #define h_ficl_version "( -- addr len ) return FTH version\n\
3309 ver type => \"1.2.9 (28-Jan-2012) [i386-portbld-freebsd9.0]\"\n\
3310 Return fth-version as a Forth string with ADDR LEN.\n\
3311 See also .version and .long-version."
3312 FTH_STACK_CHECK(vm, 0, 2);
3313 push_forth_string(vm, fth_version());
3314 }
3315
3316 /* ARGSUSED */
3317 static void
ficl_dot_lversion(ficlVm * vm)3318 ficl_dot_lversion(ficlVm *vm)
3319 {
3320 #define h_dot_lversion "( -- ) print FTH version\n\
3321 .long-version => FTH 1.2.9 (28-Jan-2012) [i386-portbld-freebsd9.0]\n\
3322 Print long package version.\n\
3323 See also .version and ver"
3324 (void) vm;
3325 fth_printf("FTH %s\n", fth_version());
3326 }
3327
3328 /* ARGSUSED */
3329 static void
ficl_dot_version(ficlVm * vm)3330 ficl_dot_version(ficlVm *vm)
3331 {
3332 #define h_dot_version "( -- ) print FTH version\n\
3333 .version => 1.2.9\n\
3334 Print package version number.\n\
3335 See also .long-version and ver."
3336 (void) vm;
3337 fth_print(FTH_PACKAGE_VERSION "\n");
3338 }
3339
3340 /* ARGSUSED */
3341 static void
ficl_dot_prefix(ficlVm * vm)3342 ficl_dot_prefix(ficlVm *vm)
3343 {
3344 #define h_dot_prefix "( -- ) print install prefix\n\
3345 .prefix => /usr/local\n\
3346 Print installation prefix path.\n\
3347 See also .cflags and .libs."
3348 (void) vm;
3349 fth_print(FTH_PREFIX_PATH "\n");
3350 }
3351
3352 /* ARGSUSED */
3353 static void
ficl_dot_cflags(ficlVm * vm)3354 ficl_dot_cflags(ficlVm *vm)
3355 {
3356 #define h_dot_cflags "( -- ) print compile flags\n\
3357 .cflags => -I/usr/local/include/fth\n\
3358 Print compiler flags to compile libfth.so to other applications.\n\
3359 See also .prefix and .libs."
3360 (void) vm;
3361 fth_print("-I" FTH_PREFIX_PATH "/include/" FTH_PROG_NAME "\n");
3362 }
3363
3364 /* ARGSUSED */
3365 static void
ficl_dot_libs(ficlVm * vm)3366 ficl_dot_libs(ficlVm *vm)
3367 {
3368 #define h_dot_libs "( -- ) print link flags\n\
3369 .libs => -L/usr/local/lib -lfth -lm\n\
3370 Print linker flags to link libfth.so to other applications.\n\
3371 See also .cflags and .prefix."
3372 (void) vm;
3373 fth_print("-L" FTH_PREFIX_PATH "/lib -l" FTH_PROG_NAME " ");
3374 #if defined(FTH_STATIC)
3375 fth_print(FTH_LIBS "\n");
3376 #else
3377 fth_print("-lm\n");
3378 #endif
3379 }
3380
3381 static void
ficl_config_prefix(ficlVm * vm)3382 ficl_config_prefix(ficlVm *vm)
3383 {
3384 #define h_config_prefix "( -- str ) return install prefix\n\
3385 config-prefix => \"/usr/local\"\n\
3386 Return installation prefix path.\n\
3387 See also config-cflags and config-libs."
3388 FTH_STACK_CHECK(vm, 0, 1);
3389 push_cstring(vm, FTH_PREFIX_PATH);
3390 }
3391
3392 static void
ficl_config_cflags(ficlVm * vm)3393 ficl_config_cflags(ficlVm *vm)
3394 {
3395 #define h_config_cflags "( -- str ) return compile flags\n\
3396 config-cflags => \"-I/usr/local/include/fth\"\n\
3397 Return compiler flags to compile libfth.so to other applications.\n\
3398 See also config-prefix and config-libs."
3399 FTH_STACK_CHECK(vm, 0, 1);
3400 push_cstring(vm, "-I" FTH_PREFIX_PATH "/include/" FTH_PROG_NAME);
3401 }
3402
3403 static void
ficl_config_libs(ficlVm * vm)3404 ficl_config_libs(ficlVm *vm)
3405 {
3406 #define h_config_libs "( -- str ) return link flags\n\
3407 config-libs => \"-L/usr/local/lib -lfth -lm\"\n\
3408 Return linker flags to link libfth.so to other applications.\n\
3409 See also config-prefix and config-cflags."
3410 FTH_STACK_CHECK(vm, 0, 1);
3411 push_cstring(vm, "-L" FTH_PREFIX_PATH "/lib -l" FTH_PROG_NAME " -lm");
3412 }
3413
3414 static void
ficl_configure_args(ficlVm * vm)3415 ficl_configure_args(ficlVm *vm)
3416 {
3417 #define h_configure_args "( -- str ) return configure arguments\n\
3418 configure-args => \" '--with-tecla-prefix=/usr/local' ...\"\n\
3419 Return configure arguments."
3420 FTH_STACK_CHECK(vm, 0, 1);
3421 push_cstring(vm, FTH_CONFIGURE_ARGS);
3422 }
3423
3424 static FTH
at_exit_each(FTH proc,FTH name)3425 at_exit_each(FTH proc, FTH name)
3426 {
3427 fth_proc_call(proc, (char *) name, 0);
3428 return (name);
3429 }
3430
3431 static void
run_at_exit(void)3432 run_at_exit(void)
3433 {
3434 FTH rw;
3435 #if !defined(_WIN32)
3436 int i;
3437
3438 for (i = 0; i < FTH_SIGNALS; i++)
3439 signal(fth_signals[i], SIG_DFL);
3440 #endif
3441 rw = (FTH) RUNNING_WORD();
3442
3443 if (fth_array_length(fth_at_exit_procs) > 0)
3444 fth_array_each(fth_at_exit_procs, at_exit_each, rw);
3445
3446 fth_reset_loop_and_depth();
3447 simple_array_free(depth_array);
3448 simple_array_free(loop_array);
3449 gc_free_all();
3450 ficlSystemDestroy(FTH_FICL_SYSTEM());
3451 FTH_FREE(FTH_FICL_VAR());
3452 }
3453
3454 static void
ficl_at_exit(ficlVm * vm)3455 ficl_at_exit(ficlVm *vm)
3456 {
3457 #define h_at_exit "( obj -- ) set clean-up function\n\
3458 lambda: <{ -- }> \"test.file\" file-delete ; at-exit\n\
3459 OBJ, a proc or xt, will be called by Fth's exit function. \
3460 More than one calls to AT-EXIT are possible, \
3461 all procs or xts will be called in order. \
3462 The stack effect of OBJ must be ( -- ).\n\
3463 See atexit(3) for more information."
3464 FTH proc_or_xt, proc;
3465
3466 FTH_STACK_CHECK(vm, 1, 0);
3467 proc_or_xt = fth_pop_ficl_cell(vm);
3468 proc = proc_from_proc_or_xt(proc_or_xt, 0, 0, 0);
3469 FTH_ASSERT_ARGS(FTH_PROC_P(proc), proc, FTH_ARG1, "a proc");
3470
3471 if (fth_array_length(fth_at_exit_procs) > 0)
3472 fth_array_push(fth_at_exit_procs, proc);
3473 else
3474 fth_at_exit_procs = fth_make_array_var(1, proc);
3475 }
3476
3477 static void
ficl_exit(ficlVm * vm)3478 ficl_exit(ficlVm *vm)
3479 {
3480 #define h_exit "( n -- ) exit FTH\n\
3481 2 (bye) => \\ exits FTH with exit code 2\n\
3482 The exit hook fth_exit_hook will be called if set, \
3483 all procs registered for at-exit will be executed \
3484 and the current process will be terminated with exit code N.\n\
3485 See exit(3) for more information.\n\
3486 See also bye and at-exit."
3487 FTH_STACK_CHECK(vm, 1, 0);
3488 fth_exit((int) ficlStackPopInteger(vm->dataStack));
3489 }
3490
3491 /*-
3492 * Convenient functions for
3493 * >array >assoc >list >alist >hash
3494 * #( ... ) #a( ... ) '( ... ) 'a( ... ) #{ ... }
3495 *
3496 * Creating an array:
3497 *
3498 * 'a 'b 'c 'd 4 >array
3499 *
3500 * or
3501 *
3502 * #( 'a 'b 'c 'd )
3503 *
3504 */
3505
3506 static ficlWord *set_begin_paren;
3507 static ficlWord *set_end_paren;
3508 static ficlWord *loop_begin;
3509 static ficlWord *loop_until;
3510
3511 void
fth_reset_loop_and_depth(void)3512 fth_reset_loop_and_depth(void)
3513 {
3514 unsigned int i;
3515
3516 for (i = 0; i < depth_array->length; i++)
3517 simple_array_free(simple_array_pop(depth_array));
3518
3519 simple_array_clear(depth_array);
3520 simple_array_clear(loop_array);
3521 }
3522
3523 static void
ficl_set_begin_paren(ficlVm * vm)3524 ficl_set_begin_paren(ficlVm *vm)
3525 {
3526 ficlWord *to_obj;
3527 FTH args;
3528
3529 FTH_STACK_CHECK(vm, 2, 0);
3530 to_obj = ficlStackPopPointer(vm->dataStack);
3531 args = fth_pop_ficl_cell(vm);
3532 simple_array_push(depth_array,
3533 make_simple_array_var(3, FTH_STACK_DEPTH(vm), to_obj,
3534 (void *) args));
3535 }
3536
3537 static void
ficl_set_end_paren(ficlVm * vm)3538 ficl_set_end_paren(ficlVm *vm)
3539 {
3540 simple_array *ary;
3541 ficlInteger depth;
3542
3543 ary = simple_array_pop(depth_array);
3544 depth = FTH_STACK_DEPTH(vm) - (ficlInteger) simple_array_ref(ary, 0);
3545 simple_array_free(ary);
3546 ficlStackPushInteger(vm->dataStack, depth);
3547 }
3548
3549 /* dbm.c needs it too. */
3550 void
fth_begin_values_to_obj(ficlVm * vm,char * name,FTH args)3551 fth_begin_values_to_obj(ficlVm *vm, char *name, FTH args)
3552 {
3553 ficlWord *to_obj;
3554
3555 to_obj = FICL_WORD_NAME_REF(name);
3556
3557 if (vm->state == FICL_VM_STATE_COMPILE) {
3558 ficlDictionary *dict;
3559 ficlUnsigned up;
3560
3561 dict = ficlVmGetDictionary(vm);
3562 up = (ficlUnsigned) ficlInstructionLiteralParen;
3563 ficlDictionaryAppendUnsigned(dict, up);
3564 ficlDictionaryAppendFTH(dict, args);
3565 ficlDictionaryAppendUnsigned(dict, up);
3566 ficlDictionaryAppendPointer(dict, to_obj);
3567 ficlDictionaryAppendPointer(dict, set_begin_paren);
3568 ficlDictionaryAppendPointer(dict, loop_begin);
3569 } else {
3570 ficlInteger d;
3571 simple_array *ary;
3572
3573 d = FTH_STACK_DEPTH(vm);
3574 ary = make_simple_array_var(3, d, to_obj, (void *) args);
3575 simple_array_push(depth_array, ary);
3576 }
3577 }
3578
3579 #define FTH_BEGIN_OBJ(name) \
3580 static void \
3581 ficl_begin_ ## name (ficlVm *vm) \
3582 { \
3583 fth_begin_values_to_obj(vm, ">" # name, FTH_FALSE); \
3584 }
3585
3586 FTH_BEGIN_OBJ(array)
FTH_BEGIN_OBJ(assoc)3587 FTH_BEGIN_OBJ(assoc)
3588 FTH_BEGIN_OBJ(list)
3589 FTH_BEGIN_OBJ(alist)
3590 FTH_BEGIN_OBJ(hash)
3591
3592 static void
3593 ficl_values_end(ficlVm *vm)
3594 {
3595 ficlWord *to_obj;
3596 FTH args;
3597 int len;
3598
3599 len = simple_array_length(depth_array);
3600
3601 if (len <= 0)
3602 FTH_BAD_SYNTAX_ERROR("orphaned closing paren found");
3603
3604 to_obj = FICL_WORD_REF(simple_array_ref(simple_array_ref(depth_array,
3605 len - 1), 1));
3606 args = (FTH) simple_array_ref(simple_array_ref(depth_array,
3607 len - 1), 2);
3608
3609 if (vm->state == FICL_VM_STATE_COMPILE) {
3610 ficlDictionary *dict;
3611 ficlUnsigned up;
3612
3613 dict = ficlVmGetDictionary(vm);
3614 up = (ficlUnsigned) ficlInstructionLiteralParen;
3615 ficlDictionaryAppendUnsigned(dict, up);
3616 ficlDictionaryAppendInteger(dict, (ficlInteger) FICL_TRUE);
3617 ficlDictionaryAppendPointer(dict, loop_until);
3618 ficlDictionaryAppendPointer(dict, set_end_paren);
3619
3620 /* >dbm needs an argument, the filename */
3621 if (FTH_NOT_FALSE_P(args)) {
3622 up = (ficlUnsigned) ficlInstructionLiteralParen;
3623 ficlDictionaryAppendUnsigned(dict, up);
3624 ficlDictionaryAppendFTH(dict, args);
3625 }
3626 ficlDictionaryAppendPointer(dict, to_obj);
3627 } else {
3628 simple_array *ary;
3629 ficlInteger depth, od;
3630
3631 ary = simple_array_pop(depth_array);
3632 od = (ficlInteger) simple_array_ref(ary, 0);
3633 depth = FTH_STACK_DEPTH(vm) - od;
3634 simple_array_free(ary);
3635 ficlStackPushInteger(vm->dataStack, depth);
3636
3637 /* >dbm needs an argument, the filename */
3638 if (FTH_NOT_FALSE_P(args))
3639 fth_push_ficl_cell(vm, args);
3640
3641 ficlVmExecuteXT(vm, to_obj);
3642 }
3643 }
3644
3645 /* === EACH-MAP === */
3646
3647 static void
ficl_set_each_loop_paren(ficlVm * vm)3648 ficl_set_each_loop_paren(ficlVm *vm)
3649 {
3650 #define h_set_each_l_paren "( obj -- len ) set each/end-each object\n\
3651 Helper function for each ... end-each. \
3652 Sets array representation of OBJ to loop_array and returns OBJ's length.\n\
3653 See also (reset-each), (fetch) and source file fth.fs."
3654 FTH obj;
3655
3656 FTH_STACK_CHECK(vm, 1, 1);
3657 obj = fth_pop_ficl_cell(vm);
3658 simple_array_push(loop_array, (void *) fth_object_copy(obj));
3659 ficlStackPushInteger(vm->dataStack, fth_object_length(obj));
3660 }
3661
3662 static void
ficl_set_map_loop_paren(ficlVm * vm)3663 ficl_set_map_loop_paren(ficlVm *vm)
3664 {
3665 #define h_set_map_l_paren "( obj -- len ) set map/end-map object\n\
3666 Helper function for map ... end-map. \
3667 Sets copy of OBJ to loop_array and returns OBJ's length.\n\
3668 See also (set-map-loop), (reset-map), (fetch), (store) and source file fth.fs."
3669 FTH obj;
3670
3671 FTH_STACK_CHECK(vm, 1, 1);
3672 obj = fth_pop_ficl_cell(vm);
3673 simple_array_push(loop_array, (void *) obj);
3674 ficlStackPushInteger(vm->dataStack, fth_object_length(obj));
3675 }
3676
3677 /* ARGSUSED */
3678 static void
ficl_reset_each_paren(ficlVm * vm)3679 ficl_reset_each_paren(ficlVm *vm)
3680 {
3681 #define h_re_each_paren "( -- ) reset each/end-each object\n\
3682 Helper function for each ... end-each. \
3683 Removes last object from loop-array.\n\
3684 See also (set-each-loop), (fetch) and source file fth.fs."
3685 (void) vm;
3686 simple_array_pop(loop_array);
3687 }
3688
3689 static void
ficl_reset_map_paren(ficlVm * vm)3690 ficl_reset_map_paren(ficlVm *vm)
3691 {
3692 #define h_re_map_paren "( -- obj ) reset map/end-map object\n\
3693 Helper function for map ... end-map. \
3694 Removes last object from loop-array and retuns it.\n\
3695 See also (set-map-loop), (fetch), (store) and source file fth.fs."
3696 FTH_STACK_CHECK(vm, 0, 1);
3697 ficlStackPushFTH(vm->dataStack, (FTH) simple_array_pop(loop_array));
3698 }
3699
3700 static void
ficl_fetch_paren(ficlVm * vm)3701 ficl_fetch_paren(ficlVm *vm)
3702 {
3703 #define h_fetch_paren "( index -- value ) fetch next value from object\n\
3704 Helper function for each ... end-each and map ... end-map. \
3705 Returns value on INDEX of last object in loop-array.\n\
3706 See also (set-each-loop), (reset-each), (store) and source file fth.fs."
3707 ficlInteger idx;
3708 int len;
3709
3710 FTH_STACK_CHECK(vm, 1, 1);
3711 idx = ficlStackPopInteger(vm->dataStack);
3712 len = simple_array_length(loop_array);
3713
3714 if (len > 0)
3715 fth_push_ficl_cell(vm,
3716 fth_object_value_ref((FTH) simple_array_ref(loop_array,
3717 len - 1), idx));
3718 else
3719 ficlStackPushBoolean(vm->dataStack, 0);
3720 }
3721
3722 static void
ficl_store_paren(ficlVm * vm)3723 ficl_store_paren(ficlVm *vm)
3724 {
3725 #define h_store_paren "( value index -- ) store value to object\n\
3726 Helper function for map ... end-map. \
3727 Stores VALUE on INDEX of last object in loop-array.\n\
3728 See also (set-map-loop), (reset-map), (fetch) and source file fth.fs."
3729 FTH value;
3730 ficlInteger idx;
3731 int len;
3732
3733 FTH_STACK_CHECK(vm, 2, 0);
3734 idx = ficlStackPopInteger(vm->dataStack);
3735 value = fth_pop_ficl_cell(vm);
3736 len = simple_array_length(loop_array);
3737
3738 if (len > 0)
3739 fth_object_value_set((FTH) simple_array_ref(loop_array,
3740 len - 1), idx, value);
3741 }
3742
3743 /* === Initialize === */
3744 void
forth_init(void)3745 forth_init(void)
3746 {
3747 ficlDictionary *dict;
3748
3749 INIT_ASSERT(FTH_FICL_VAR());
3750 dict = FTH_FICL_DICT();
3751 FTH_FICL_VM()->runningWord = NULL;
3752
3753 if (atexit(run_at_exit) == -1)
3754 FTH_SYSTEM_ERROR_THROW(atexit);
3755
3756 /* Load Ficl source files. */
3757 {
3758 char *sf[] = {
3759 "softcore.fr",
3760 "ifbrack.fr",
3761 "prefix.fr",
3762 "ficl.fr",
3763 "jhlocal.fr",
3764 "marker.fr",
3765 "fileaccess.fr",
3766 "assert.fs",
3767 "compat.fs",
3768 NULL};
3769 char **softcore = sf;
3770
3771 while (*softcore) {
3772 fth_var_set(fth_last_exception, FTH_FALSE);
3773 fth_require_file(*softcore++);
3774 }
3775 }
3776
3777 /* constants */
3778 fth_define_constant("cell", sizeof(ficlCell), NULL);
3779 fth_define_constant("float", sizeof(ficlFloat), NULL);
3780 fth_define_constant("sfloat", sizeof(ficlFloat), NULL);
3781 fth_define_constant("dfloat", sizeof(ficlFloat), NULL);
3782 fth_define_constant("ficl-version", fth_make_string(FICL_VERSION),
3783 NULL);
3784 fth_define_constant("fth-version", fth_make_string(fth_version()),
3785 NULL);
3786 fth_define_constant("fth-date", fth_make_string(FTH_DATE), NULL);
3787 fth_define_constant("INTERPRET_STATE", FICL_VM_STATE_INTERPRET, NULL);
3788 fth_define_constant("COMPILE_STATE", FICL_VM_STATE_COMPILE, NULL);
3789 fth_define_constant("FICL_VM_STATE_INTERPRET", FICL_VM_STATE_INTERPRET,
3790 NULL);
3791 fth_define_constant("FICL_VM_STATE_COMPILE", FICL_VM_STATE_COMPILE,
3792 NULL);
3793
3794 /* misc */
3795 FTH_PRI1("add-feature", ficl_add_feature, h_add_feature);
3796 FTH_PRI1("provided?", ficl_provided_p, h_provided_p);
3797 FTH_PRI1("*features*", ficl_features, h_features);
3798 FTH_PRI1("add-load-path", ficl_add_load_path, h_add_load_path);
3799 FTH_PRI1("unshift-load-path", ficl_unshift_load_path, h_uns_load_path);
3800 FTH_PRI1("add-load-lib-path", ficl_add_load_lib_path,
3801 h_add_load_lib_path);
3802 FTH_PRI1("unshift-load-lib-path", ficl_unshift_load_lib_path,
3803 h_uns_load_lib_path);
3804 FTH_PRI1("include", ficl_include_file, h_include_file);
3805 FTH_PRI1("require", ficl_require_file, h_require_file);
3806 FTH_PRI1("load-init-file", ficl_load_init_file, h_load_init_file);
3807 FTH_PRI1("dl-load", ficl_dl_load, h_dl_load);
3808 #if !defined(_WIN32)
3809 FTH_VOID_PROC("install-file", fth_install_file, 1, 0, 0,
3810 h_install_file);
3811 FTH_VOID_PROC("install", fth_install, 0, 0, 0, h_install);
3812 #endif
3813 FTH_PROC("apropos", fth_apropos, 1, 0, 0, h_apropos);
3814 FTH_PRI1("fth-catch", ficl_catch, h_fth_catch);
3815 FTH_PRI1("fth-throw", ficl_throw, h_fth_throw);
3816 FTH_PRI1("fth-raise", ficl_raise, h_fth_raise);
3817 FTH_PRI1("stack-reset", ficl_stack_reset, h_stack_reset);
3818 #if defined(HAVE_GETTIMEOFDAY)
3819 FTH_PRI1("time", ficl_time, h_time);
3820 FTH_PRI1("time-reset", ficl_time_reset, h_time_reset);
3821 #endif
3822 FTH_PRI1("utime", ficl_utime, h_utime);
3823 FTH_PRI1("current-time", ficl_current_time, h_current_time);
3824 FTH_PRI1("time->string", ficl_time_to_string, h_time_to_string);
3825 FTH_PRI1("strftime", ficl_strftime, h_strftime);
3826 FTH_PRI1("strptime", ficl_strptime, h_strptime);
3827 FTH_PRI1("localtime", ficl_localtime, h_localtime);
3828 FTH_PRI1("gmtime", ficl_gmtime, h_gmtime);
3829 FTH_PRI1("mktime", ficl_mktime, h_mktime);
3830 FTH_PRI1("getenv", ficl_getenv, h_getenv);
3831 FTH_PRI1("putenv", ficl_putenv, h_putenv);
3832 FTH_PRI1("environ", ficl_environ, h_environ);
3833 FTH_PRI1("getpid", ficl_getpid, h_getpid);
3834 FTH_PRI1("getppid", ficl_getppid, h_getppid);
3835 FTH_PRI1("getuid", ficl_getuid, h_getuid);
3836 FTH_PRI1("geteuid", ficl_geteuid, h_geteuid);
3837 FTH_PRI1("getgid", ficl_getgid, h_getgid);
3838 FTH_PRI1("getegid", ficl_getegid, h_getegid);
3839 #if defined(HAVE_SETUID)
3840 FTH_PRI1("setuid", ficl_setuid, h_setuid);
3841 #endif
3842 #if defined(HAVE_SETEUID)
3843 FTH_PRI1("seteuid", ficl_seteuid, h_seteuid);
3844 #endif
3845 #if defined(HAVE_SETGID)
3846 FTH_PRI1("setgid", ficl_setgid, h_setgid);
3847 #endif
3848 #if defined(HAVE_SETEGID)
3849 FTH_PRI1("setegid", ficl_setegid, h_setegid);
3850 #endif
3851 FTH_PRI1("signal", ficl_signal, h_signal);
3852 #if defined(HAVE_KILL)
3853 FTH_PRI1("kill", ficl_kill, h_kill);
3854 #endif
3855 FTH_PRI1("wait", ficl_wait, h_wait);
3856 FTH_PRI1("waitpid", ficl_waitpid, h_waitpid);
3857 #if defined(HAVE_FORK)
3858 FTH_PRI1("fork", ficl_fork, h_fork);
3859 #endif
3860 #if defined(HAVE_EXECLP) && defined(HAVE_EXECVP)
3861 FTH_PRI1("exec", ficl_exec, h_exec);
3862 #endif
3863 FTH_PRI1("getlogin", ficl_getlogin, h_getlogin);
3864 FTH_PRI1("hostname", ficl_gethostname, h_gethostname);
3865 FTH_PRI1("gethostname", ficl_gethostname, h_gethostname);
3866 FTH_PRI1("sethostname", ficl_sethostname, h_sethostname);
3867 FTH_PRI1("getservbyname", ficl_getservbyname, h_getservbyname);
3868 FTH_PRI1("getservbyport", ficl_getservbyport, h_getservbyport);
3869 FTH_PRI1("date", ficl_date, h_date);
3870 #if defined(HAVE_SLEEP)
3871 FTH_PRI1("sleep", ficl_sleep, h_sleep);
3872 #endif
3873 fth_define_variable("opterr", FTH_TRUE, h_opterr);
3874 fth_define_variable("optopt", FTH_FALSE, h_optopt);
3875 fth_define_variable("optind", FTH_ONE, h_optind);
3876 fth_define_variable("optarg", FTH_FALSE, h_optarg);
3877 FTH_PRI1("getopt", ficl_getopt, h_getopt);
3878 FTH_PRI1("getopt-long", ficl_getopt_long, h_getopt_long);
3879 FTH_PRI1(".memory", ficl_show_memory, h_show_memory);
3880 FTH_PRI1("ver", ficl_version, h_ficl_version);
3881 FTH_PRI1(".long-version", ficl_dot_lversion, h_dot_lversion);
3882 FTH_PRI1(".version", ficl_dot_version, h_dot_version);
3883 FTH_PRI1(".prefix", ficl_dot_prefix, h_dot_prefix);
3884 FTH_PRI1(".cflags", ficl_dot_cflags, h_dot_cflags);
3885 FTH_PRI1(".libs", ficl_dot_libs, h_dot_libs);
3886 FTH_PRI1("config-prefix", ficl_config_prefix, h_config_prefix);
3887 FTH_PRI1("config-cflags", ficl_config_cflags, h_config_cflags);
3888 FTH_PRI1("config-libs", ficl_config_libs, h_config_libs);
3889 FTH_PRI1("configure-args", ficl_configure_args, h_configure_args);
3890 FTH_PRI1("at-exit", ficl_at_exit, h_at_exit);
3891 FTH_PRI1("(bye)", ficl_exit, h_exit);
3892 #if !defined(_WIN32)
3893 FTH_SET_CONSTANT(WNOHANG);
3894 FTH_SET_CONSTANT(WUNTRACED);
3895 #endif
3896 FTH_SET_CONSTANT(SIG_DFL);
3897 FTH_SET_CONSTANT(SIG_IGN);
3898 FTH_SET_CONSTANT(SIG_ERR);
3899 #if defined(SIGHUP)
3900 FTH_SET_CONSTANT(SIGHUP); /* hangup */
3901 #endif
3902 #if defined(SIGINT)
3903 FTH_SET_CONSTANT(SIGINT); /* interrupt */
3904 #endif
3905 #if defined(SIGQUIT)
3906 FTH_SET_CONSTANT(SIGQUIT); /* quit */
3907 #endif
3908 #if defined(SIGILL)
3909 FTH_SET_CONSTANT(SIGILL); /* illegal instr. */
3910 #endif
3911 #if defined(SIGTRAP)
3912 FTH_SET_CONSTANT(SIGTRAP); /* trace trap */
3913 #endif
3914 #if defined(SIGABRT)
3915 FTH_SET_CONSTANT(SIGABRT); /* abort */
3916 #endif
3917 #if defined(SIGIOT)
3918 FTH_SET_CONSTANT(SIGIOT); /* compatibility (SIGABRT) */
3919 #endif
3920 #if defined(SIGEMT)
3921 FTH_SET_CONSTANT(SIGEMT); /* EMT instruction */
3922 #endif
3923 #if defined(SIGFPE)
3924 FTH_SET_CONSTANT(SIGFPE); /* floating point exception */
3925 #endif
3926 #if defined(SIGKILL)
3927 FTH_SET_CONSTANT(SIGKILL); /* kill */
3928 #endif
3929 #if defined(SIGBUS)
3930 FTH_SET_CONSTANT(SIGBUS); /* bus error */
3931 #endif
3932 #if defined(SIGSEGV)
3933 FTH_SET_CONSTANT(SIGSEGV); /* segmentation violation */
3934 #endif
3935 #if defined(SIGSYS)
3936 FTH_SET_CONSTANT(SIGSYS); /* non-existent system call invoked */
3937 #endif
3938 #if defined(SIGPIPE)
3939 FTH_SET_CONSTANT(SIGPIPE); /* write on a pipe with no one to
3940 * read it */
3941 #endif
3942 #if defined(SIGALRM)
3943 FTH_SET_CONSTANT(SIGALRM); /* alarm clock */
3944 #endif
3945 #if defined(SIGTERM)
3946 FTH_SET_CONSTANT(SIGTERM); /* software termination signal from
3947 * kill */
3948 #endif
3949 #if defined(SIGURG)
3950 FTH_SET_CONSTANT(SIGURG); /* urgent condition on IO channel */
3951 #endif
3952 #if defined(SIGSTOP)
3953 FTH_SET_CONSTANT(SIGSTOP); /* sendable stop signal not from tty */
3954 #endif
3955 #if defined(SIGTSTP)
3956 FTH_SET_CONSTANT(SIGTSTP); /* stop signal from tty */
3957 #endif
3958 #if defined(SIGCONT)
3959 FTH_SET_CONSTANT(SIGCONT); /* continue a stopped process */
3960 #endif
3961 #if defined(SIGCHLD)
3962 FTH_SET_CONSTANT(SIGCHLD); /* to parent on child stop or exit */
3963 #endif
3964 #if defined(SIGTTIN)
3965 FTH_SET_CONSTANT(SIGTTIN); /* to readers pgrp upon background
3966 * tty read */
3967 #endif
3968 #if defined(SIGTTOU)
3969 FTH_SET_CONSTANT(SIGTTOU); /* like TTIN if (tp->t_local<OSTOP) */
3970 #endif
3971 #if defined(SIGIO)
3972 FTH_SET_CONSTANT(SIGIO);/* input/output possible signal */
3973 #endif
3974 #if defined(SIGXCPU)
3975 FTH_SET_CONSTANT(SIGXCPU); /* exceeded CPU time limit */
3976 #endif
3977 #if defined(SIGXFSZ)
3978 FTH_SET_CONSTANT(SIGXFSZ); /* exceeded file size limit */
3979 #endif
3980 #if defined(SIGVTALRM)
3981 FTH_SET_CONSTANT(SIGVTALRM); /* virtual time alarm */
3982 #endif
3983 #if defined(SIGPROF)
3984 FTH_SET_CONSTANT(SIGPROF); /* profiling time alarm */
3985 #endif
3986 #if defined(SIGWINCH)
3987 FTH_SET_CONSTANT(SIGWINCH); /* window size changes */
3988 #endif
3989 #if defined(SIGINFO)
3990 FTH_SET_CONSTANT(SIGINFO); /* information request */
3991 #endif
3992 #if defined(SIGUSR1)
3993 FTH_SET_CONSTANT(SIGUSR1); /* user defined signal 1 */
3994 #endif
3995 #if defined(SIGUSR2)
3996 FTH_SET_CONSTANT(SIGUSR2); /* user defined signal 2 */
3997 #endif
3998 #if defined(SIGTHR)
3999 FTH_SET_CONSTANT(SIGTHR); /* Thread interrupt. */
4000 #endif
4001
4002 /* >array, >assoc, >list, >hash */
4003 loop_begin = FICL_WORD_NAME_REF("begin");
4004 loop_until = FICL_WORD_NAME_REF("until");
4005 set_begin_paren = ficlDictionaryAppendPrimitive(dict,
4006 "(set-begin)", ficl_set_begin_paren, FICL_WORD_DEFAULT);
4007 set_end_paren = ficlDictionaryAppendPrimitive(dict,
4008 "(set-end)", ficl_set_end_paren, FICL_WORD_DEFAULT);
4009 FTH_PRI1("#(", ficl_begin_array, NULL);
4010 FTH_PRI1("array(", ficl_begin_array, NULL);
4011 FTH_PRI1("#a(", ficl_begin_assoc, NULL);
4012 FTH_PRI1("assoc(", ficl_begin_assoc, NULL);
4013 FTH_PRI1("'(", ficl_begin_list, NULL);
4014 FTH_PRI1("list(", ficl_begin_list, NULL);
4015 FTH_PRI1("'a(", ficl_begin_alist, NULL);
4016 FTH_PRI1("alist(", ficl_begin_alist, NULL);
4017 FTH_PRI1("#{", ficl_begin_hash, NULL);
4018 FTH_PRI1("hash{", ficl_begin_hash, NULL);
4019 FTH_PRI1(")", ficl_values_end, NULL);
4020 FTH_PRI1("}", ficl_values_end, NULL);
4021
4022 /* each/map */
4023 FTH_PRI1("(set-each-loop)", ficl_set_each_loop_paren,
4024 h_set_each_l_paren);
4025 FTH_PRI1("(set-map-loop)", ficl_set_each_loop_paren,
4026 h_set_map_l_paren);
4027 FTH_PRI1("(set-map!-loop)", ficl_set_map_loop_paren,
4028 h_set_map_l_paren);
4029 FTH_PRI1("(reset-each)", ficl_reset_each_paren, h_re_each_paren);
4030 FTH_PRI1("(reset-map)", ficl_reset_map_paren, h_re_map_paren);
4031 FTH_PRI1("(fetch)", ficl_fetch_paren, h_fetch_paren);
4032 FTH_PRI1("(store)", ficl_store_paren, h_store_paren);
4033
4034 fth_require_file("fth.fs");
4035 #if defined(HAVE_TZSET)
4036 tzset();
4037 #endif
4038 #if defined(HAVE_GETTIMEOFDAY)
4039 if (gettimeofday(&fth_timeval_tv, NULL) == -1)
4040 FTH_SYSTEM_ERROR_THROW(gettimeofday);
4041 #endif
4042 }
4043
4044 /*
4045 * misc.c ends here
4046 */
4047