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/cdefs.h>
28
29 #include <sys/param.h> /* to pick up __FreeBSD_version */
30 #include <string.h>
31 #include <stand.h>
32 #include "bootstrap.h"
33 #include "ficl.h"
34
35 extern unsigned bootprog_rev;
36 INTERP_DEFINE("4th");
37
38 /* #define BFORTH_DEBUG */
39
40 #ifdef BFORTH_DEBUG
41 #define DPRINTF(fmt, args...) printf("%s: " fmt "\n", __func__, ## args)
42 #else
43 #define DPRINTF(fmt, args...) ((void)0)
44 #endif
45
46 /*
47 * Eventually, all builtin commands throw codes must be defined
48 * elsewhere, possibly bootstrap.h. For now, just this code, used
49 * just in this file, it is getting defined.
50 */
51 #define BF_PARSE 100
52
53 /*
54 * FreeBSD loader default dictionary cells
55 */
56 #ifndef BF_DICTSIZE
57 #define BF_DICTSIZE 30000
58 #endif
59
60 /*
61 * BootForth Interface to Ficl Forth interpreter.
62 */
63
64 ficlSystemInformation *fsi;
65 ficlSystem *bf_sys;
66 ficlVm *bf_vm;
67
68 /*
69 * Shim for taking commands from BF and passing them out to 'standard'
70 * argv/argc command functions.
71 */
72 static void
bf_command(ficlVm * vm)73 bf_command(ficlVm *vm)
74 {
75 char *name, *line, *tail, *cp;
76 size_t len;
77 struct bootblk_command **cmdp;
78 bootblk_cmd_t *cmd;
79 int nstrings, i;
80 int argc, result;
81 char **argv;
82
83 /* Get the name of the current word */
84 name = vm->runningWord->name;
85
86 /* Find our command structure */
87 cmd = NULL;
88 SET_FOREACH(cmdp, Xcommand_set) {
89 if (((*cmdp)->c_name != NULL) &&
90 strcmp(name, (*cmdp)->c_name) == 0)
91 cmd = (*cmdp)->c_fn;
92 }
93 if (cmd == NULL)
94 panic("callout for unknown command '%s'", name);
95
96 /* Check whether we have been compiled or are being interpreted */
97 if (ficlStackPopInteger(ficlVmGetDataStack(vm))) {
98 /*
99 * Get parameters from stack, in the format:
100 * an un ... a2 u2 a1 u1 n --
101 * Where n is the number of strings, a/u are pairs of
102 * address/size for strings, and they will be concatenated
103 * in LIFO order.
104 */
105 nstrings = ficlStackPopInteger(ficlVmGetDataStack(vm));
106 for (i = 0, len = 0; i < nstrings; i++) {
107 ficlStack *stack = ficlVmGetDataStack(vm);
108 len += ficlStackFetch(stack, i * 2).i + 1;
109 }
110 line = malloc(strlen(name) + len + 1);
111 (void) strcpy(line, name);
112
113 if (nstrings)
114 for (i = 0; i < nstrings; i++) {
115 ficlStack *stack = ficlVmGetDataStack(vm);
116
117 len = ficlStackPopInteger(stack);
118 cp = ficlStackPopPointer(stack);
119 (void) strcat(line, " ");
120 (void) strncat(line, cp, len);
121 }
122 } else {
123 /* Get remainder of invocation */
124 tail = ficlVmGetInBuf(vm);
125
126 len = 0;
127 cp = tail;
128 for (; cp != vm->tib.end && *cp != 0 && *cp != '\n'; cp++)
129 len++;
130
131 line = malloc(strlen(name) + len + 2);
132 (void) strcpy(line, name);
133 if (len > 0) {
134 (void) strcat(line, " ");
135 (void) strncat(line, tail, len);
136 ficlVmUpdateTib(vm, tail + len);
137 }
138 }
139 DPRINTF("cmd '%s'", line);
140
141 command_errmsg = command_errbuf;
142 command_errbuf[0] = 0;
143 if (!parse(&argc, &argv, line)) {
144 result = (cmd)(argc, argv);
145 free(argv);
146 } else {
147 result = BF_PARSE;
148 }
149
150 switch (result) {
151 case CMD_CRIT:
152 printf("%s\n", command_errmsg);
153 command_errmsg = NULL;
154 break;
155 case CMD_FATAL:
156 panic("%s", command_errmsg);
157 }
158
159 free(line);
160 /*
161 * If there was error during nested ficlExec(), we may no longer have
162 * valid environment to return. Throw all exceptions from here.
163 */
164 if (result != CMD_OK)
165 ficlVmThrow(vm, result);
166
167 /* This is going to be thrown!!! */
168 ficlStackPushInteger(ficlVmGetDataStack(vm), result);
169 }
170
171 /*
172 * Replace a word definition (a builtin command) with another
173 * one that:
174 *
175 * - Throw error results instead of returning them on the stack
176 * - Pass a flag indicating whether the word was compiled or is
177 * being interpreted.
178 *
179 * There is one major problem with builtins that cannot be overcome
180 * in anyway, except by outlawing it. We want builtins to behave
181 * differently depending on whether they have been compiled or they
182 * are being interpreted. Notice that this is *not* the interpreter's
183 * current state. For example:
184 *
185 * : example ls ; immediate
186 * : problem example ; \ "ls" gets executed while compiling
187 * example \ "ls" gets executed while interpreting
188 *
189 * Notice that, though the current state is different in the two
190 * invocations of "example", in both cases "ls" has been
191 * *compiled in*, which is what we really want.
192 *
193 * The problem arises when you tick the builtin. For example:
194 *
195 * : example-1 ['] ls postpone literal ; immediate
196 * : example-2 example-1 execute ; immediate
197 * : problem example-2 ;
198 * example-2
199 *
200 * We have no way, when we get EXECUTEd, of knowing what our behavior
201 * should be. Thus, our only alternative is to "outlaw" this. See RFI
202 * 0007, and ANS Forth Standard's appendix D, item 6.7 for a related
203 * problem, concerning compile semantics.
204 *
205 * The problem is compounded by the fact that "' builtin CATCH" is valid
206 * and desirable. The only solution is to create an intermediary word.
207 * For example:
208 *
209 * : my-ls ls ;
210 * : example ['] my-ls catch ;
211 *
212 * So, with the below implementation, here is a summary of the behavior
213 * of builtins:
214 *
215 * ls -l \ "interpret" behavior, ie,
216 * \ takes parameters from TIB
217 * : ex-1 s" -l" 1 ls ; \ "compile" behavior, ie,
218 * \ takes parameters from the stack
219 * : ex-2 ['] ls catch ; immediate \ undefined behavior
220 * : ex-3 ['] ls catch ; \ undefined behavior
221 * ex-2 ex-3 \ "interpret" behavior,
222 * \ catch works
223 * : ex-4 ex-2 ; \ "compile" behavior,
224 * \ catch does not work
225 * : ex-5 ex-3 ; immediate \ same as ex-2
226 * : ex-6 ex-3 ; \ same as ex-3
227 * : ex-7 ['] ex-1 catch ; \ "compile" behavior,
228 * \ catch works
229 * : ex-8 postpone ls ; immediate \ same as ex-2
230 * : ex-9 postpone ls ; \ same as ex-3
231 *
232 * As the definition below is particularly tricky, and it's side effects
233 * must be well understood by those playing with it, I'll be heavy on
234 * the comments.
235 *
236 * (if you edit this definition, pay attention to trailing spaces after
237 * each word -- I warned you! :-) )
238 */
239 #define BUILTIN_CONSTRUCTOR \
240 ": builtin: " \
241 ">in @ " /* save the tib index pointer */ \
242 "' " /* get next word's xt */ \
243 "swap >in ! " /* point again to next word */ \
244 "create " /* create a new definition of the next word */ \
245 ", " /* save previous definition's xt */ \
246 "immediate " /* make the new definition an immediate word */ \
247 \
248 "does> " /* Now, the *new* definition will: */ \
249 "state @ if " /* if in compiling state: */ \
250 "1 postpone literal " /* pass 1 flag to indicate compile */ \
251 "@ compile, " /* compile in previous definition */ \
252 "postpone throw " /* throw stack-returned result */ \
253 "else " /* if in interpreting state: */ \
254 "0 swap " /* pass 0 flag to indicate interpret */ \
255 "@ execute " /* call previous definition */ \
256 "throw " /* throw stack-returned result */ \
257 "then ; "
258
259 /*
260 * Initialise the Forth interpreter, create all our commands as words.
261 */
262 void
bf_init(char * rc)263 bf_init(char *rc)
264 {
265 struct bootblk_command **cmdp;
266 char create_buf[41]; /* 31 characters-long builtins */
267 int fd, rv;
268 ficlDictionary *dict;
269 ficlDictionary *env;
270
271 fsi = malloc(sizeof (ficlSystemInformation));
272 ficlSystemInformationInitialize(fsi);
273 fsi->dictionarySize = BF_DICTSIZE;
274
275 bf_sys = ficlSystemCreate(fsi);
276 bf_vm = ficlSystemCreateVm(bf_sys);
277
278 /* Put all private definitions in a "builtins" vocabulary */
279 rv = ficlVmEvaluate(bf_vm,
280 "vocabulary builtins also builtins definitions");
281 if (rv != FICL_VM_STATUS_OUT_OF_TEXT) {
282 panic("error interpreting forth: %d", rv);
283 }
284
285 /* Builtin constructor word */
286 rv = ficlVmEvaluate(bf_vm, BUILTIN_CONSTRUCTOR);
287 if (rv != FICL_VM_STATUS_OUT_OF_TEXT) {
288 panic("error interpreting forth: %d", rv);
289 }
290
291 /* make all commands appear as Forth words */
292 dict = ficlSystemGetDictionary(bf_sys);
293 SET_FOREACH(cmdp, Xcommand_set) {
294 (void) ficlDictionaryAppendPrimitive(dict,
295 (char *)(*cmdp)->c_name, bf_command, FICL_WORD_DEFAULT);
296 rv = ficlVmEvaluate(bf_vm, "forth definitions builtins");
297 if (rv != FICL_VM_STATUS_OUT_OF_TEXT) {
298 panic("error interpreting forth: %d", rv);
299 }
300 (void) snprintf(create_buf, sizeof (create_buf),
301 "builtin: %s", (*cmdp)->c_name);
302 rv = ficlVmEvaluate(bf_vm, create_buf);
303 if (rv != FICL_VM_STATUS_OUT_OF_TEXT) {
304 panic("error interpreting forth: %d", rv);
305 }
306 rv = ficlVmEvaluate(bf_vm, "builtins definitions");
307 if (rv != FICL_VM_STATUS_OUT_OF_TEXT) {
308 panic("error interpreting forth: %d", rv);
309 }
310 }
311 rv = ficlVmEvaluate(bf_vm, "only forth definitions");
312 if (rv != FICL_VM_STATUS_OUT_OF_TEXT) {
313 panic("error interpreting forth: %d", rv);
314 }
315
316 /*
317 * Export some version numbers so that code can detect the loader/host
318 * version
319 */
320 env = ficlSystemGetEnvironment(bf_sys);
321 (void) ficlDictionarySetConstant(env, "loader_version", bootprog_rev);
322
323 /* try to load and run init file if present */
324 if (rc == NULL)
325 rc = "/boot/forth/boot.4th";
326 if (*rc != '\0') {
327 fd = open(rc, O_RDONLY);
328 if (fd != -1) {
329 (void) ficlExecFD(bf_vm, fd);
330 (void) close(fd);
331 }
332 }
333 }
334
335 /*
336 * Feed a line of user input to the Forth interpreter
337 */
338 int
bf_run(char * line)339 bf_run(char *line)
340 {
341 int result;
342 ficlString s;
343
344 FICL_STRING_SET_FROM_CSTRING(s, line);
345 result = ficlVmExecuteString(bf_vm, s);
346
347 DPRINTF("ficlExec '%s' = %d", line, result);
348 switch (result) {
349 case FICL_VM_STATUS_OUT_OF_TEXT:
350 case FICL_VM_STATUS_ABORTQ:
351 case FICL_VM_STATUS_QUIT:
352 case FICL_VM_STATUS_ERROR_EXIT:
353 break;
354 case FICL_VM_STATUS_USER_EXIT:
355 printf("No where to leave to!\n");
356 break;
357 case FICL_VM_STATUS_ABORT:
358 printf("Aborted!\n");
359 break;
360 case BF_PARSE:
361 printf("Parse error!\n");
362 break;
363 default:
364 if (command_errmsg != NULL) {
365 printf("%s\n", command_errmsg);
366 command_errmsg = NULL;
367 }
368 }
369
370 /* bye is same as reboot and will behave depending on platform */
371 if (result == FICL_VM_STATUS_USER_EXIT)
372 (void) bf_run("reboot");
373 (void) setenv("interpret", bf_vm->state ? "" : "ok", 1);
374
375 return (result);
376 }
377