xref: /freebsd/stand/common/interp_forth.c (revision c57c26179033f64c2011a2d2a904ee3fa62e826a)
1 /*-
2  * Copyright (c) 1998 Michael Smith <msmith@freebsd.org>
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 #include <sys/param.h>		/* to pick up __FreeBSD_version */
28 #include <string.h>
29 #include <stand.h>
30 #include "bootstrap.h"
31 #include "ficl.h"
32 
33 INTERP_DEFINE("4th");
34 
35 /* #define BFORTH_DEBUG */
36 
37 #ifdef BFORTH_DEBUG
38 #define	DPRINTF(fmt, args...)	printf("%s: " fmt "\n" , __func__ , ## args)
39 #else
40 #define	DPRINTF(fmt, args...)	((void)0)
41 #endif
42 
43 /*
44  * Eventually, all builtin commands throw codes must be defined
45  * elsewhere, possibly bootstrap.h. For now, just this code, used
46  * just in this file, it is getting defined.
47  */
48 #define BF_PARSE 100
49 
50 /*
51  * FreeBSD loader default dictionary cells
52  */
53 #ifndef	BF_DICTSIZE
54 #define	BF_DICTSIZE	10000
55 #endif
56 
57 /*
58  * BootForth   Interface to Ficl Forth interpreter.
59  */
60 
61 FICL_SYSTEM *bf_sys;
62 FICL_VM	*bf_vm;
63 
64 /*
65  * Shim for taking commands from BF and passing them out to 'standard'
66  * argv/argc command functions.
67  */
68 static void
69 bf_command(FICL_VM *vm)
70 {
71 	char			*name, *line, *tail, *cp;
72 	size_t			len;
73 	struct bootblk_command	**cmdp;
74 	bootblk_cmd_t		*cmd;
75 	int			nstrings, i;
76 	int			argc, result;
77 	char			**argv;
78 
79 	/* Get the name of the current word */
80 	name = vm->runningWord->name;
81 
82 	/* Find our command structure */
83 	cmd = NULL;
84 	SET_FOREACH(cmdp, Xcommand_set) {
85 		if (((*cmdp)->c_name != NULL) && !strcmp(name, (*cmdp)->c_name))
86 			cmd = (*cmdp)->c_fn;
87 	}
88 	if (cmd == NULL)
89 		panic("callout for unknown command '%s'", name);
90 
91 	/* Check whether we have been compiled or are being interpreted */
92 	if (stackPopINT(vm->pStack)) {
93 		/*
94 		 * Get parameters from stack, in the format:
95 		 * an un ... a2 u2 a1 u1 n --
96 		 * Where n is the number of strings, a/u are pairs of
97 		 * address/size for strings, and they will be concatenated
98 		 * in LIFO order.
99 		 */
100 		nstrings = stackPopINT(vm->pStack);
101 		for (i = 0, len = 0; i < nstrings; i++)
102 			len += stackFetch(vm->pStack, i * 2).i + 1;
103 		line = malloc(strlen(name) + len + 1);
104 		strcpy(line, name);
105 
106 		if (nstrings)
107 			for (i = 0; i < nstrings; i++) {
108 				len = stackPopINT(vm->pStack);
109 				cp = stackPopPtr(vm->pStack);
110 				strcat(line, " ");
111 				strncat(line, cp, len);
112 			}
113 	} else {
114 		/* Get remainder of invocation */
115 		tail = vmGetInBuf(vm);
116 		for (cp = tail, len = 0; cp != vm->tib.end && *cp != 0 && *cp != '\n'; cp++, len++)
117 			;
118 
119 		line = malloc(strlen(name) + len + 2);
120 		strcpy(line, name);
121 		if (len > 0) {
122 			strcat(line, " ");
123 			strncat(line, tail, len);
124 			vmUpdateTib(vm, tail + len);
125 		}
126 	}
127 	DPRINTF("cmd '%s'", line);
128 
129 	command_errmsg = command_errbuf;
130 	command_errbuf[0] = 0;
131 	if (!parse(&argc, &argv, line)) {
132 		result = (cmd)(argc, argv);
133 		free(argv);
134 	} else {
135 		result=BF_PARSE;
136 	}
137 
138 	switch (result) {
139 	case CMD_CRIT:
140 		printf("%s\n", command_errmsg);
141 		command_errmsg = NULL;
142 		break;
143 	case CMD_FATAL:
144 		panic("%s", command_errmsg);
145 	}
146 
147 	free(line);
148 	/*
149 	 * If there was error during nested ficlExec(), we may no longer have
150 	 * valid environment to return.  Throw all exceptions from here.
151 	 */
152 	if (result != CMD_OK)
153 		vmThrow(vm, result);
154 
155 	/* This is going to be thrown!!! */
156 	stackPushINT(vm->pStack,result);
157 }
158 
159 /*
160  * Replace a word definition (a builtin command) with another
161  * one that:
162  *
163  *        - Throw error results instead of returning them on the stack
164  *        - Pass a flag indicating whether the word was compiled or is
165  *          being interpreted.
166  *
167  * There is one major problem with builtins that cannot be overcome
168  * in anyway, except by outlawing it. We want builtins to behave
169  * differently depending on whether they have been compiled or they
170  * are being interpreted. Notice that this is *not* the interpreter's
171  * current state. For example:
172  *
173  * : example ls ; immediate
174  * : problem example ;		\ "ls" gets executed while compiling
175  * example			\ "ls" gets executed while interpreting
176  *
177  * Notice that, though the current state is different in the two
178  * invocations of "example", in both cases "ls" has been
179  * *compiled in*, which is what we really want.
180  *
181  * The problem arises when you tick the builtin. For example:
182  *
183  * : example-1 ['] ls postpone literal ; immediate
184  * : example-2 example-1 execute ; immediate
185  * : problem example-2 ;
186  * example-2
187  *
188  * We have no way, when we get EXECUTEd, of knowing what our behavior
189  * should be. Thus, our only alternative is to "outlaw" this. See RFI
190  * 0007, and ANS Forth Standard's appendix D, item 6.7 for a related
191  * problem, concerning compile semantics.
192  *
193  * The problem is compounded by the fact that "' builtin CATCH" is valid
194  * and desirable. The only solution is to create an intermediary word.
195  * For example:
196  *
197  * : my-ls ls ;
198  * : example ['] my-ls catch ;
199  *
200  * So, with the below implementation, here is a summary of the behavior
201  * of builtins:
202  *
203  * ls -l				\ "interpret" behavior, ie,
204  *					\ takes parameters from TIB
205  * : ex-1 s" -l" 1 ls ;			\ "compile" behavior, ie,
206  *					\ takes parameters from the stack
207  * : ex-2 ['] ls catch ; immediate	\ undefined behavior
208  * : ex-3 ['] ls catch ;		\ undefined behavior
209  * ex-2 ex-3				\ "interpret" behavior,
210  *					\ catch works
211  * : ex-4 ex-2 ;			\ "compile" behavior,
212  *					\ catch does not work
213  * : ex-5 ex-3 ; immediate		\ same as ex-2
214  * : ex-6 ex-3 ;			\ same as ex-3
215  * : ex-7 ['] ex-1 catch ;		\ "compile" behavior,
216  *					\ catch works
217  * : ex-8 postpone ls ;	immediate	\ same as ex-2
218  * : ex-9 postpone ls ;			\ same as ex-3
219  *
220  * As the definition below is particularly tricky, and it's side effects
221  * must be well understood by those playing with it, I'll be heavy on
222  * the comments.
223  *
224  * (if you edit this definition, pay attention to trailing spaces after
225  *  each word -- I warned you! :-) )
226  */
227 #define BUILTIN_CONSTRUCTOR						\
228 	": builtin: "							\
229 	">in @ "		/* save the tib index pointer */	\
230 	"' "			/* get next word's xt */		\
231 	"swap >in ! "		/* point again to next word */		\
232 	"create "		/* create a new definition of the next word */ \
233 	", "			/* save previous definition's xt */	\
234 	"immediate "		/* make the new definition an immediate word */ \
235 									\
236 	"does> "		/* Now, the *new* definition will: */	\
237 	"state @ if "		/* if in compiling state: */		\
238 	"1 postpone literal "	/* pass 1 flag to indicate compile */	\
239 	"@ compile, "		/* compile in previous definition */	\
240 	"postpone throw "		/* throw stack-returned result */ \
241 	"else "		/* if in interpreting state: */			\
242 	"0 swap "			/* pass 0 flag to indicate interpret */ \
243 	"@ execute "		/* call previous definition */		\
244 	"throw "			/* throw stack-returned result */ \
245 	"then ; "
246 
247 /*
248  * Initialise the Forth interpreter, create all our commands as words.
249  */
250 void
251 bf_init(void)
252 {
253 	struct bootblk_command	**cmdp;
254 	char create_buf[41];	/* 31 characters-long builtins */
255 	int fd;
256 
257 	bf_sys = ficlInitSystem(BF_DICTSIZE);
258 	bf_vm = ficlNewVM(bf_sys);
259 
260 	/* Put all private definitions in a "builtins" vocabulary */
261 	ficlExec(bf_vm, "vocabulary builtins also builtins definitions");
262 
263 	/* Builtin constructor word  */
264 	ficlExec(bf_vm, BUILTIN_CONSTRUCTOR);
265 
266 	/* make all commands appear as Forth words */
267 	SET_FOREACH(cmdp, Xcommand_set) {
268 		ficlBuild(bf_sys, (char *)(*cmdp)->c_name, bf_command, FW_DEFAULT);
269 		ficlExec(bf_vm, "forth definitions builtins");
270 		sprintf(create_buf, "builtin: %s", (*cmdp)->c_name);
271 		ficlExec(bf_vm, create_buf);
272 		ficlExec(bf_vm, "builtins definitions");
273 	}
274 	ficlExec(bf_vm, "only forth definitions");
275 
276 	/* Export some version numbers so that code can detect the loader/host version */
277 	ficlSetEnv(bf_sys, "FreeBSD_version", __FreeBSD_version);
278 	ficlSetEnv(bf_sys, "loader_version", bootprog_rev);
279 
280 	/* try to load and run init file if present */
281 	if ((fd = open("/boot/boot.4th", O_RDONLY)) != -1) {
282 #ifdef LOADER_VERIEXEC
283 		if (verify_file(fd, "/boot/boot.4th", 0, VE_GUESS, __func__) < 0) {
284 			close(fd);
285 			return;
286 		}
287 #endif
288 		(void)ficlExecFD(bf_vm, fd);
289 		close(fd);
290 	}
291 }
292 
293 /*
294  * Feed a line of user input to the Forth interpreter
295  */
296 static int
297 bf_run(const char *line)
298 {
299 	int		result;
300 
301 	/*
302 	 * ficl would require extensive changes to accept a const char *
303 	 * interface. Instead, cast it away here and hope for the best.
304 	 * We know at the present time the caller for us in the boot
305 	 * forth loader can tolerate the string being modified because
306 	 * the string is passed in here and then not touched again.
307 	 */
308 	result = ficlExec(bf_vm, __DECONST(char *, line));
309 
310 	DPRINTF("ficlExec '%s' = %d", line, result);
311 	switch (result) {
312 	case VM_OUTOFTEXT:
313 	case VM_ABORTQ:
314 	case VM_QUIT:
315 	case VM_ERREXIT:
316 		break;
317 	case VM_USEREXIT:
318 		printf("No where to leave to!\n");
319 		break;
320 	case VM_ABORT:
321 		printf("Aborted!\n");
322 		break;
323 	case BF_PARSE:
324 		printf("Parse error!\n");
325 		break;
326 	default:
327 		if (command_errmsg != NULL) {
328 			printf("%s\n", command_errmsg);
329 			command_errmsg = NULL;
330 		}
331 	}
332 
333 	if (result == VM_USEREXIT)
334 		panic("interpreter exit");
335 	setenv("interpret", bf_vm->state ? "" : "OK", 1);
336 
337 	return (result);
338 }
339 
340 static bool preinit_run = false;
341 
342 void
343 interp_preinit(void)
344 {
345 	if (preinit_run)
346 		return;
347 	setenv("script.lang", "forth", 1);
348 	bf_init();
349 	preinit_run = true;
350 }
351 
352 void
353 interp_init(void)
354 {
355 	/* Read our default configuration. */
356 	interp_include("/boot/loader.rc");
357 }
358 
359 int
360 interp_run(const char *input)
361 {
362 
363 	bf_vm->sourceID.i = 0;
364 	return bf_run(input);
365 }
366 
367 /*
368  * Header prepended to each line. The text immediately follows the header.
369  * We try to make this short in order to save memory -- the loader has
370  * limited memory available, and some of the forth files are very long.
371  */
372 struct includeline
373 {
374 	struct includeline	*next;
375 	char			text[0];
376 };
377 
378 int
379 interp_include(const char *filename)
380 {
381 	struct includeline	*script, *se, *sp;
382 	char			input[256];			/* big enough? */
383 	int			res;
384 	char			*cp;
385 	int			prevsrcid, fd, line;
386 
387 	if (((fd = open(filename, O_RDONLY)) == -1)) {
388 		snprintf(command_errbuf, sizeof(command_errbuf),
389 		    "can't open '%s': %s", filename, strerror(errno));
390 		return(CMD_ERROR);
391 	}
392 
393 #ifdef LOADER_VERIEXEC
394 	if (verify_file(fd, filename, 0, VE_GUESS, __func__) < 0) {
395 		close(fd);
396 		sprintf(command_errbuf,"can't verify '%s'", filename);
397 		return(CMD_ERROR);
398 	}
399 #endif
400 	/*
401 	 * Read the script into memory.
402 	 */
403 	script = se = NULL;
404 	line = 0;
405 
406 	while (fgetstr(input, sizeof(input), fd) >= 0) {
407 		line++;
408 		cp = input;
409 		/* Allocate script line structure and copy line, flags */
410 		if (*cp == '\0')
411 			continue;	/* ignore empty line, save memory */
412 		sp = malloc(sizeof(struct includeline) + strlen(cp) + 1);
413 		/* On malloc failure (it happens!), free as much as possible and exit */
414 		if (sp == NULL) {
415 			while (script != NULL) {
416 				se = script;
417 				script = script->next;
418 				free(se);
419 			}
420 			snprintf(command_errbuf, sizeof(command_errbuf),
421 			    "file '%s' line %d: memory allocation failure - aborting",
422 			    filename, line);
423 			close(fd);
424 			return (CMD_ERROR);
425 		}
426 		strcpy(sp->text, cp);
427 		sp->next = NULL;
428 
429 		if (script == NULL) {
430 			script = sp;
431 		} else {
432 			se->next = sp;
433 		}
434 		se = sp;
435 	}
436 	close(fd);
437 
438 	/*
439 	 * Execute the script
440 	 */
441 	prevsrcid = bf_vm->sourceID.i;
442 	bf_vm->sourceID.i = fd;
443 	res = CMD_OK;
444 	for (sp = script; sp != NULL; sp = sp->next) {
445 		res = bf_run(sp->text);
446 		if (res != VM_OUTOFTEXT) {
447 			snprintf(command_errbuf, sizeof(command_errbuf),
448 			    "Error while including %s, in the line:\n%s",
449 			    filename, sp->text);
450 			res = CMD_ERROR;
451 			break;
452 		} else
453 			res = CMD_OK;
454 	}
455 	bf_vm->sourceID.i = prevsrcid;
456 
457 	while (script != NULL) {
458 		se = script;
459 		script = script->next;
460 		free(se);
461 	}
462 	return(res);
463 }
464