File:  [DragonFly] / src / sys / boot / common / interp_forth.c
Revision 1.4: download - view: text, annotated - select for diffs
Sun Jan 25 22:50:20 2004 UTC (10 years, 10 months ago) by drhodus
Branches: MAIN
CVS tags: HEAD, DragonFly_Stable, DragonFly_Snap29Sep2004, DragonFly_Snap13Sep2004, DragonFly_RELEASE_2_0_Slip, DragonFly_RELEASE_2_0, DragonFly_RELEASE_1_8_Slip, DragonFly_RELEASE_1_8, DragonFly_RELEASE_1_6_Slip, DragonFly_RELEASE_1_6, DragonFly_RELEASE_1_4_Slip, DragonFly_RELEASE_1_4, DragonFly_RELEASE_1_2_Slip, DragonFly_RELEASE_1_2, DragonFly_RELEASE_1_12_Slip, DragonFly_RELEASE_1_12, DragonFly_RELEASE_1_10_Slip, DragonFly_RELEASE_1_10, DragonFly_Preview, DragonFly_1_0_REL, DragonFly_1_0_RC1, DragonFly_1_0A_REL
*	DragonFly<-FreeBSD name change in boot loader code.

    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:  * $FreeBSD: src/sys/boot/common/interp_forth.c,v 1.23 2003/08/25 23:30:41 obrien Exp $
   27:  * $DragonFly: src/sys/boot/common/interp_forth.c,v 1.4 2004/01/25 22:50:20 drhodus Exp $
   28:  */
   29: 
   30: #include <sys/param.h>		/* to pick up __DragonFly_version */
   31: #include <string.h>
   32: #include <stand.h>
   33: #include "bootstrap.h"
   34: #include "ficl.h"
   35: 
   36: extern char bootprog_rev[];
   37: 
   38: /* #define BFORTH_DEBUG */
   39: 
   40: #ifdef BFORTH_DEBUG
   41: # define DEBUG(fmt, args...)	printf("%s: " fmt "\n" , __func__ , ## args)
   42: #else
   43: # define DEBUG(fmt, args...)
   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:  * BootForth   Interface to Ficl Forth interpreter.
   55:  */
   56: 
   57: FICL_SYSTEM *bf_sys;
   58: FICL_VM	*bf_vm;
   59: FICL_WORD *pInterp;
   60: 
   61: /*
   62:  * Shim for taking commands from BF and passing them out to 'standard'
   63:  * argv/argc command functions.
   64:  */
   65: static void
   66: bf_command(FICL_VM *vm)
   67: {
   68:     char			*name, *line, *tail, *cp;
   69:     size_t			len;
   70:     struct bootblk_command	**cmdp;
   71:     bootblk_cmd_t		*cmd;
   72:     int				nstrings, i;
   73:     int				argc, result;
   74:     char			**argv;
   75: 
   76:     /* Get the name of the current word */
   77:     name = vm->runningWord->name;
   78:     
   79:     /* Find our command structure */
   80:     cmd = NULL;
   81:     SET_FOREACH(cmdp, Xcommand_set) {
   82: 	if (((*cmdp)->c_name != NULL) && !strcmp(name, (*cmdp)->c_name))
   83: 	    cmd = (*cmdp)->c_fn;
   84:     }
   85:     if (cmd == NULL)
   86: 	panic("callout for unknown command '%s'", name);
   87:    
   88:     /* Check whether we have been compiled or are being interpreted */
   89:     if (stackPopINT(vm->pStack)) {
   90: 	/*
   91: 	 * Get parameters from stack, in the format:
   92: 	 * an un ... a2 u2 a1 u1 n --
   93: 	 * Where n is the number of strings, a/u are pairs of
   94: 	 * address/size for strings, and they will be concatenated
   95: 	 * in LIFO order.
   96: 	 */
   97: 	nstrings = stackPopINT(vm->pStack);
   98: 	for (i = 0, len = 0; i < nstrings; i++)
   99: 	    len += stackFetch(vm->pStack, i * 2).i + 1;
  100: 	line = malloc(strlen(name) + len + 1);
  101: 	strcpy(line, name);
  102: 
  103: 	if (nstrings)
  104: 	    for (i = 0; i < nstrings; i++) {
  105: 		len = stackPopINT(vm->pStack);
  106: 		cp = stackPopPtr(vm->pStack);
  107: 		strcat(line, " ");
  108: 		strncat(line, cp, len);
  109: 	    }
  110:     } else {
  111: 	/* Get remainder of invocation */
  112: 	tail = vmGetInBuf(vm);
  113: 	for (cp = tail, len = 0; cp != vm->tib.end && *cp != 0 && *cp != '\n'; cp++, len++)
  114: 	    ;
  115:     
  116: 	line = malloc(strlen(name) + len + 2);
  117: 	strcpy(line, name);
  118: 	if (len > 0) {
  119: 	    strcat(line, " ");
  120: 	    strncat(line, tail, len);
  121: 	    vmUpdateTib(vm, tail + len);
  122: 	}
  123:     }
  124:     DEBUG("cmd '%s'", line);
  125:     
  126:     command_errmsg = command_errbuf;
  127:     command_errbuf[0] = 0;
  128:     if (!parse(&argc, &argv, line)) {
  129: 	result = (cmd)(argc, argv);
  130: 	free(argv);
  131:     } else {
  132: 	result=BF_PARSE;
  133:     }
  134:     free(line);
  135:     /* This is going to be thrown!!! */
  136:     stackPushINT(vm->pStack,result);
  137: }
  138: 
  139: /*
  140:  * Replace a word definition (a builtin command) with another
  141:  * one that:
  142:  *
  143:  *        - Throw error results instead of returning them on the stack
  144:  *        - Pass a flag indicating whether the word was compiled or is
  145:  *          being interpreted.
  146:  *
  147:  * There is one major problem with builtins that cannot be overcome
  148:  * in anyway, except by outlawing it. We want builtins to behave
  149:  * differently depending on whether they have been compiled or they
  150:  * are being interpreted. Notice that this is *not* the interpreter's
  151:  * current state. For example:
  152:  *
  153:  * : example ls ; immediate
  154:  * : problem example ;		\ "ls" gets executed while compiling
  155:  * example			\ "ls" gets executed while interpreting
  156:  *
  157:  * Notice that, though the current state is different in the two
  158:  * invocations of "example", in both cases "ls" has been
  159:  * *compiled in*, which is what we really want.
  160:  *
  161:  * The problem arises when you tick the builtin. For example:
  162:  *
  163:  * : example-1 ['] ls postpone literal ; immediate
  164:  * : example-2 example-1 execute ; immediate
  165:  * : problem example-2 ;
  166:  * example-2
  167:  *
  168:  * We have no way, when we get EXECUTEd, of knowing what our behavior
  169:  * should be. Thus, our only alternative is to "outlaw" this. See RFI
  170:  * 0007, and ANS Forth Standard's appendix D, item 6.7 for a related
  171:  * problem, concerning compile semantics.
  172:  *
  173:  * The problem is compounded by the fact that "' builtin CATCH" is valid
  174:  * and desirable. The only solution is to create an intermediary word.
  175:  * For example:
  176:  *
  177:  * : my-ls ls ;
  178:  * : example ['] my-ls catch ;
  179:  *
  180:  * So, with the below implementation, here is a summary of the behavior
  181:  * of builtins:
  182:  *
  183:  * ls -l				\ "interpret" behavior, ie,
  184:  *					\ takes parameters from TIB
  185:  * : ex-1 s" -l" 1 ls ;			\ "compile" behavior, ie,
  186:  *					\ takes parameters from the stack
  187:  * : ex-2 ['] ls catch ; immediate	\ undefined behavior
  188:  * : ex-3 ['] ls catch ;		\ undefined behavior
  189:  * ex-2 ex-3				\ "interpret" behavior,
  190:  *					\ catch works
  191:  * : ex-4 ex-2 ;			\ "compile" behavior,
  192:  *					\ catch does not work
  193:  * : ex-5 ex-3 ; immediate		\ same as ex-2
  194:  * : ex-6 ex-3 ;			\ same as ex-3
  195:  * : ex-7 ['] ex-1 catch ;		\ "compile" behavior,
  196:  *					\ catch works
  197:  * : ex-8 postpone ls ;	immediate	\ same as ex-2
  198:  * : ex-9 postpone ls ;			\ same as ex-3
  199:  *
  200:  * As the definition below is particularly tricky, and it's side effects
  201:  * must be well understood by those playing with it, I'll be heavy on
  202:  * the comments.
  203:  *
  204:  * (if you edit this definition, pay attention to trailing spaces after
  205:  *  each word -- I warned you! :-) )
  206:  */
  207: #define BUILTIN_CONSTRUCTOR \
  208: ": builtin: "		\
  209:   ">in @ "		/* save the tib index pointer */ \
  210:   "' "			/* get next word's xt */ \
  211:   "swap >in ! "		/* point again to next word */ \
  212:   "create "		/* create a new definition of the next word */ \
  213:   ", "			/* save previous definition's xt */ \
  214:   "immediate "		/* make the new definition an immediate word */ \
  215: 			\
  216:   "does> "		/* Now, the *new* definition will: */ \
  217:   "state @ if "		/* if in compiling state: */ \
  218:     "1 postpone literal "	/* pass 1 flag to indicate compile */ \
  219:     "@ compile, "		/* compile in previous definition */ \
  220:     "postpone throw "		/* throw stack-returned result */ \
  221:   "else "		/* if in interpreting state: */ \
  222:     "0 swap "			/* pass 0 flag to indicate interpret */ \
  223:     "@ execute "		/* call previous definition */ \
  224:     "throw "			/* throw stack-returned result */ \
  225:   "then ; "
  226: 
  227: /*
  228:  * Initialise the Forth interpreter, create all our commands as words.
  229:  */
  230: void
  231: bf_init(void)
  232: {
  233:     struct bootblk_command	**cmdp;
  234:     char create_buf[41];	/* 31 characters-long builtins */
  235:     int fd;
  236:    
  237:     bf_sys = ficlInitSystem(10000);	/* Default dictionary ~4000 cells */
  238:     bf_vm = ficlNewVM(bf_sys);
  239: 
  240:     /* Put all private definitions in a "builtins" vocabulary */
  241:     ficlExec(bf_vm, "vocabulary builtins also builtins definitions");
  242: 
  243:     /* Builtin constructor word  */
  244:     ficlExec(bf_vm, BUILTIN_CONSTRUCTOR);
  245: 
  246:     /* make all commands appear as Forth words */
  247:     SET_FOREACH(cmdp, Xcommand_set) {
  248: 	ficlBuild(bf_sys, (char *)(*cmdp)->c_name, bf_command, FW_DEFAULT);
  249: 	ficlExec(bf_vm, "forth definitions builtins");
  250: 	sprintf(create_buf, "builtin: %s", (*cmdp)->c_name);
  251: 	ficlExec(bf_vm, create_buf);
  252: 	ficlExec(bf_vm, "builtins definitions");
  253:     }
  254:     ficlExec(bf_vm, "only forth definitions");
  255: 
  256:     /* Export some version numbers so that code can detect the loader/host version */
  257:     ficlSetEnv(bf_sys, "DragonFly_version", __DragonFly_version);
  258:     ficlSetEnv(bf_sys, "loader_version", 
  259: 	       (bootprog_rev[0] - '0') * 10 + (bootprog_rev[2] - '0'));
  260: 
  261:     /* try to load and run init file if present */
  262:     if ((fd = open("/boot/boot.4th", O_RDONLY)) != -1) {
  263: 	(void)ficlExecFD(bf_vm, fd);
  264: 	close(fd);
  265:     }
  266: 
  267:     /* Do this last, so /boot/boot.4th can change it */
  268:     pInterp = ficlLookup(bf_sys, "interpret");
  269: }
  270: 
  271: /*
  272:  * Feed a line of user input to the Forth interpreter
  273:  */
  274: int
  275: bf_run(char *line)
  276: {
  277:     int		result;
  278: 
  279:     result = ficlExec(bf_vm, line);
  280: 
  281:     DEBUG("ficlExec '%s' = %d", line, result);
  282:     switch (result) {
  283:     case VM_OUTOFTEXT:
  284:     case VM_ABORTQ:
  285:     case VM_QUIT:
  286:     case VM_ERREXIT:
  287: 	break;
  288:     case VM_USEREXIT:
  289: 	printf("No where to leave to!\n");
  290: 	break;
  291:     case VM_ABORT:
  292: 	printf("Aborted!\n");
  293: 	break;
  294:     case BF_PARSE:
  295: 	printf("Parse error!\n");
  296: 	break;
  297:     default:
  298:         /* Hopefully, all other codes filled this buffer */
  299: 	printf("%s\n", command_errmsg);
  300:     }
  301:     
  302:     if (result == VM_USEREXIT)
  303: 	panic("interpreter exit");
  304:     setenv("interpret", bf_vm->state ? "" : "OK", 1);
  305: 
  306:     return result;
  307: }