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 fth_sccsid[] = "@(#)fth.c 2.2 1/29/19";
29 #endif /* not lint */
30
31 #if defined(HAVE_CONFIG_H)
32 #include "config.h"
33 #endif
34
35 #include "fth.h"
36 #include "utils.h"
37 #include <getopt.h>
38
39 #define FTH_COPYRIGHT "(c) 2004-2019 Michael Scholz"
40
41 static FTH eval_with_error_exit(void *, int);
42 static void repl_in_place(char *, FTH, ficlWord *, int, int, int);
43 static ficlWord *source_to_word(const char *);
44 static FTH string_split(char *, char *);
45
46 enum {
47 REPL_COMPILE,
48 REPL_INTERPRET
49 };
50
51 static ficlWord *
source_to_word(const char * buffer)52 source_to_word(const char *buffer)
53 {
54 int status;
55 char *bstr;
56 ficlWord *word;
57
58 word = NULL;
59 bstr = fth_format("lambda: ( ?? -- ?? ) %s ;", buffer);
60 status = fth_catch_eval(bstr);
61 FTH_FREE(bstr);
62
63 switch (status) {
64 case FTH_BYE:
65 fth_exit(EXIT_SUCCESS);
66 break;
67 case FTH_ERROR:
68 fth_exit(EXIT_FAILURE);
69 break;
70 default:
71 word = ficlStackPopPointer(FTH_FICL_STACK());
72 break;
73 }
74
75 return (word);
76 }
77
78 /*
79 * Like fth_eval() in misc.c but exit(0) if 'bye' and exit(1) if error.
80 */
81 static FTH
eval_with_error_exit(void * p,int kind)82 eval_with_error_exit(void *p, int kind)
83 {
84 int status;
85 ficlInteger depth;
86 ficlInteger new_depth;
87 ficlInteger i;
88 ficlVm *vm;
89 FTH val;
90
91 val = FTH_UNDEF;
92
93 if (p == NULL)
94 return (val);
95
96 fth_eval_p = 1;
97 vm = FTH_FICL_VM();
98 depth = FTH_STACK_DEPTH(vm);
99
100 switch (kind) {
101 case REPL_COMPILE:
102 status = fth_catch_exec((ficlWord *) p);
103 break;
104 case REPL_INTERPRET:
105 default:
106 status = fth_catch_eval((const char *) p);
107 break;
108 }
109
110 switch (status) {
111 case FTH_BYE:
112 fth_exit(EXIT_SUCCESS);
113 break;
114 case FTH_ERROR:
115 if (fth_die_on_signal_p)
116 fth_exit(EXIT_FAILURE);
117 break;
118 default:
119 new_depth = FTH_STACK_DEPTH(vm) - depth;
120
121 switch (new_depth) {
122 case 0:
123 val = FTH_UNDEF;
124 break;
125 case 1:
126 val = fth_pop_ficl_cell(vm);
127 break;
128 default:
129 val = fth_make_array_len(new_depth);
130
131 for (i = 0; i < new_depth; i++)
132 fth_array_set(val, i, fth_pop_ficl_cell(vm));
133 break;
134 }
135 break;
136 }
137
138 fth_eval_p = 0;
139 return (val);
140 }
141
142 static FTH
string_split(char * str,char * delim)143 string_split(char *str, char *delim)
144 {
145 char *p;
146 char *s;
147 char *t;
148 FTH result;
149
150 s = t = FTH_STRDUP(str);
151 result = fth_make_empty_array();
152
153 while ((p = strsep(&s, delim)) != NULL)
154 if (*p != '\0')
155 fth_array_push(result, fth_make_string(p));
156
157 FTH_FREE(t);
158 return (result);
159 }
160
161 static char fth_scratch[BUFSIZ];
162
163 static void
repl_in_place(char * in,FTH out,ficlWord * word,int auto_split_p,int print_p,int chomp_p)164 repl_in_place(char *in, FTH out, ficlWord *word, int auto_split_p, int print_p, int chomp_p)
165 {
166 size_t len;
167 ficlInteger line_no;
168 char *delim;
169 char *buf;
170 FILE *ifp;
171 FTH line;
172
173 ifp = stdin;
174
175 if (in != NULL) {
176 ifp = fopen(in, "r");
177
178 if (ifp == NULL) {
179 FTH_SYSTEM_ERROR_ARG_THROW(fopen, in);
180 return;
181 }
182 }
183 gc_push(FTH_FICL_VM()->runningWord);
184 delim = fth_string_ref(fth_variable_ref("*fs*"));
185 line_no = 0;
186 buf = fth_scratch;
187
188 while (fgets(buf, BUFSIZ, ifp) != NULL) {
189 if (print_p)
190 fth_print(buf);
191
192 if (chomp_p) {
193 len = fth_strlen(buf);
194 if (buf[len - 1] == '\n')
195 buf[len - 1] = '\0';
196 }
197 if (auto_split_p)
198 fth_variable_set("*farray*", string_split(buf, delim));
199
200 fth_variable_set("*line*", fth_make_string(buf));
201 fth_variable_set("*fnr*", fth_make_int(line_no++));
202 line = eval_with_error_exit(word, REPL_COMPILE);
203 fth_variable_set("*nr*",
204 fth_number_add(fth_variable_ref("*nr*"), FTH_ONE));
205
206 if (FTH_NOT_FALSE_P(out))
207 fth_array_push(out, line);
208
209 gc_loop_reset();
210 }
211
212 gc_pop();
213
214 if (in != NULL)
215 fclose(ifp);
216 }
217
218 #define LIBSLEN 48
219 #define WARN_STR "#<warning: too much calls for -%c, ignoring \"%s\">\n"
220 #define FTH_USAGE "\
221 usage: fth [-DdQqrv] [-C so-lib-path] [-Ee pattern] [-F fs] [-f init-file]\n\
222 [-I fs-path] [-S \"lib init\"] [-s file] [file ...]\n\
223 fth [-al] [-i [suffix]] [-n | -p] -e pattern [file | -]\n\
224 fth -V\n"
225
226 extern char *optarg;
227 extern int opterr;
228 extern int optind;
229 extern int optopt;
230
231 int
main(int argc,char ** argv)232 main(int argc, char **argv)
233 {
234 int i;
235 int c;
236 int die;
237 int no_init_file;
238 int auto_split;
239 int debug;
240 int in_place_p;
241 int ficl_repl;
242 int line_end;
243 int implicit_loop;
244 int loop_print;
245 int script_p;
246 int finish_getopt;
247 int exit_value;
248 int stay_in_repl;
249 int verbose;
250 int lp_len;
251 int llp_len;
252 int bufs_len;
253 int libs_len;
254 char *field_separator;
255 char *init_file;
256 char *suffix;
257 char *script;
258 char *buffers[LIBSLEN];
259 char *load_lib_paths[LIBSLEN];
260 char *libraries[LIBSLEN];
261 char *load_paths[LIBSLEN];
262 FTH ret;
263
264 /*-
265 * environment variable POSIXLY_CORRECT: if set, disable permutation
266 * optstring starting with `-': RETURN_IN_ORDER
267 * optstring starting with `+': REQUIRE_ORDER (posix)
268 * optional arguments: append two colons x:: (see i:: in char *args)
269 */
270 char *args = "C:DE:F:I:QS:Vade:f:i::lnpqrs:v";
271
272 /*
273 * Long options are gone with version 1.3.3 but --eval and
274 * --no-init-file remain for backwards compatibility for old fth.m4
275 * files.
276 */
277 struct option opts[] = {
278 {"eval", required_argument, NULL, 'e'},
279 {"no-init-file", no_argument, NULL, 'Q'},
280 {0, 0, 0, 0}
281 };
282
283 exit_value = EXIT_SUCCESS;
284 llp_len = 0; /* -C path */
285 die = 0; /* -D */
286 /*
287 * stay_in_repl: -1 not set
288 * 0 -e (eval)
289 * 0 -s (script)
290 * 1 -E (eval-and-stay)
291 * 1 -r (ficl-repl)
292 */
293 stay_in_repl = -1; /* -Er 1 || -es 0 */
294 bufs_len = 0; /* -Ee pattern */
295 field_separator = NULL; /* -F fs */
296 lp_len = 0; /* -I path */
297 no_init_file = 0; /* -Q */
298 libs_len = 0; /* -S path */
299 auto_split = 0; /* -a */
300 debug = 0; /* -d */
301 init_file = NULL; /* -f file */
302 in_place_p = 0; /* -i[suffix] */
303 suffix = NULL; /* -isuffix */
304 line_end = 0; /* -l */
305 implicit_loop = 0; /* -n || -p */
306 loop_print = 0; /* -n 0 || -p 1 */
307 ficl_repl = 0; /* -r */
308 script_p = 0; /* -s */
309 finish_getopt = 0; /* -s */
310 script = NULL; /* -s file */
311
312 /*-
313 * verbose: -1 not set --> true in interactive repl
314 * 0 -q quiet
315 * 1 -v verbose
316 */
317 verbose = -1; /* -v 1 || -q 0 */
318 opterr = 1; /* show getopt's error message */
319 optind = 1; /* initialize getopt */
320
321 while (!finish_getopt &&
322 (c = getopt_long(argc, argv, args, opts, NULL)) != -1) {
323 switch (c) {
324 case 'C': /* -C PATH */
325 if (llp_len < LIBSLEN)
326 load_lib_paths[llp_len++] = optarg;
327 else
328 fprintf(stderr, WARN_STR, c, optarg);
329 break;
330 case 'D': /* -D */
331 die = 1;
332 break;
333 case 'E': /* -E PATTERN */
334 stay_in_repl = 1;
335 if (bufs_len < LIBSLEN)
336 buffers[bufs_len++] = optarg;
337 else
338 fprintf(stderr, WARN_STR, c, optarg);
339 break;
340 case 'F': /* -F SEP */
341 field_separator = optarg;
342 break;
343 case 'I': /* -I PATH */
344 if (lp_len < LIBSLEN)
345 load_paths[lp_len++] = optarg;
346 else
347 fprintf(stderr, WARN_STR, c, optarg);
348 break;
349 case 'Q': /* -Q */
350 no_init_file = 1;
351 break;
352 case 'S': /* -S "LIB FUNC" */
353 if (libs_len < LIBSLEN)
354 libraries[libs_len++] = optarg;
355 else
356 fprintf(stderr, WARN_STR, c, optarg);
357 break;
358 case 'V': /* -V */
359 fprintf(stdout, "%s %s\n",
360 FTH_PACKAGE_NAME, fth_version());
361 fprintf(stdout, "Copyright %s\n", FTH_COPYRIGHT);
362 exit(EXIT_SUCCESS);
363 break;
364 case 'a': /* -a */
365 auto_split = 1;
366 break;
367 case 'd': /* -d */
368 debug = 1;
369 break;
370 case 'e': /* -e PATTERN */
371 stay_in_repl = 0;
372 if (bufs_len < LIBSLEN)
373 buffers[bufs_len++] = optarg;
374 else
375 fprintf(stderr, WARN_STR, c, optarg);
376 break;
377 case 'f': /* -f FILE */
378 init_file = optarg;
379 break;
380 case 'i': /* -i [SUFFIX] */
381 in_place_p = 1;
382 if (optarg)
383 suffix = optarg;
384 break;
385 case 'l': /* -l */
386 line_end = 1;
387 break;
388 case 'n': /* -n */
389 loop_print = 0;
390 implicit_loop = 1;
391 break;
392 case 'p': /* -p */
393 loop_print = 1;
394 implicit_loop = 1;
395 break;
396 case 'q': /* -q */
397 verbose = 0;
398 break;
399 case 'r': /* -r */
400 stay_in_repl = 1;
401 ficl_repl = 1;
402 break;
403 case 's': /* -s FILE */
404 stay_in_repl = 0;
405 script_p = 1;
406 script = optarg;
407 finish_getopt = 1;
408 break;
409 case 'v': /* -v */
410 verbose = 1;
411 break;
412 case '?':
413 default:
414 fprintf(stderr, FTH_USAGE);
415 exit(EXIT_FAILURE);
416 break;
417 }
418 }
419
420 /*
421 * Start init forth.
422 */
423 forth_init_before_load();
424 fth_variable_set("*fth-verbose*", BOOL_TO_FTH(verbose > 0));
425 fth_variable_set("*fth-debug*", BOOL_TO_FTH(debug));
426 fth_die_on_signal_p = die;
427 fth_true_repl_p = !ficl_repl;
428
429 /*
430 * If -I or -C was given, we have to add these paths before finishing
431 * Forth init; calling 'make test' before 'make install' requires
432 * this for finding system scripts in the source tree instead in
433 * ${prefix}/share/fth.
434 */
435 if (lp_len > 0) /* -I PATH */
436 for (i = 0; i < lp_len; i++)
437 fth_unshift_load_path(load_paths[i]);
438
439 if (llp_len > 0) /* -C PATH */
440 for (i = 0; i < llp_len; i++)
441 fth_unshift_load_lib_path(load_lib_paths[i]);
442
443 /*
444 * Finish init forth.
445 */
446 forth_init();
447
448 /*
449 * Adjust command line array.
450 */
451 fth_set_argv(script_p ? optind - 1 : 0, argc, argv);
452 argc -= optind;
453 argv += optind;
454
455 /*
456 * Reset getopt for further use in Forth scripts.
457 */
458 optind = 1;
459
460 if (field_separator != NULL) /* -F SEP */
461 fth_variable_set("*fs*", fth_make_string(field_separator));
462
463 if (libs_len > 0) { /* -S "LIB FUNC" */
464 char *lib, *name, *fnc;
465
466 for (i = 0; i < libs_len; i++) {
467 lib = libraries[i];
468 name = strsep(&lib, " \t");
469 fnc = strsep(&lib, " \t");
470 fth_dl_load(name, fnc);
471 }
472 }
473
474 /*
475 * Run script and exit.
476 */
477 if (script_p) { /* -s FILE */
478 ret = fth_load_file(script);
479
480 if (FTH_STRING_P(ret)) {
481 fth_throw(FTH_LOAD_ERROR, "%S", ret);
482 fth_exit(EXIT_FAILURE);
483 }
484 fth_exit(EXIT_SUCCESS);
485 }
486
487 /*
488 * In-place or implicit-loop action and exit.
489 */
490 if (in_place_p || implicit_loop) { /* -inp */
491 ficlWord *word;
492 char *in_file, out_file[MAXPATHLEN];
493 FTH out;
494
495 if (bufs_len < 1) {
496 fth_errorf("#<%s: in-place requires -e PATTERN!>\n",
497 fth_exception_ref(FTH_FORTH_ERROR));
498 fth_exit(EXIT_FAILURE);
499 /*
500 * To silence ccc-analyzer (uninitialized
501 * 'buffer[i]' after for-loop below).
502 */
503 /* NOTREACHED */
504 return (EXIT_FAILURE);
505 }
506
507 /*
508 * If multiple -e, eval all but last.
509 */
510 for (i = 0; i < bufs_len - 1; i++)
511 eval_with_error_exit(buffers[i], REPL_INTERPRET);
512
513 /*
514 * Last or only -e: compile and use it for in-place.
515 */
516 word = source_to_word(buffers[i]);
517
518 /*
519 * Read from stdin ...
520 */
521 if (*argv == NULL) {
522 repl_in_place(NULL, FTH_FALSE, word,
523 auto_split, loop_print, line_end);
524 fth_exit(EXIT_SUCCESS);
525 }
526
527 /*
528 * ... or process all remaining files in order.
529 */
530 for (i = 0; argv[i]; i++) {
531 in_file = argv[i];
532 fth_variable_set("*fname*", fth_make_string(in_file));
533
534 if (in_place_p) { /* -i [SUFFIX] */
535 out = fth_make_empty_array();
536 repl_in_place(in_file, out, word,
537 auto_split, loop_print, line_end);
538
539 if (suffix != NULL) { /* -i SUFFIX */
540 fth_strcpy(out_file, sizeof(out_file),
541 in_file);
542 fth_strcat(out_file, sizeof(out_file),
543 suffix);
544 fth_file_rename(in_file, out_file);
545 }
546 fth_writelines(in_file, out);
547 } else
548 repl_in_place(in_file, FTH_FALSE, word,
549 auto_split, loop_print, line_end);
550 }
551 fth_exit(EXIT_SUCCESS);
552 }
553
554 /*
555 * Load remaining args as fth source files.
556 */
557 for (i = 0; argv[i]; i++) {
558 /* read words from stdin and exit */
559 if (strcmp(argv[i], "-") == 0) {
560 /*-
561 * % echo "80 .f2c cr" | fth - ==> 26.67
562 *
563 * % cat foo
564 * 80 .f2c cr
565 *
566 * % fth - < foo ==> 26.67
567 *
568 * % fth -
569 * 80 .f2c cr <enter> ==> 26.67
570 * bye <enter>
571 * %
572 */
573 char *buf;
574
575 buf = fth_scratch;
576
577 while (fgets(buf, BUFSIZ, stdin) != NULL)
578 eval_with_error_exit(buf, REPL_INTERPRET);
579
580 fth_exit(EXIT_SUCCESS);
581 } else {
582 ret = fth_load_file(argv[i]);
583
584 if (FTH_STRING_P(ret))
585 fth_throw(FTH_LOAD_ERROR, "%S", ret);
586 }
587 }
588
589 /*
590 * Adjust exit-value; if -D, exit.
591 */
592 if (exit_value != EXIT_SUCCESS || fth_hit_error_p) {
593 exit_value = EXIT_FAILURE;
594
595 if (die)
596 fth_exit(exit_value);
597 }
598
599 /*
600 * Eval strings from command line.
601 */
602 if (bufs_len > 0) { /* -Ee PATTERN */
603 /*
604 * If multiple -e, eval all but last.
605 */
606 for (i = 0; i < bufs_len - 1; i++)
607 eval_with_error_exit(buffers[i], REPL_INTERPRET);
608
609 /*
610 * Compile last or only -e.
611 */
612 eval_with_error_exit(source_to_word(buffers[i]), REPL_COMPILE);
613 }
614
615 /*
616 * Adjust stay_in_repl if not set.
617 */
618 if (stay_in_repl == -1)
619 stay_in_repl = (argc == 0) ? 1 : 0;
620
621 if (stay_in_repl > 0) {
622 /*
623 * If not set, be verbose in repl (and while loading init
624 * files).
625 */
626 if (verbose == -1)
627 fth_variable_set("*fth-verbose*", FTH_TRUE);
628
629 /*
630 * Print banner if we are still here.
631 */
632 if (verbose != 0) { /* not -q */
633 fth_printf("\\ This is %s, %s\n",
634 FTH_PACKAGE_NAME, FTH_COPYRIGHT);
635 fth_printf("\\ %s %s\n",
636 FTH_PACKAGE_NAME, fth_version());
637 }
638
639 /*
640 * Load init files if not -Q.
641 */
642 if (!no_init_file) { /* -f FILE */
643 ret = fth_load_global_init_file();
644
645 if (FTH_STRING_P(ret)) {
646 exit_value++;
647 fth_throw(FTH_LOAD_ERROR, "%S", ret);
648 }
649 ret = fth_load_init_file(init_file);
650
651 if (FTH_STRING_P(ret)) {
652 exit_value++;
653 fth_throw(FTH_LOAD_ERROR, "%S", ret);
654 }
655 if (fth_hit_error_p)
656 exit_value = EXIT_FAILURE;
657 }
658 }
659 if (!stay_in_repl || ((exit_value != EXIT_SUCCESS) && die))
660 fth_exit(exit_value);
661
662 /*
663 * Finally, start interactive mode.
664 */
665 fth_repl(argc, argv);
666 return (EXIT_SUCCESS);
667 }
668
669 /*
670 * fth.c ends here
671 */
672