diff options
Diffstat (limited to 'stand/common/interp_forth.c')
| -rw-r--r-- | stand/common/interp_forth.c | 332 |
1 files changed, 332 insertions, 0 deletions
diff --git a/stand/common/interp_forth.c b/stand/common/interp_forth.c new file mode 100644 index 0000000000000..a3b77769d38a6 --- /dev/null +++ b/stand/common/interp_forth.c @@ -0,0 +1,332 @@ +/*- + * Copyright (c) 1998 Michael Smith <msmith@freebsd.org> + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND + * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE + * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + * SUCH DAMAGE. + */ + +#include <sys/cdefs.h> +__FBSDID("$FreeBSD$"); + +#include <sys/param.h> /* to pick up __FreeBSD_version */ +#include <string.h> +#include <stand.h> +#include "bootstrap.h" +#include "ficl.h" + +extern unsigned bootprog_rev; + +/* #define BFORTH_DEBUG */ + +#ifdef BFORTH_DEBUG +#define DEBUG(fmt, args...) printf("%s: " fmt "\n" , __func__ , ## args) +#else +#define DEBUG(fmt, args...) +#endif + +/* + * Eventually, all builtin commands throw codes must be defined + * elsewhere, possibly bootstrap.h. For now, just this code, used + * just in this file, it is getting defined. + */ +#define BF_PARSE 100 + +/* + * FreeBSD loader default dictionary cells + */ +#ifndef BF_DICTSIZE +#define BF_DICTSIZE 10000 +#endif + +/* + * BootForth Interface to Ficl Forth interpreter. + */ + +FICL_SYSTEM *bf_sys; +FICL_VM *bf_vm; + +/* + * Shim for taking commands from BF and passing them out to 'standard' + * argv/argc command functions. + */ +static void +bf_command(FICL_VM *vm) +{ + char *name, *line, *tail, *cp; + size_t len; + struct bootblk_command **cmdp; + bootblk_cmd_t *cmd; + int nstrings, i; + int argc, result; + char **argv; + + /* Get the name of the current word */ + name = vm->runningWord->name; + + /* Find our command structure */ + cmd = NULL; + SET_FOREACH(cmdp, Xcommand_set) { + if (((*cmdp)->c_name != NULL) && !strcmp(name, (*cmdp)->c_name)) + cmd = (*cmdp)->c_fn; + } + if (cmd == NULL) + panic("callout for unknown command '%s'", name); + + /* Check whether we have been compiled or are being interpreted */ + if (stackPopINT(vm->pStack)) { + /* + * Get parameters from stack, in the format: + * an un ... a2 u2 a1 u1 n -- + * Where n is the number of strings, a/u are pairs of + * address/size for strings, and they will be concatenated + * in LIFO order. + */ + nstrings = stackPopINT(vm->pStack); + for (i = 0, len = 0; i < nstrings; i++) + len += stackFetch(vm->pStack, i * 2).i + 1; + line = malloc(strlen(name) + len + 1); + strcpy(line, name); + + if (nstrings) + for (i = 0; i < nstrings; i++) { + len = stackPopINT(vm->pStack); + cp = stackPopPtr(vm->pStack); + strcat(line, " "); + strncat(line, cp, len); + } + } else { + /* Get remainder of invocation */ + tail = vmGetInBuf(vm); + for (cp = tail, len = 0; cp != vm->tib.end && *cp != 0 && *cp != '\n'; cp++, len++) + ; + + line = malloc(strlen(name) + len + 2); + strcpy(line, name); + if (len > 0) { + strcat(line, " "); + strncat(line, tail, len); + vmUpdateTib(vm, tail + len); + } + } + DEBUG("cmd '%s'", line); + + command_errmsg = command_errbuf; + command_errbuf[0] = 0; + if (!parse(&argc, &argv, line)) { + result = (cmd)(argc, argv); + free(argv); + } else { + result=BF_PARSE; + } + + switch (result) { + case CMD_CRIT: + printf("%s\n", command_errmsg); + break; + case CMD_FATAL: + panic("%s\n", command_errmsg); + } + + free(line); + /* + * If there was error during nested ficlExec(), we may no longer have + * valid environment to return. Throw all exceptions from here. + */ + if (result != CMD_OK) + vmThrow(vm, result); + + /* This is going to be thrown!!! */ + stackPushINT(vm->pStack,result); +} + +/* + * Replace a word definition (a builtin command) with another + * one that: + * + * - Throw error results instead of returning them on the stack + * - Pass a flag indicating whether the word was compiled or is + * being interpreted. + * + * There is one major problem with builtins that cannot be overcome + * in anyway, except by outlawing it. We want builtins to behave + * differently depending on whether they have been compiled or they + * are being interpreted. Notice that this is *not* the interpreter's + * current state. For example: + * + * : example ls ; immediate + * : problem example ; \ "ls" gets executed while compiling + * example \ "ls" gets executed while interpreting + * + * Notice that, though the current state is different in the two + * invocations of "example", in both cases "ls" has been + * *compiled in*, which is what we really want. + * + * The problem arises when you tick the builtin. For example: + * + * : example-1 ['] ls postpone literal ; immediate + * : example-2 example-1 execute ; immediate + * : problem example-2 ; + * example-2 + * + * We have no way, when we get EXECUTEd, of knowing what our behavior + * should be. Thus, our only alternative is to "outlaw" this. See RFI + * 0007, and ANS Forth Standard's appendix D, item 6.7 for a related + * problem, concerning compile semantics. + * + * The problem is compounded by the fact that "' builtin CATCH" is valid + * and desirable. The only solution is to create an intermediary word. + * For example: + * + * : my-ls ls ; + * : example ['] my-ls catch ; + * + * So, with the below implementation, here is a summary of the behavior + * of builtins: + * + * ls -l \ "interpret" behavior, ie, + * \ takes parameters from TIB + * : ex-1 s" -l" 1 ls ; \ "compile" behavior, ie, + * \ takes parameters from the stack + * : ex-2 ['] ls catch ; immediate \ undefined behavior + * : ex-3 ['] ls catch ; \ undefined behavior + * ex-2 ex-3 \ "interpret" behavior, + * \ catch works + * : ex-4 ex-2 ; \ "compile" behavior, + * \ catch does not work + * : ex-5 ex-3 ; immediate \ same as ex-2 + * : ex-6 ex-3 ; \ same as ex-3 + * : ex-7 ['] ex-1 catch ; \ "compile" behavior, + * \ catch works + * : ex-8 postpone ls ; immediate \ same as ex-2 + * : ex-9 postpone ls ; \ same as ex-3 + * + * As the definition below is particularly tricky, and it's side effects + * must be well understood by those playing with it, I'll be heavy on + * the comments. + * + * (if you edit this definition, pay attention to trailing spaces after + * each word -- I warned you! :-) ) + */ +#define BUILTIN_CONSTRUCTOR \ +": builtin: " \ + ">in @ " /* save the tib index pointer */ \ + "' " /* get next word's xt */ \ + "swap >in ! " /* point again to next word */ \ + "create " /* create a new definition of the next word */ \ + ", " /* save previous definition's xt */ \ + "immediate " /* make the new definition an immediate word */ \ + \ + "does> " /* Now, the *new* definition will: */ \ + "state @ if " /* if in compiling state: */ \ + "1 postpone literal " /* pass 1 flag to indicate compile */ \ + "@ compile, " /* compile in previous definition */ \ + "postpone throw " /* throw stack-returned result */ \ + "else " /* if in interpreting state: */ \ + "0 swap " /* pass 0 flag to indicate interpret */ \ + "@ execute " /* call previous definition */ \ + "throw " /* throw stack-returned result */ \ + "then ; " + +/* + * Initialise the Forth interpreter, create all our commands as words. + */ +void +bf_init(const char *rc) +{ + struct bootblk_command **cmdp; + char create_buf[41]; /* 31 characters-long builtins */ + int fd; + + bf_sys = ficlInitSystem(BF_DICTSIZE); + bf_vm = ficlNewVM(bf_sys); + + /* Put all private definitions in a "builtins" vocabulary */ + ficlExec(bf_vm, "vocabulary builtins also builtins definitions"); + + /* Builtin constructor word */ + ficlExec(bf_vm, BUILTIN_CONSTRUCTOR); + + /* make all commands appear as Forth words */ + SET_FOREACH(cmdp, Xcommand_set) { + ficlBuild(bf_sys, (char *)(*cmdp)->c_name, bf_command, FW_DEFAULT); + ficlExec(bf_vm, "forth definitions builtins"); + sprintf(create_buf, "builtin: %s", (*cmdp)->c_name); + ficlExec(bf_vm, create_buf); + ficlExec(bf_vm, "builtins definitions"); + } + ficlExec(bf_vm, "only forth definitions"); + + /* Export some version numbers so that code can detect the loader/host version */ + ficlSetEnv(bf_sys, "FreeBSD_version", __FreeBSD_version); + ficlSetEnv(bf_sys, "loader_version", bootprog_rev); + + /* try to load and run init file if present */ + if (rc == NULL) + rc = "/boot/boot.4th"; + if (*rc != '\0') { + fd = open(rc, O_RDONLY); + if (fd != -1) { + (void)ficlExecFD(bf_vm, fd); + close(fd); + } + } +} + +/* + * Feed a line of user input to the Forth interpreter + */ +int +bf_run(char *line) +{ + int result; + + result = ficlExec(bf_vm, line); + + DEBUG("ficlExec '%s' = %d", line, result); + switch (result) { + case VM_OUTOFTEXT: + case VM_ABORTQ: + case VM_QUIT: + case VM_ERREXIT: + break; + case VM_USEREXIT: + printf("No where to leave to!\n"); + break; + case VM_ABORT: + printf("Aborted!\n"); + break; + case BF_PARSE: + printf("Parse error!\n"); + break; + default: + if (command_errmsg != NULL) { + printf("%s\n", command_errmsg); + command_errmsg = NULL; + } + } + + if (result == VM_USEREXIT) + panic("interpreter exit"); + setenv("interpret", bf_vm->state ? "" : "OK", 1); + + return (result); +} |