[comp.lang.forth] TILE FORTH PACKAGE 7

mip@massormetrix.ida.liu.se (Mikael Patel) (12/19/89)

#! /bin/sh
# This is a shell archive.  Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file".  To overwrite existing
# files, type "sh file -c".  You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g..  If this archive is complete, you
# will see the following message at the end:
#		"End of archive 7 (of 7)."
# Contents:  kernel.c
# Wrapped by mip@massormetrix on Mon Dec 18 18:40:14 1989
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f kernel.c -a "${1}" != "-c" ; then 
  echo shar: Will not over-write existing file \"kernel.c\"
else
echo shar: Extracting \"kernel.c\" \(57109 characters\)
sed "s/^X//" >kernel.c <<'END_OF_kernel.c'
X/*
X  C BASED FORTH-83 MULTI-TASKING KERNEL
X
X  Copyright (c) 1989 by Mikael R.K. Patel
X
X  Computer Aided Design Laboratory (CADLAB)
X  Department of Computer and Information Science
X  Linkoping University
X  S-581 83 LINKOPING
X  SWEDEN
X
X  Email: mip@ida.liu.se
X
X  Started on: 30 June 1988
X
X  Last updated on: 11 December 1989
X
X  Dependencies:
X       (cc) kernel.h, error.h, memory.h and io.c
X
X  Description:
X       Virtual Forth machine and kernel code supporting multi-tasking of
X       light weight processes. A pure 32-bit Forth-83 Standard implementation.
X
X       Extended with argument binding and local variables, exception
X       handling, queue data management, multi-tasking, symbol hiding and
X       casting, forwarding, null terminated string and memory allocation,
X       file search paths, and source library module loading.
X  
X       The kernel does not implement the block word set. All code is
X       stored as text files.
X
X  Copying:
X       This program is free software; you can redistribute it and/or modify
X       it under the terms of the GNU General Public License as published by
X       the Free Software Foundation; either version 1, or (at your option)
X       any later version.
X
X       This program is distributed in the hope that it will be useful,
X       but WITHOUT ANY WARRANTY; without even the implied warranty of
X       MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
X       GNU General Public License for more details.
X
X       You should have received a copy of the GNU General Public License
X       along with this program; see the file COPYING.  If not, write to
X       the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. 
X
X*/
X
X#include "kernel.h"
X#include "memory.h"
X#include "error.h"
X#include "io.h"
X
X
X/* EXTERNAL DECLARATIONS */
X
Xextern void io_dispatch();
X
X
X/* INTERNAL FORWARD DECLARATIONS */
X
Xextern ENTRY terminate;
Xextern ENTRY toexception;
Xextern ENTRY kernel_abort;
Xextern ENTRY span;
Xextern ENTRY state;
Xextern ENTRY vocabulary;
Xextern char  thepad[];
Xextern char  thetib[];
X
X
X/* VOCABULARY LISTING PARAMETERS */
X
X#define COLUMNWIDTH 15
X#define LINEWIDTH 75
X
X
X/* CONTROL STRUCTURE MARKERS */
X
X#define ELSE 1
X#define THEN 2
X#define AGAIN 4
X#define UNTIL 8
X#define WHILE 16
X#define REPEAT 32
X#define LOOP 64
X#define PLUSLOOP 128
X#define OF 256
X#define ENDOF 512
X#define ENDCASE 1024
X#define SEMICOLON 2048
X
X
X/* MULTI-TASKING MACHINE REGISTERS */
X
Xlong verbose;			/* Application or programming mode */
Xlong quited;			/* Interpreter toploop state */
Xlong running;			/* Task switch flag */
Xlong tasking;			/* Multi-tasking flag */
X
XTASK *tp;			/* Task pointer */
XTASK *foreground;		/* Foreground task pointer */
X
X
X/* FORTH MACHINE REGISTERS */
X
Xlong tos;			/* Top of stack register */
Xlong *sp;			/* Parameter stack pointer */
Xlong *s0;			/* Bottom of parameter stack pointer */
X
Xlong *ip;			/* Instruction pointer */
Xlong *rp;			/* Return stack pointer */
Xlong *r0;			/* Bottom of return stack pointer */
X
Xlong *fp;			/* Argument frame pointer */
Xlong *ep;			/* Exception frame pointer */
X
X
X/* VOCABULARY SEARCH LISTS */
X
X#define CONTEXTSIZE 32
X
Xstatic ENTRY *current = &forth;
Xstatic ENTRY *context[CONTEXTSIZE] = {&forth};
X
X
X/* ENTRY LOOKUP CACHE, SIZE AND HASH FUNCTION */
X
X#define CACHESIZE 256
X#define hash(s) ((s[0] + (s[1] << 4)) & (CACHESIZE - 1))
X
Xstatic ENTRY *cache[CACHESIZE];
X
X
X/* DICTIONARY AREA FOR THREADED CODE AND DATA */
X
Xlong *dictionary;
Xlong *dp;
X
X
X/* INTERNAL STRUCTURE SIZES */
X
X#define PADSIZE 84
X#define TIBSIZE 256
X    
X
X/* INNER MULTI-TASKING FORTH VIRTUAL MACHINE */
X
Xvoid doinner()
X{
X    long e;
X
X    /* Exception marking and handler */
X    if (e = setjmp(restart)) {
X	spush(e);
X	doraise();
X    }
X    
X    /* Run virtual machine until task switch */
X    running = TRUE;
X    while (running) {
X
X	/* Fetch next thread to execute */
X	ENTRY *p = (ENTRY *) *ip++;
X
X	/* Select on type of entry */
X	switch (p -> code) {
X	  case CODE:
X	    ((void (*)()) (p -> parameter))(); 
X	    break;
X	  case COLON:
X	    rpush(ip);
X	    jump(p -> parameter);
X	    break;
X	  case VARIABLE:
X	    spush(&(p -> parameter));
X	    break;
X	  case CONSTANT:
X	    spush(p -> parameter);
X	    break;
X	  case VOCABULARY:
X	    doappend(p);
X	    break;
X	  case CREATE:
X	    spush(p -> parameter);
X	    break;
X	  case USER:
X	    spush(tp + p -> parameter);
X	    break;
X	  case LOCAL:
X	    spush(*((long *) (long) fp - p -> parameter));
X	    break;
X	  case FORWARD:
X	    if (p -> parameter)
X		docall((ENTRY *) p -> parameter);
X	    else {
X		(void) printf("%s: unresolved forward entry\n", p -> name);
X		doabort();
X	    }
X	    break;
X	  case EXCEPTION:
X	    spush(p);
X	    break;
X	  case FIELD:
X	    tos = p -> parameter + tos;
X	    break;
X	  default: /* DOES: FORTH LEVEL INTERPRETATION */
X	    rpush(ip);
X	    spush(p -> parameter);
X	    jump(p -> code);
X	    break;
X	}
X    }
X}
X
Xvoid docommand()
X{
X    long e;
X
X    /* Exception marking and handler */
X    if (e = setjmp(restart)) {
X	spush(e);
X	doraise();
X	return;
X    }
X
X    /* Execute command on top of stack */
X    doexecute();
X
X    /* Check if this affects the virtual machine */
X    if (rp != r0) {
X	tasking = TRUE;
X
X	/* Run the virtual machine and allow user extension */
X	while (tasking) {
X	    doinner();
X	    io_dispatch();
X	}
X    }
X}
X
Xvoid docall(p)
X    ENTRY *p;
X{
X    /* Select on type of entry */
X    switch (p -> code) {
X      case CODE:
X	((void (*)()) (p -> parameter))(); 
X	return;	
X      case COLON:
X	rpush(ip);
X	jump(p -> parameter);
X	return;
X      case VARIABLE:
X	spush(&(p -> parameter));
X	return;
X      case CONSTANT:
X	spush(p -> parameter);
X	return;
X      case VOCABULARY:
X	doappend(p);
X	return;
X      case CREATE:
X	spush(p -> parameter);
X	return;
X      case USER:
X	spush(tp + p -> parameter);
X	return;
X      case LOCAL:
X	spush(*((long *) (long) fp - p -> parameter));
X	return;
X      case FORWARD:
X	if (p -> parameter)
X	    docall((ENTRY *) p -> parameter);
X	else {
X	    (void) printf("%s: unresolved forward entry\n", p -> name);
X	    doabort();
X	}
X	return;
X      case EXCEPTION:
X	spush(p);
X	return;
X      case FIELD:
X	tos = p -> parameter + tos;
X	return;
X      default: /* DOES: FORTH LEVEL INTERPRETATION */
X	rpush(ip);
X	spush(p -> parameter);
X	jump(p -> code);
X	return;
X    }
X}
X
Xvoid doappend(p)
X    ENTRY *p;
X{
X    long v;
X    
X    /* Flush the entry cache */
X    spush(FALSE);
X    dorestore();
X
X    /* Check if the vocabulary is a member of the current search set */
X    for (v = 0; v < CONTEXTSIZE; v++)
X
X	/* If a member then rotate the vocabulary first */
X	if (p == context[v]) {
X	    for (; v; v--) context[v] = context[v - 1];
X	    context[0] = p;
X	    return;
X	}
X
X    /* If not a member, then insert first into the search set */
X    for (v = CONTEXTSIZE - 1; v > 0; v--) context[v] = context[v - 1];
X    context[0] = p;
X}    
X
X
X/* VOCABULARY ROOT */
X
XENTRY forth = {(ENTRY *) NIL, "forth", NORMAL, VOCABULARY, (long) &vocabulary};
X
X
X/* CONTROL: EXTENSION LEVEL DEFINITIONS */
X
Xvoid doparenbranch()
X{
X    branch(*ip);
X}
X
XCOMPILATION_CODE(parenbranch, forth, "(branch)", doparenbranch);
X
Xvoid doparenqbranch()
X{
X    long flag = spop;
X    
X    /* Check flag on top of stack and branch if false */
X    if (flag)
X	skip;
X    else
X	branch(*ip);
X}
X
XCOMPILATION_CODE(parenqbranch, parenbranch, "(?branch)", doparenqbranch);
X
Xvoid doparendo()
X{
X    /* Build a loop frame on return stack */
X    rpush(ip++);
X    rpush(spop);
X    rpush(spop);
X}
X
XCOMPILATION_CODE(parendo, parenqbranch, "(do)", doparendo);
X
Xvoid doparenqdo()
X{
X    /* Check if the start and stop value are equal */
X    if (tos == snth(0)) {
X
X	/* If equal then branch over the loop block */
X	sdrop(1);
X	branch(*ip);
X    }
X    else {
X
X	/* else build a loop frame on the return stack */
X	rpush(ip++);
X	rpush(spop);
X	rpush(spop);
X    }
X}
X
XCOMPILATION_CODE(parenqdo, parendo, "(?do)", doparenqdo);
X
Xvoid doparenloop()
X{
X    /* Increment the index by one and check if within loop range */
X    rnth(1) += 1;
X    if (rnth(0) > rnth(1)) {
X
X	/* Branch if still within range */
X	branch(*ip);
X	return;
X    }
X
X    /* Else remove the loop frame from the return stack and skip */
X    rdrop(3);
X    skip;
X
X}
X
XCOMPILATION_CODE(parenloop, parenqdo, "(loop)", doparenloop);
X
Xvoid doparenplusloop()
X{
X    long d = spop;
X
X    /* Increment the index with the top of stack value */
X    rnth(1) += d;
X
X    /* Check direction and if the index is still within the loop range */
X    if (d > 0) {
X	if (rnth(0) > rnth(1)) {
X	    branch(*ip);
X	    return;
X	}
X    }
X    else {
X	if (rnth(0) < rnth(1)) {
X	    branch(*ip);
X	    return;
X	}
X    }
X
X    /* Else remove the loop frame from the return stack and skip */
X    rdrop(3);
X    skip;
X}
X
XCOMPILATION_CODE(parenplusloop, parenloop, "(+loop)", doparenplusloop);
X
X
X/* COMPILATION LITERALS */
X
Xvoid doparenliteral()
X{ 
X    spush(*ip++);
X}
X
XCOMPILATION_CODE(parenliteral, parenplusloop, "(literal)", doparenliteral);
X
Xvoid doparendotquote()
X{
X    (void) printf("%s", *ip++);
X}
X
XCOMPILATION_CODE(parendotquote, parenliteral, "(.\")", doparendotquote);
X
Xvoid doparenabortquote()
X{
X    long flag = spop;
X    
X    /* Check flag on top of stack. If true then abort and give inline message */
X    if (flag) {
X	doparendotquote();
X	doabort();
X    }
X    else skip;
X}
X
XCOMPILATION_CODE(parenabortquote, parendotquote, "(abort\")", doparenabortquote);
X
Xvoid doparensemicolon()
X{
X    jump(rpop);
X}
X
XCOMPILATION_CODE(parensemicolon, parendotquote, "(;)", doparensemicolon);
X
Xvoid doparendoes()
X{
X    ((ENTRY *) (current -> parameter)) -> code = (long) ip;
X    jump(rpop);
X}
X
XCOMPILATION_CODE(parendoes, parensemicolon, "(does>)", doparendoes);
X
X
X/* THREADING PRIMITIVES */
X
Xvoid dothread()
X{
X    *dp++ = spop;
X}
X
XNORMAL_CODE(thread, parendoes, "thread", dothread);
X
Xvoid dounthread()
X{
X    unary(*(long *));
X}
X
XNORMAL_CODE(unthread, thread, "unthread", dounthread);
X
X
X/* COMPILATION: STANDARD EXTENSION LEVEL DEFINITIONS */
X
Xvoid doforwardmark()
X{
X    dohere();
X    spush(0);
X    docomma();
X}
X
XCOMPILATION_CODE(forwardmark, unthread, ">mark", doforwardmark);
X
Xvoid dobackwardmark()
X{
X    dohere();
X}
X
XCOMPILATION_CODE(backwardmark, forwardmark, "<mark", dobackwardmark);
X
Xvoid doforwardresolve()
X{
X    dohere();
X    doover();
X    dominus();
X    doswap();
X    dostore();
X}
X
XCOMPILATION_CODE(forwardresolve, backwardmark, ">resolve", doforwardresolve);
X
Xvoid dobackwardresolve()
X{
X    dohere();
X    dominus();
X    docomma();
X}
X
XCOMPILATION_CODE(backwardresolve, forwardresolve, "<resolve", dobackwardresolve);
X
XNORMAL_VOCABULARY(compiler, forth, "compiler", backwardresolve);
X
X
X/* LOCAL VARIABLES AND ARGUMENT BINDING */
X
Xstatic ENTRY *theframed = (ENTRY *) NIL;
X
Xvoid doremovelocals()
X{
X    /* Check if the last definition used an argument definition */
X    if (theframed) {
X	
X	/* Restore the vocabulary structure */
X	spush(theframed);
X	dorestore();
X	theframed = (ENTRY *) NIL;
X    }
X}
X
Xvoid doparenlink()  
X{
X    /* Build an argument and local variable frame */
X    spush(tos);
X    rpush(fp);
X
X    /* Using the two inline values: arguments and local variables */
X    fp = sp + *ip++;
X    sp = sp - *ip++;
X
X    /* Save entry stack pointer to allow result movement on exit */
X    rpush(sp);
X}
X
XCOMPILATION_CODE(parenlink, forth, "(link)", doparenlink);
X
Xvoid doparenunlink()  
X{    
X    long *t;
X
X    /* Remove the argument and local variable frame */
X    t = (long *) rpop;
X    spush(tos);
X
X    /* And move results to new top of stack */
X    for (--t; t > sp; *--fp = *--t);
X    sp = fp;
X    spop;
X
X    /* Restore old frame pointer */
X    fp = (long *) rpop;
X}
X
XCOMPILATION_CODE(parenunlink, parenlink, "(unlink)", doparenunlink);
X
Xvoid doparenunlinksemicolon() 
X{
X    long *t;
X
X    /* Remove the argument and local variable frame */
X    t = (long *) rpop;
X    spush(tos);
X
X    /* And move results to new top of stack */
X    for (--t; t > sp; *--fp = *--t);
X    sp = fp;
X    spop;
X
X    /* Restore old frame pointer */
X    fp = (long *) rpop;
X
X    /* Return from this colon definition */
X    jump(rpop);
X}
X
XCOMPILATION_CODE(parenunlinksemicolon, parenunlink, "(unlink;)", doparenunlinksemicolon);
X
Xvoid doparenunlinkdoes()
X{
X    long *t;
X
X    /* Remove the argument and local variable frame */
X    t = (long *) rpop;
X    spush(tos);
X
X    /* And move results to new top of stack */
X    for (--t; t > sp; *--fp = *--t);
X    sp = fp;
X    spop;
X
X    /* Restore old frame pointer */
X    fp = (long *) rpop;
X
X    /* Make the last definition of the following does code */
X    ((ENTRY *) ((ENTRY *) current -> parameter)) -> code = (long) ip;
X
X    /* Return from this colon definition */
X    jump(rpop);
X}
X
XCOMPILATION_CODE(parenunlinkdoes, parenunlinksemicolon, "(unlinkdoes>)", doparenunlinkdoes);
X
Xvoid doparenlocal()
X{
X    spush(((long *) (long) fp - *ip++));
X}
X
XCOMPILATION_CODE(parenlocal, parenunlinkdoes, "(local)", doparenlocal);
X
Xvoid doparenlocalstore()
X{
X    *((long *) (long) fp - *ip++) = spop;
X}
X
XCOMPILATION_CODE(parenlocalstore, parenlocal, "(local!)", doparenlocalstore);
X
Xvoid doparenlocalfetch()
X{
X    spush(*((long *) (long) fp - *ip++));
X}
X
XCOMPILATION_CODE(parenlocalfetch, parenlocalstore, "(local@)", doparenlocalfetch);
X
Xvoid doassignlocal()
X{
X    *((long *) (long) fp - ((ENTRY *) *ip++) -> parameter) = spop;
X}
X
XCOMPILATION_CODE(assignlocal, parenlocalfetch, "->", doassignlocal);
X
XCOMPILATION_CODE(localexit, assignlocal, "exit", doparenunlinksemicolon);
X
Xvoid docurlebracket()
X{
X    long frameflag = 1;
X    long argflag   = 1;
X    long arguments = 0;
X    long locals    = 0;
X
X    /* Check only one active lexical levels allowed */
X    if (theframed) {
X	(void) printf("%s: illegal argument binding\n", theframed -> name);
X	doremovelocals();
X	doabort();
X	return;
X    }
X
X    /* Save pointer to latest defintion to allow removal of local names */
X    theframed = (ENTRY *) current -> parameter;
X
X    /* While the end of the frame description is not found */
X    while (frameflag) {
X
X	/* Scan the next symbol */
X    	spush(' ');
X	doword();
X	if (io_eof()) {
X	    (void) printf("locals: end of file during scan of parameter list\n");
X	    doabort();
X	    return;
X	}
X
X	/* Check if it marks the end of the argument section */
X	if (STREQ(tos, "|")) {
X	    argflag = 0;
X	}
X	else {
X	    /* else check if its the end of the frame description */
X            if (STREQ(tos, "}")) {
X	    	frameflag = 0;
X	    }
X	    else {
X		/* Or the beginning of the return description */
X	    	if (STREQ(tos, "--")) {
X		    spop;
X		    spush('}');
X		    doword();
X		    frameflag = 0;
X		}
X		else {
X		    /* If not then make the symbol a local variable */
X		    if (argflag)
X			arguments++;
X		    else
X			locals++;
X		    (void) makeentry((char *) tos,
X				     (long) LOCAL,
X				     (long) COMPILATION,
X				     arguments + locals);
X		}
X	    }
X	}
X	spop;
X    }
X
X    /* Compile the parameter binding linkage */
X    spush(&parenlink);
X    dothread();
X
X    /* And the appropriate frame size */
X    spush(arguments);
X    docomma();
X    spush(locals);
X    docomma();
X}
X
XCOMPILATION_IMMEDIATE_CODE(curlebracket, localexit, "{", docurlebracket);
X
XNORMAL_VOCABULARY(locals, compiler, "locals", curlebracket);
X
X
X/* NULL TERMINATED STRINGS */
X
Xvoid doparenquote()
X{
X    spush(*ip++);
X}
X
XCOMPILATION_CODE(parenquote, forth, "(\")", doparenquote);
X
Xvoid doquote()
X{
X    /* Scan for the string if not end of input */
X    (void) io_scan(thetib, '"');
X
X    /* Make a copy of it */
X    spush(thetib);
X    dostringcopy();
X
X    /* If compilation mode then thread a string literal */
X    if (state.parameter) {
X	spush(&parenquote);
X	dothread();
X	docomma();
X    }
X}
X
XIMMEDIATE_CODE(quote, parenquote, "\"", doquote);
X
Xvoid dostringlength()
X{
X    tos = (long) strlen((char *) tos);
X}
X
XNORMAL_CODE(stringlength, quote, "length", dostringlength);
X
Xvoid dostringcopy()
X{
X    tos = (long) strcpy(malloc((unsigned) strlen((char *) tos) + 1), (char *) tos);
X}
X
XNORMAL_CODE(stringcopy, stringlength, "copy", dostringcopy);
X
Xvoid dostringequal()
X{
X    char *s = (char *) spop;
X    
X    tos = ((STREQ(tos, s) ? TRUE : FALSE));
X}
X
XNORMAL_CODE(stringequal, stringcopy, "=", dostringequal);
X
Xvoid dostringcat()
X{
X    char *s = (char *) spop;
X    
X    tos = (long) strcat((char *) tos, s);
X}
X
XNORMAL_CODE(stringcat, stringequal, "+", dostringcat);
X
Xvoid dostringprint()
X{
X    char *s = (char *) spop;
X    
X    (void) printf("%s", s);
X}
X
XNORMAL_CODE(stringprint, stringcat, "print", dostringprint);
X
XNORMAL_VOCABULARY(string, locals, "string", stringprint); 
X
X
X/* MEMORY ALLOCATION */
X
Xvoid domalloc()
X{
X    tos = (long) malloc((unsigned) tos);
X}
X
XNORMAL_CODE(kernel_malloc, forth, "malloc", domalloc);
X
Xvoid dorealloc()
X{
X    char *m = (char *) spop;
X    
X    tos = (long) realloc(m, (unsigned) tos);
X}
X
XNORMAL_CODE(kernel_realloc, kernel_malloc, "realloc", dorealloc);
X
Xvoid dofree()
X{
X    char *m = (char *) spop;
X    
X    free(m);
X}
X
XNORMAL_CODE(kernel_free, kernel_realloc, "free", dofree);
X
XNORMAL_VOCABULARY(memory, string, "memory", kernel_free); 
X
X
X/* DOUBLE LINKED LIST */
X
Xvoid doqemptyqueue()
X{
X    compare(== (long) (((QUEUE *) tos) -> succ));
X}
X
XNORMAL_CODE(qemptyqueue, forth, "?empty", doqemptyqueue);
X
Xvoid dointoqueue()
X{
X    QUEUE *t, *q;
X
X    q = (QUEUE *) spop;
X    t = (QUEUE *) spop;
X
X    t -> pred = q -> pred;
X    t -> succ = q;
X
X    q -> pred -> succ = t;
X    q -> pred = t;
X}
X
XNORMAL_CODE(intoqueue, qemptyqueue, "into", dointoqueue);
X
Xvoid dooutqueue()
X{
X    QUEUE *t = (QUEUE *) spop;
X
X    t -> succ -> pred = t -> pred;
X    t -> pred -> succ = t -> succ;
X
X    t -> succ = t -> pred = t;
X}
X
XNORMAL_CODE(outqueue, intoqueue, "out", dooutqueue);
X
XNORMAL_VOCABULARY(queues, memory, "queues", outqueue);
X
X
X/* MULTI-TASKING */
X
Xstatic long toterminate = (long) &terminate;
X
XNORMAL_CONSTANT(kernel_foreground, forth, "foreground", (long) &foreground);
X
XNORMAL_CONSTANT(kernel_running, kernel_foreground, "running", (long) &tp);
X
Xvoid douser()
X{
X    spush(NORMAL);
X    spush(USER);
X    spush(' ');
X    doword();
X    doentry();
X}
X
XNORMAL_CODE(user, kernel_running, "user", douser);
X
XTASK *maketask(users, params, returns, action)
X    long users, params, returns, action;
X{
X    long size = sizeof(TASK_HEADER) + users + params + returns;
X    TASK *t = (TASK *) malloc((unsigned) size);
X
X    /* Initiate queues structure, status and environment */
X    t -> queue.succ = t -> queue.pred = (QUEUE *) t;
X    t -> status = READY;
X
X    t -> s0 = t -> sp = (long *) ((char *) t + size - returns);
X    t -> r0 = t -> rp = (long *) ((char *) t + size);
X    t -> ip = (action ? (long *) action : (long *) &toterminate);
X    t -> fp = NIL;
X    t -> ep = NIL;
X
X    /* Return task pointer */
X    return t;
X}
X
Xvoid dotask()
X{
X    long users, params, returns, action;
X
X    action  = spop;
X    returns = spop;
X    params  = spop;
X    users   = spop;
X    spush(maketask(users, params, returns, action));
X}
X
XNORMAL_CODE(task, user, "task", dotask);
X
Xvoid doresume()
X{
X    TASK *t = (TASK *) tos;
X
X    /* Check if the task to resume is the current task and active */
X    if (t -> status && t != tp) {
X
X	/* Store the state of the current task */
X	tp -> sp = sp;
X	tp -> s0 = s0;
X	tp -> ip = ip;
X	tp -> rp = rp;
X	tp -> r0 = r0;
X	tp -> fp = fp;
X	tp -> ep = ep;
X
X	/* Indicate task switch to the virtual machine */
X	running = FALSE;
X    
X	/* Restore the parameter task */
X	sp = t -> sp;
X	s0 = t -> s0;
X	ip = t -> ip;
X	rp = t -> rp;
X	r0 = t -> r0;
X	fp = t -> fp;
X	ep = t -> ep;
X	tp = t;
X    }
X
X    /* Load top of stack again */
X    spop;
X}
X
XNORMAL_CODE(resume, task, "resume", doresume);
X
Xvoid doschedule()
X{
X    /* Put the task after the current task */
X    spush(tp -> queue.succ);
X    dointoqueue();
X
X    /* Resume the task now */
X    dodetach();
X
X    /* Restore parameter and return stack */
X    spush(tp);
X    rpush(&toterminate);
X
X    /* Mark the task as running */
X    tp -> status = RUNNING;
X}
X
XNORMAL_CODE(schedule, resume, "schedule", doschedule);
X
Xvoid dodetach()
X{
X    /* Resume the next task in the system task queue */
X    spush(tp -> queue.succ);
X    doresume();
X}
X
XNORMAL_CODE(detach, schedule , "detach", dodetach);
X
Xvoid doterminate()
X{
X    TASK *t = tp;
X
X    /* Check if the task is the foreground task */
X    if (tp == foreground) {
X
X	/* Empty the return stack and signal end of execution to inner loop */
X	rinit;
X	running = FALSE;
X	tasking = FALSE;
X
X	/* Foreground should always terminate on last exit */
X	ip = (long *) &toterminate;
X    }
X    else {
X
X	/* else remove the current task from the system task queue */
X	dodetach();
X	t -> status = TERMINATED;
X	spush(t);
X	dooutqueue();
X    }
X}
X
XNORMAL_CODE(terminate, detach, "terminate", doterminate);
X
XNORMAL_VOCABULARY(multitasking, queues, "multi-tasking", terminate);
X
X
X/* EXCEPTION MANAGEMENT */
X
Xvoid donewexception()
X{
X    spush(NIL);
X    spush(NORMAL);
X    spush(EXCEPTION);
X    spush(' ');
X    doword();
X    doentry();
X}
X
XNORMAL_CODE(newexception, forth, "exception", donewexception);
X
Xvoid doparenexceptionsemicolon()
X{  
X    /* Restore the old exception frame pointer */
X    ep = (long *) rpop;
X
X    /* Remove the exception frame */
X    rdrop(4);
X    
X    /* Return from the current definition */
X    jump(rpop);
X}
X
XCOMPILATION_CODE(parenexceptionsemicolon, newexception, "(exception;)", doparenexceptionsemicolon);
X
Xvoid doparenexceptionunlinksemicolon()
X{  
X    long *t;
X
X    /* Remove the argument and local variable frame */
X    t = (long *) rpop;
X    spush(tos);
X
X    /* And move results to new top of stack */
X    for (--t; t > sp; *--fp = *--t);
X    sp = fp;
X    spop;
X
X    /* Restore old frame pointer */
X    fp = (long *) rpop;
X
X    /* Restore the old exception frame pointer */
X    ep = (long *) rpop;
X
X    /* Remove the exception frame */
X    rdrop(4);
X    
X    /* Return from the current definition */
X    jump(rpop);
X}
X
XCOMPILATION_CODE(parenexceptionunlinksemicolon, parenexceptionsemicolon, "(exceptionunlink;)", doparenexceptionunlinksemicolon);
X
Xvoid doparenexception()
X{   
X    long body;
X
X    /* Capture pointer to body */
X    body = spop;
X   
X    /* Build an exception frame */
X    rpush(tos);
X    rpush(sp);
X    rpush(ip);
X    rpush(fp);
X    rpush(ep);
X    ep = rp;
X    
X    /* Jump to the body of the definition */
X    jump(body);
X}
X
XCOMPILATION_CODE(parenexception, parenexceptionunlinksemicolon, "(exception>)", doparenexception);
X
Xvoid doexception()
X{  
X    ENTRY *t;
X
X    /* Set up pointer to last definition */
X    dolast();
X    t = (ENTRY *) spop;
X    
X    /* Compile an exit of the current definition */
X    spush((theframed ? &parenexceptionunlinksemicolon : &parenexceptionsemicolon));
X    dothread();
X    doremovelocals();
X    
X    /* Redefine the code type of the last definition */
X    t -> code = (long) dp;
X    
X    /* Compile the run time exception management definition */
X    spush(&parenexception);
X    dothread();
X}
X
XCOMPILATION_IMMEDIATE_CODE(exception, parenexception, "exception>", doexception);
X
Xvoid doraise()
X{  
X    long s = spop;
X    
X    /* Check if there is an exception block available */
X    if (ep) {
X
X	/* Restore the call environment */
X	rp = ep;
X	ep = (long *) rpop;
X	fp = (long *) rpop;
X	ip = (long *) rpop;
X	sp = (long *) rpop;
X	tos = rpop;
X
X	/* Pass on the signal or exception to the exception block */
X	spush(s);
X    }
X    else {
X	
X	/* Call low level management of signal */
X	(void) error_signal(s);
X    }
X}
X
XNORMAL_CODE(raise, exception, "raise", doraise);
X
XNORMAL_VOCABULARY(exceptions, multitasking, "exceptions", raise);
X
X
X/* LOGIC: FORTH-83 VOCABULARY */
X
XNORMAL_CONSTANT(false, exceptions, "false", FALSE);
X
XNORMAL_CONSTANT(true, false, "true", TRUE);
X
Xvoid doboolean()
X{
X    compare(!= 0);
X}
X
XNORMAL_CODE(boolean, true, "boolean", doboolean);
X
Xvoid donot()
X{
X    unary(~);
X}
X
XNORMAL_CODE(not, boolean, "not", donot);
X
Xvoid doand()
X{
X    binary(&);
X}
X
XNORMAL_CODE(and, not, "and", doand);
X
Xvoid door()
X{
X    binary(|);
X}
X
XNORMAL_CODE(or, and, "or", door);
X
Xvoid doxor()
X{
X    binary(^);
X}
X
XNORMAL_CODE(xor, or, "xor", doxor);
X
Xvoid doqwithin()
X{
X    long value;
X    long upper;
X    long lower;
X    
X    upper = spop;
X    lower = spop;
X    value = spop;
X    
X    spush((value > upper) || (value < lower) ? FALSE : TRUE);
X}
X    
XNORMAL_CODE(qwithin, xor, "?within", doqwithin);
X
X
X/* STACK MANIPULATION */
X
Xvoid dodup()
X{
X    spush(tos);
X}
X
XNORMAL_CODE(kernel_dup, qwithin, "dup", dodup);
X
Xvoid dodrop()
X{
X    spop;
X}
X
XNORMAL_CODE(drop, kernel_dup, "drop", dodrop);
X
Xvoid doswap()
X{
X    long t = tos;
X
X    tos = snth(0);
X    snth(0) = t;
X}
X
XNORMAL_CODE(swap, drop, "swap", doswap);
X
Xvoid doover()
X{
X    spush(snth(1));
X}
X
XNORMAL_CODE(over, swap, "over", doover);
X
Xvoid dorot()
X{
X    long t = tos;
X
X    tos = snth(1);
X    snth(1) = snth(0);
X    snth(0) = t;
X}
X
XNORMAL_CODE(rot, over, "rot", dorot);
X
Xvoid dopick()
X{
X    tos = snth(tos);
X}
X
XNORMAL_CODE(pick, rot, "pick", dopick);
X
Xvoid doroll()
X{
X    long e;
X    long *s;
X
X    /* Fetch roll parameters: number and element */
X    e = snth(tos);
X
X    /* Roll the stack */
X    for (s = sp + tos; s > sp; s--) *s = *(s - 1);
X    sp++;
X    
X    /* And assign the new top of stack */
X    tos = e;
X}
X
XNORMAL_CODE(roll, pick, "roll", doroll);
X
Xvoid doqdup()
X{
X    if (tos) spush(tos);
X}
X
XNORMAL_CODE(qdup, roll, "?dup", doqdup);
X
Xvoid dotor()
X{
X    rpush(spop);
X}
X
XCOMPILATION_CODE(tor, qdup, ">r", dotor);
X
Xvoid dofromr()
X{
X    spush(rpop);
X}
X
XCOMPILATION_CODE(fromr, tor, "r>", dofromr);
X
Xvoid docopyr()
X{
X    spush(*rp);
X}
X
XCOMPILATION_CODE(copyr, fromr, "r@", docopyr);
X
Xvoid dodepth()
X{
X    long *t = sp;
X
X    spush((s0 - t));
X}
X
XNORMAL_CODE(depth, copyr, "depth", dodepth);
X
Xvoid dodots()
X{
X    /* Print the stack depth */
X    (void) printf("[%d] ", s0 - sp);
X
X    /* Check if there are any elements on the stack */
X    if (s0 - sp > 0) {
X	long *s;
X
X	/* Print them and don't forget top of stack */
X	for (s = s0 - 2; s >= sp; s--) {
X	    (void) printf("\\");
X	    spush(*s);
X	    if (tos < 0) {
X		(void) putchar('-');
X		tos = -tos;
X	    }
X	    dolesssharp();
X	    dosharps();
X	    dosharpgreater();
X	    dotype();
X	}
X	(void) printf("\\");
X	dodup();
X	dodot();
X    }
X}
X
XNORMAL_CODE(dots, depth, ".s", dodots);
X
X
X/* COMPARISON */
X
Xvoid dolessthan()
X{
X    relation(<);
X}
X
XNORMAL_CODE(lessthan, dots, "<", dolessthan);
X
Xvoid doequals()
X{
X    relation(==);
X}
X
XNORMAL_CODE(equals, lessthan, "=", doequals);
X
Xvoid dogreaterthan()
X{
X    relation(>);
X}
X
XNORMAL_CODE(greaterthan, equals, ">", dogreaterthan);
X
Xvoid dozeroless()
X{
X    compare(< 0);
X}
X
XNORMAL_CODE(zeroless, greaterthan, "0<", dozeroless);
X
Xvoid dozeroequals()
X{
X    compare(== 0);
X}
X
XNORMAL_CODE(zeroequals, zeroless, "0=", dozeroequals);
X
Xvoid dozerogreater()
X{
X    compare(> 0);
X}
X
XNORMAL_CODE(zerogreater, zeroequals, "0>", dozerogreater);
X
Xvoid doulessthan()
X{
X    urelation(<);
X}
X
XNORMAL_CODE(ulessthan, zerogreater, "u<", doulessthan);
X
X
X/* CONSTANTS */
X
XNORMAL_CONSTANT(nil, ulessthan, "nil", NIL);
X
XNORMAL_CONSTANT(minustwo, nil, "-2", -2);
X
XNORMAL_CONSTANT(minusone, minustwo, "-1", -1);
X
XNORMAL_CONSTANT(zero, minusone, "0", 0);
X
XNORMAL_CONSTANT(one, zero, "1", 1);
X
XNORMAL_CONSTANT(two, one, "2", 2);
X
X
X/* ARITHMETRIC */
X
Xvoid doplus()
X{
X    binary(+);
X}
X
XNORMAL_CODE(plus, two, "+", doplus);
X
Xvoid dominus()
X{
X    binary(-);
X}
X
XNORMAL_CODE(minus, plus, "-", dominus);
X
Xvoid dooneplus()
X{
X    unary(++);
X}
X
XNORMAL_CODE(oneplus, minus, "1+", dooneplus);
X
Xvoid dooneminus()
X{
X    unary(--);
X}
X
XNORMAL_CODE(oneminus, oneplus, "1-", dooneminus);
X
Xvoid dotwoplus()
X{
X    unary(2 +);
X}
X
XNORMAL_CODE(twoplus, oneminus, "2+", dotwoplus);
X
Xvoid dotwominus()
X{
X    unary(-2 +);
X}
X
XNORMAL_CODE(twominus, twoplus, "2-", dotwominus);
X
Xvoid dotwotimes()
X{
X    tos <<= 1;
X}
X
XNORMAL_CODE(twotimes, twominus, "2*", dotwotimes);
X
Xvoid doleftshift()
X{
X    binary(<<);
X}
X
XNORMAL_CODE(leftshift, twotimes, "<<", doleftshift);
X
Xvoid dotimes()
X{
X    binary(*);
X}
X
XNORMAL_CODE(kernel_times, leftshift, "*", dotimes);
X
Xvoid doumtimes()
X{
X    ubinary(*);
X}
X
XNORMAL_CODE(kernel_utimes, kernel_times, "um*", doumtimes);
X
Xvoid doumdividemod()
X{
X    long t = snth(0);
X
X    snth(0) = (unsigned long) t % (unsigned long) tos;
X    tos = (unsigned long) t / (unsigned long) tos;
X}
X
XNORMAL_CODE(umdividemod, kernel_utimes, "um/mod", doumdividemod);
X
Xvoid dotwodivide()
X{
X    tos >>= 1;
X}
X
XNORMAL_CODE(twodivide, umdividemod, "2/", dotwodivide);
X
Xvoid dorightshift()
X{
X    binary(>>);
X}
X
XNORMAL_CODE(rightshift, twodivide, ">>", dorightshift);
X
Xvoid dodivide()
X{
X    binary(/);
X}
X
XNORMAL_CODE(divide, rightshift, "/", dodivide);
X
Xvoid domod()
X{
X    binary(%);
X}
X
XNORMAL_CODE(mod, divide, "mod", domod);
X
Xvoid dodividemod()
X{
X    long t = snth(0);
X
X    snth(0) = t % tos;
X    tos = t / tos;
X}
X
XNORMAL_CODE(dividemod, mod, "/mod", dodividemod);
X
Xvoid dotimesdividemod()
X{
X    long t = spop;
X
X    tos = tos * snth(0);
X    snth(0) = tos % t;
X    tos = tos / t;
X}
X
XNORMAL_CODE(timesdividemod, dividemod, "*/mod", dotimesdividemod);
X
Xvoid dotimesdivide()
X{
X    long t = spop;
X
X    binary(*);
X    spush(t);
X    binary(/);
X}
X
XNORMAL_CODE(timesdivide, timesdividemod, "*/", dotimesdivide);
X
Xvoid domin()
X{
X    long t = spop;
X    
X    tos = (t < tos ? t : tos);
X}
X
XNORMAL_CODE(min, timesdivide, "min", domin);
X
Xvoid domax()
X{
X    long t = spop;
X    
X    tos = (t > tos ? t : tos);
X}
X
XNORMAL_CODE(max, min, "max", domax);
X
Xvoid doabs()
X{
X    tos = (tos < 0 ? -tos : tos);
X}
X
XNORMAL_CODE(kernel_abs, max, "abs", doabs);
X
Xvoid donegate()
X{
X    unary(-);
X}
X
XNORMAL_CODE(negate, kernel_abs, "negate", donegate);
X
X
X/* MEMORY */
X
Xvoid dofetch()
X{
X    unary(*(long *));
X}
X
XNORMAL_CODE(fetch, negate, "@", dofetch);
X
Xvoid dostore()
X{
X    *((long *) tos) = snth(0);
X    sdrop(1);
X}
X
XNORMAL_CODE(store, fetch, "!", dostore);
X
Xvoid dowfetch()
X{
X    unary(*(word *));
X}
X
XNORMAL_CODE(wfetch, store, "w@", dowfetch);
X
Xvoid dowstore()
X{
X    *((word *) tos) = snth(0);
X    sdrop(1);
X}
X
XNORMAL_CODE(wstore, wfetch, "w!", dowstore);
X
Xvoid docfetch()
X{
X    unary(*(char *));
X}
X
XNORMAL_CODE(cfetch, wstore, "c@", docfetch);
X
Xvoid docstore()
X{
X    *((char *) tos) = snth(0);
X    sdrop(1);
X}
X
XNORMAL_CODE(cstore, cfetch, "c!", docstore);
X
Xvoid doffetch()
X{
X    long pos;
X    long width;
X
X    width = spop;
X    pos = spop;
X    tos = (tos >> pos) & ~(-1 << width);
X}
X
XNORMAL_CODE(ffetch, cstore, "f@", doffetch);
X
Xvoid dofstore()
X{
X    long pos;
X    long width;
X    long value;
X
X    width = spop;
X    pos = spop;
X    value = spop;
X    tos = ((tos & ~(-1 << width)) << pos) | (value & ~((~(-1 << width)) << pos));
X}
X
XNORMAL_CODE(fstore, ffetch, "f!", dofstore);
X
Xvoid dobfetch()
X{
X    long bit = spop;
X
X    tos = (((tos >> bit) & 1) ? TRUE : FALSE);
X}
X
XNORMAL_CODE(bfetch, fstore, "b@", dobfetch);
X
Xvoid dobstore()
X{
X    long bit;
X    long value;
X
X    bit = spop;
X    value = spop;
X
X    tos = (tos ? (value | (1 << bit)) : (value & ~(1 << bit)));
X}
X
XNORMAL_CODE(bstore, bfetch, "b!", dobstore);
X
Xvoid doplusstore()
X{
X    *((long *) tos) += snth(0);
X    sdrop(1);
X}
X
XNORMAL_CODE(plusstore, bstore, "+!", doplusstore);
X
X
X/* STRINGS */
X
Xvoid docmove()
X{
X    register long n;
X    register char *to;
X    register char *from;
X
X    n = spop;
X    to = (char *) spop;
X    from = (char *) spop;
X
X    while (--n != -1) *to++ = *from++;
X}
X
XNORMAL_CODE(cmove, plusstore, "cmove", docmove);
X
Xvoid docmoveup()
X{
X    register long n;
X    register char *to;
X    register char *from;
X
X    n = spop;
X    to = (char *) spop;
X    from = (char *) spop;
X
X    to += n;
X    from += n;
X    while (--n != -1) *--to = *--from;
X}
X
XNORMAL_CODE(cmoveup, cmove, "cmove>", docmoveup);
X
Xvoid dofill()
X{
X    register char with;
X    register long n;
X    register char *from;
X
X    with = (char) spop;
X    n = spop;
X    from = (char *) spop;
X
X    while (--n != -1) *from++ = with;
X}
X
XNORMAL_CODE(fill, cmoveup, "fill", dofill);
X
Xvoid docount()
X{
X    spush(*((char *) tos));
X    snth(0)++;
X}
X
XNORMAL_CODE(count, fill, "count", docount);
X
Xvoid dodashtrailing()
X{
X    char *p = (char *) (snth(0) + tos);
X    
X    tos += 1;
X    while (--tos && (*--p == ' '));
X}
X
XNORMAL_CODE(dashtrailing, count, "-trailing", dodashtrailing);
X
X
X/* NUMERICAL CONVERSION */
X
XNORMAL_VARIABLE(base, dashtrailing, "base", 10);
X
Xvoid dobinary()
X{
X    base.parameter = 2;
X}
X
XNORMAL_CODE(kernel_binary, base, "binary", dobinary);
X
Xvoid dooctal()
X{
X    base.parameter = 8;
X}
X
XNORMAL_CODE(octal, kernel_binary, "octal", dooctal);
X
Xvoid dodecimal()
X{
X    base.parameter = 10;
X}
X
XNORMAL_CODE(decimal, octal, "decimal", dodecimal);
X
Xvoid dohex()
X{
X    base.parameter = 16;
X}
X
XNORMAL_CODE(hex, decimal, "hex", dohex);
X
Xvoid doconvert()
X{
X    register char c;
X    register long b;
X    register long n;
X    
X    b = base.parameter;
X    n = snth(0);			
X
X    for (;;) {
X	c = *(char *) tos;
X	if (c < '0' || c > 'z' || (c > '9' && c < 'a')) {
X	    snth(0) = n;
X	    return;
X	}
X	else {
X	    if (c > '9') c = c - 'a' + ':';
X	    c = c - '0';
X	    if (c < 0 || c >= b) {
X		snth(0) = n;
X		return;
X	    }
X	    n = (n * b) + c;
X	    tos += 1;
X	}
X    }
X}
X
XNORMAL_CODE(convert, hex, "convert", doconvert);
X
Xstatic long hld;
X
Xvoid dolesssharp()
X{
X    hld = (long) thepad + PADSIZE;
X}
X
XNORMAL_CODE(lesssharp, convert, "<#", dolesssharp);
X
Xvoid dosharp()
X{
X    long n = tos;
X    
X    tos = (unsigned long) n / (unsigned long) base.parameter;
X    n = (unsigned long) n % (unsigned long) base.parameter;
X    *(char *) --hld = n + ((n > 9) ? 'a' - 10 : '0');
X}
X
XNORMAL_CODE(sharp, lesssharp, "#", dosharp);
X
Xvoid dosharps()
X{
X    do { dosharp(); } while (tos);
X}
X
XNORMAL_CODE(sharps, sharp, "#s", dosharps);
X
Xvoid dohold()
X{
X    *(char *) --hld = spop;
X}
X
XNORMAL_CODE(hold, sharps, "hold", dohold);
X
Xvoid dosign()
X{
X    long flag = spop;
X    
X    if (flag < 0) *(char *) --hld = '-';
X}
X
XNORMAL_CODE(sign, hold, "sign", dosign);
X
Xvoid dosharpgreater()
X{
X    tos = hld;
X    spush(thepad + PADSIZE - hld);
X}
X
XNORMAL_CODE(sharpgreater, sign, "#>", dosharpgreater);
X
Xvoid doqnumber()
X{
X    char *s0;
X    char *s1;
X    
X    s0 = (char *) spop;
X    spush(0);
X    if (*s0 == '-') {
X	spush(s0 + 1);
X    }
X    else {
X	spush(s0);
X    }
X    doconvert();
X    s1 = (char *) spop;
X    if (*s1 == '\0') {
X	if (*s0 == '-') unary(-);
X	spush(TRUE);
X    }
X    else {
X	tos = (long) s0;
X	spush(FALSE);
X    }
X}
X
XNORMAL_CODE(qnumber, sharpgreater, "?number", doqnumber);
X
X
X/* CONTROL STRUCTURES */
X
Xlong docheck(this)
X    int this;
X{
X    ENTRY *last;
X    long follow = spop;
X
X    /* Check if the symbol is in the follow set */
X    if (this & follow) {
X
X	/* Return true is so */
X	return TRUE;
X    }
X    else {
X
X	/* Else report a control structure error */
X	dolast();
X	last = (ENTRY *) spop;
X	(void) printf("%s: illegal control structure\n", last -> name);
X	doabort();
X
X	return FALSE;
X    }
X}
X
Xvoid dodo()
X{
X    spush(&parendo);
X    dothread();
X    doforwardmark();
X    dobackwardmark();
X    spush(LOOP+PLUSLOOP);
X}
X
XCOMPILATION_IMMEDIATE_CODE(kernel_do, qnumber, "do", dodo);
X
Xvoid doqdo()
X{
X    spush(&parenqdo);
X    dothread();
X    doforwardmark();
X    dobackwardmark();
X    spush(LOOP+PLUSLOOP);
X}
X
XCOMPILATION_IMMEDIATE_CODE(kernel_qdo, kernel_do, "?do", doqdo);
X
Xvoid doloop()
X{
X    if (docheck(LOOP)) {
X	spush(&parenloop);
X	dothread();
X	dobackwardresolve();
X	doforwardresolve();
X    }
X}
X
XCOMPILATION_IMMEDIATE_CODE(loop, kernel_qdo, "loop", doloop);
X
Xvoid doplusloop()
X{
X    if (docheck(PLUSLOOP)) {
X	spush(&parenplusloop);
X	dothread();
X	dobackwardresolve();
X	doforwardresolve();
X    }
X}
X
XCOMPILATION_IMMEDIATE_CODE(plusloop, loop, "+loop", doplusloop);
X
Xvoid doleave()
X{
X    rdrop(2);
X    jump(rpop);
X    branch(*ip);
X}
X
XCOMPILATION_CODE(leave, plusloop, "leave", doleave);
X
Xvoid doi()
X{
X    spush(rnth(1));
X}
X
XCOMPILATION_CODE(kernel_i, leave,"i", doi);
X
Xvoid doj()
X{
X    spush(rnth(4));
X}
X
XCOMPILATION_CODE(kernel_j, kernel_i, "j", doj);
X
Xvoid doif()
X{
X    spush(&parenqbranch);
X    dothread();
X    doforwardmark();
X    spush(ELSE+THEN);
X}
X
XCOMPILATION_IMMEDIATE_CODE(kernel_if, kernel_j, "if", doif);
X
Xvoid doelse()
X{
X    if (docheck(ELSE)) {
X	spush(&parenbranch);
X	dothread();
X	doforwardmark();
X	doswap();
X	doforwardresolve();
X	spush(THEN);
X    }
X}
X
XCOMPILATION_IMMEDIATE_CODE(kernel_else, kernel_if, "else", doelse);
X
Xvoid dothen()
X{
X    if (docheck(THEN)) {
X	doforwardresolve();
X    }
X}
X
XCOMPILATION_IMMEDIATE_CODE(kernel_then, kernel_else, "then", dothen);
X
Xvoid docase()
X{
X    spush(0);
X    spush(OF+ENDCASE);
X}
X
XCOMPILATION_IMMEDIATE_CODE(kernel_case, kernel_then, "case", docase);
X
Xvoid doof()
X{
X    if (docheck(OF)) {
X	spush(&over);
X	dothread();
X	spush(&equals);
X	dothread();
X	spush(&parenqbranch);
X	dothread();
X	doforwardmark();
X	spush(&drop);
X	dothread();
X	spush(ENDOF);
X    }
X}
X
XCOMPILATION_IMMEDIATE_CODE(kernel_of, kernel_case, "of", doof);
X
Xvoid doendof()
X{
X    if (docheck(ENDOF)) {
X	spush(&parenbranch);
X	dothread();
X	doforwardmark();
X	doswap();
X	doforwardresolve();
X	spush(OF+ENDCASE);
X    }
X}
X
XCOMPILATION_IMMEDIATE_CODE(endof, kernel_of, "endof", doendof);
X
Xvoid doendcase()
X{
X    if (docheck(ENDCASE)) {
X	spush(&drop);
X	dothread();
X	while (tos) doforwardresolve();
X	dodrop();
X    }
X}
X
XCOMPILATION_IMMEDIATE_CODE(endcase, endof, "endcase", doendcase);
X
Xvoid dobegin()
X{
X    dobackwardmark();
X    spush(AGAIN+UNTIL+WHILE);
X}
X
XCOMPILATION_IMMEDIATE_CODE(begin, endcase, "begin", dobegin);
X
Xvoid dountil()
X{
X    if (docheck(UNTIL)) {
X	spush(&parenqbranch);
X	dothread();
X	dobackwardresolve();
X    }
X}
X
XCOMPILATION_IMMEDIATE_CODE(until, begin, "until", dountil);
X
Xvoid dowhile()
X{
X    if (docheck(WHILE)) {
X	spush(&parenqbranch);
X	dothread();
X	doforwardmark();
X	spush(REPEAT);
X    }
X}
X
XCOMPILATION_IMMEDIATE_CODE(kernel_while, until, "while", dowhile);
X
Xvoid dorepeat()
X{
X    if (docheck(REPEAT)) {
X	spush(&parenbranch);
X	dothread();
X	doswap();
X	dobackwardresolve();
X	doforwardresolve();
X    }
X}
X
XCOMPILATION_IMMEDIATE_CODE(repeat, kernel_while, "repeat", dorepeat);
X
Xvoid doagain()
X{
X    if (docheck(AGAIN)) {
X	spush(&parenbranch);
X	dothread();
X	dobackwardresolve();
X    }
X}
X
XCOMPILATION_IMMEDIATE_CODE(again, repeat, "again", doagain);
X
Xvoid dorecurse()
X{
X    dolast();
X    dothread();
X}
X
XCOMPILATION_IMMEDIATE_CODE(recurse, again, "recurse", dorecurse);
X
Xvoid dotailrecurse()
X{
X    if (theframed) {
X 	spush(&parenunlink);
X	dothread();
X    }
X    dolast();
X    dotobody();
X    spush(&parenbranch);
X    dothread();
X    dobackwardresolve();
X}
X
XCOMPILATION_IMMEDIATE_CODE(tailrecurse, recurse, "tail-recurse", dotailrecurse);
X
Xvoid doexit()
X{
X    jump(rpop);
X}
X
XCOMPILATION_CODE(kernel_exit, tailrecurse, "exit", doexit);
X
Xvoid doexecute()
X{
X    long t = spop;
X
X    docall((ENTRY *) t);
X}
X
XNORMAL_CODE(execute, kernel_exit, "execute", doexecute);
X
Xvoid dobye()
X{
X    quited = FALSE;
X}
X
XNORMAL_CODE(bye, execute, "bye", dobye);
X
X
X/* TERMINAL INPUT-OUTPUT */
X
Xvoid dodot()
X{
X    if (tos < 0) {
X	(void) putchar('-');
X	tos = -tos;
X    }
X    doudot();
X}
X
XNORMAL_CODE(dot, bye, ".", dodot);
X
Xvoid doudot()
X{
X    dolesssharp();
X    dosharps();
X    dosharpgreater();
X    dotype();
X    dospace();
X}
X
XNORMAL_CODE(udot, dot, "u.", doudot);
X
Xvoid doascii()
X{
X    spush(' ');
X    doword();
X    docfetch();
X    doliteral();
X}
X
XIMMEDIATE_CODE(ascii, udot, "ascii", doascii);
X
Xvoid dodotquote()
X{
X    (void) io_scan(thetib, '"');
X    spush(thetib);
X    dostringcopy();
X    spush(&parendotquote);
X    dothread();
X    docomma();
X}
X
XCOMPILATION_IMMEDIATE_CODE(dotquote, ascii, ".\"", dodotquote);
X
Xvoid dodotparen()
X{
X    (void) io_scan(thetib, ')'); 
X    spush(thetib);
X    dostringprint();
X}
X
XIMMEDIATE_CODE(dotparen, dotquote, ".(", dodotparen);
X
Xvoid docr()
X{
X    (void) putchar('\n');
X}
X
XNORMAL_CODE(cr, dotparen, "cr", docr);
X
Xvoid doemit()
X{
X    char c = (char) spop;
X    
X    (void) putchar(c);
X}
X
XNORMAL_CODE(emit, cr, "emit", doemit);
X
Xvoid dotype()
X{
X    long n;
X    char *s;
X
X    n = spop;
X    s = (char *) spop;
X    while (n--) (void) putchar(*s++);
X}
X
XNORMAL_CODE(type, emit, "type", dotype);
X
Xvoid dospace()
X{
X    (void) putchar(' ');
X}
X
XNORMAL_CODE(space, type, "space", dospace);
X
Xvoid dospaces()
X{
X    long n = spop;
X
X    while (n--) (void) putchar(' ');
X}
X
XNORMAL_CODE(spaces, space, "spaces", dospaces);
X
Xvoid dokey()
X{
X    spush(io_getchar());
X}
X
XNORMAL_CODE(key, spaces, "key", dokey);
X
Xvoid doexpect()
X{
X    char *s0;
X    char *s1;
X    char  c;
X    long  n;
X    
X    /* Pop buffer pointer and size */
X    n = spop;
X    s0 = s1 = (char *) spop;
X    
X    /* Fill buffer until end of line or buffer */
X    while (io_not_eof() && (n-- > 0) && ((c = io_getchar()) != '\n')) *s1++ = c;
X
X    /* Set span to number of characters received */
X    span.parameter = (long) (s1 - s0);
X}
X
XNORMAL_CODE(expect, key, "expect", doexpect);
X
XNORMAL_VARIABLE(span, expect, "span", 0);
X
X
X/* PROGRAM BEGINNING AND TERMINATION */
X
Xvoid doforth83()
X{ }
X
XNORMAL_CODE(forth83, span, "forth-83", doforth83);
X    
Xvoid dointerpret()
X{
X    long flag;			/* Flag value returned by for words */
X    long cast;			/* Casting operation flag */
X
X    quited = TRUE;		/* Iterate until bye or end of input */
X
X    while (quited) {
X
X	/* Check stack underflow */
X	if (s0 < sp) {
X	    (void) printf("interpret: stack underflow\n");
X	    doabort();
X	}
X
X	/* Scan for the next symbol */
X	spush(' ');
X	doword();
X
X	/* Exit top loop if end of input stream */
X	if (io_eof()) {
X	    spop;
X	    return;
X	}
X
X	/* Search for the symbol in the current vocabulary search set*/
X	dofind();
X	flag = spop;
X
X	/* Check for vocabulary casting prefix */
X	for (cast = flag; !cast;) {
X	    char *s = (char *) tos;
X	    long l = strlen(s) - 1;
X
X	    /* Assume casting prefix */
X	    cast = TRUE;
X
X	    /* Check casting syntax, vocabulary name within parethesis */ 
X	    if ((s[0] == '(') && (s[l] == ')')) {
X
X		/* Remove the parenthesis from the input string */
X		s[l] = 0;
X		tos++;
X
X		/* Search for the symbol again */
X		dofind();
X		flag = spop;
X		
X		/* If found check that its a vocabulary */
X		if (flag) {
X		    ENTRY *v = (ENTRY *) spop;
X
X		    /* Check that the symbol is really a vocabulary */
X		    if (v -> code == VOCABULARY) {
X
X			/* Scan for a new symbol */
X			spush(' ');
X			doword();
X
X			/* Exit top loop if end of input stream */
X			if (io_eof()) {
X			    spop;
X			    return;
X			}
X
X			/* And look for it in the given vocabulary */
X			spush(v);
X			dolookup();
X			flag = spop;
X			cast = flag;
X		    }
X		}
X	    }
X	}
X	
X	/* If found then execute or thread the symbol */
X	if (flag) {
X	    if (state.parameter == flag)
X		dothread();
X	    else
X		docommand();
X	}
X	else {
X	    /* Else check if it is a number */
X	    doqnumber();
X	    flag = spop;
X	    if (flag) {
X		doliteral();
X	    }
X	    else {
X		/* If not print error message and abort */
X		(void) printf("%s ??\n", tos);
X		doabort();
X	    }
X	}
X    }
X    quited = TRUE;
X}
X
XNORMAL_CODE(interpret, forth83, "interpret", dointerpret);
X
Xvoid doquit()
X{
X    rinit;
X    doleftbracket();
X    dointerpret();
X}
X
XNORMAL_CODE(quit, interpret, "quit", doquit);
X
Xvoid doabort()
X{
X    /* Check if it is the foreground task */
X    if (tp == foreground) {
X	sinit; 
X	doleftbracket();
X	io_flush();
X    }
X
X    /* Terminate aborted tasks */
X    doterminate();
X}
X
XNORMAL_CODE(kernel_abort, quit, "abort", doabort);
X
Xvoid doabortquote()
X{
X    spush('"');
X    doword();
X    dostringcopy();
X    spush(&parenabortquote);
X    dothread();
X    docomma();
X}
X
XCOMPILATION_IMMEDIATE_CODE(abortquote, kernel_abort, "abort\"", doabortquote);
X    
X
X/* DICTIONARY ADDRESSES */
X
Xvoid dohere()
X{
X    spush(dp);
X}
X
XNORMAL_CODE(here, abortquote, "here", dohere);
X
Xstatic char thepad[PADSIZE];
X
XNORMAL_CONSTANT(pad, here, "pad", (long) thepad);
X
Xstatic char thetib[TIBSIZE];
X
XNORMAL_CONSTANT( tib, pad, "tib", (long) thetib);
X
Xvoid dotobody()
X{
X    tos = ((ENTRY *) tos) -> parameter;
X}
X
XNORMAL_CODE(tobody, tib, ">body", dotobody);
X
Xvoid dodotname()
X{
X    ENTRY *e = (ENTRY *) spop;
X    
X    (void) printf("%s", e -> name);
X}
X
XNORMAL_CODE(dotname, tobody, ".name", dodotname);
X
X
X/* COMPILER AND INTERPRETER WORDS */
X
Xvoid dosharpif()
X{
X    long symbol;
X    long flag = spop;
X
X    if (!flag) {
X	do {
X	    spush(' ');
X	    doword();
X	    symbol = spop;
X	    if (STREQ(symbol, "#if")) {
X		dosharpelse();
X		spush(' ');
X		doword();
X		symbol = spop;
X	    }
X	} while (!((STREQ(symbol, "#else") || STREQ(symbol, "#then"))));
X    }
X}
X
XIMMEDIATE_CODE(sharpif, dotname, "#if", dosharpif);
X
Xvoid dosharpelse()
X{
X    long symbol;
X    
X    do {
X	spush(' ');
X	doword();
X	symbol = spop;
X	if (STREQ(symbol, "#if")) {
X	    dosharpelse();
X	    spush(' ');
X	    doword();
X	    symbol = spop;
X	}
X    } while (!STREQ(symbol, "#then"));
X}
X
XIMMEDIATE_CODE(sharpelse, sharpif, "#else", dosharpelse);
X
Xvoid dosharpthen()
X{
X
X}
X
XIMMEDIATE_CODE(sharpthen, sharpelse, "#then", dosharpthen);
X
Xvoid dosharpifdef()
X{
X    spush(' ');
X    doword();
X    dofind();
X    doswap();
X    spop;
X    dosharpif();
X}
X
XIMMEDIATE_CODE(sharpifdef, sharpthen, "#ifdef", dosharpifdef);
X
Xvoid dosharpifundef()
X{
X    spush(' ');
X    doword();
X    dofind();
X    doswap();
X    spop;
X    dozeroequals();
X    dosharpif();
X}
X
XIMMEDIATE_CODE(sharpifundef, sharpifdef, "#ifundef", dosharpifundef);
X
Xvoid dosharpinclude()
X{
X    int  flag;
X    char *fname;
X    
X    spush(' ');
X    doword();
X    fname = (char *) spop;
X    if (flag = io_infile(fname) == IO_UNKNOWN_FILE)
X	(void) printf("%s: file not found\n", fname);
X    else if (flag == IO_TOO_MANY_FILES)
X	(void) printf("%s: too many files open\n", fname);
X}
X
XNORMAL_CODE(sharpinclude, sharpifundef, "#include", dosharpinclude);
X
Xvoid dosharppath()
X{
X    int flag;
X    
X    spush(' ');
X    doword();
X    if (flag = io_path((char *) tos, IO_PATH_FIRST) == IO_UNKNOWN_PATH)
X	(void) printf("%s: unknown environment variable\n", tos);
X    else if (flag == IO_TOO_MANY_PATHS)
X	(void) printf("%s: too many paths defined\n", tos);
X    spop;
X}
X
XNORMAL_CODE(sharppath, sharpinclude, "#path", dosharppath);
X
Xvoid doparen()
X{
X    char c;
X    
X    while (c = io_getchar())
X	if (c == ')') return;
X	else if (c == '(') doparen();
X	else if (io_eof()) return;
X}
X
XIMMEDIATE_CODE(paren, sharppath, "(", doparen);
X
Xvoid dobackslash()
X{
X    io_skip('\n');
X}
X
XIMMEDIATE_CODE(backslash, paren, "\\", dobackslash);
X
Xvoid docomma()
X{
X    *dp++ = spop;
X}
X
XNORMAL_CODE(comma, backslash, ",", docomma);
X
Xvoid doallot()
X{
X    long n = spop;
X
X    dp = (long *) ((char *) dp + n);
X}
X
XNORMAL_CODE(allot, comma, "allot", doallot);
X
Xvoid dodoes()
X{
X    spush((theframed ? &parenunlinkdoes: &parendoes));
X    dothread();
X    doremovelocals();
X}
X
XCOMPILATION_IMMEDIATE_CODE(does, allot, "does>", dodoes);
X
Xvoid doimmediate()
X{
X    ((ENTRY *) current -> parameter) -> mode |= IMMEDIATE;
X}
X
XNORMAL_CODE(immediate, does, "immediate", doimmediate);
X
Xvoid doexecution()
X{
X    ((ENTRY *) current -> parameter) -> mode |= EXECUTION;
X}
X
XNORMAL_CODE(execution, immediate, "execution", doexecution);
X
Xvoid docompilation()
X{
X    ((ENTRY *) current -> parameter) -> mode |= COMPILATION;
X}
X
XNORMAL_CODE(compilation, execution, "compilation", docompilation);
X
Xvoid doprivate()
X{
X    ((ENTRY *) current -> parameter) -> mode |= PRIVATE;
X}
X
XNORMAL_CODE(private, compilation, "private", doprivate);
X
Xvoid dobracketcompile()
X{
X    dotick();
X    dothread();
X}
X
XCOMPILATION_IMMEDIATE_CODE(bracketcompile, private, "[compile]", dobracketcompile);
X
Xvoid docompile()
X{
X    spush(*ip++);
X    dothread();
X}
X
XCOMPILATION_CODE(compile, bracketcompile, "compile", docompile);
X
Xvoid doqcompile()
X{
X    if (state.parameter) docompile();
X}
X
XCOMPILATION_CODE(qcompile, compile, "?compile", doqcompile);
X
XNORMAL_VARIABLE(state, qcompile, "state", FALSE);
X
Xvoid docompiling()
X{
X    spush(state.parameter);
X}
X
XNORMAL_CODE(compiling, state, "compiling", docompiling);
X
Xvoid doliteral()
X{
X    if (state.parameter) {
X	spush(&parenliteral);
X	dothread();
X	docomma();
X    }
X}
X
XCOMPILATION_IMMEDIATE_CODE(literal, compiling, "literal", doliteral);
X
Xvoid doleftbracket()
X{
X    state.parameter = FALSE;
X}
X
XIMMEDIATE_CODE(leftbracket, literal, "[", doleftbracket);
X
Xvoid dorightbracket()
X{
X    state.parameter = TRUE;
X}
X
XNORMAL_CODE(rightbracket, leftbracket, "]", dorightbracket);
X
Xvoid doword()
X{
X    char brkchr = (char) spop;
X    
X    (void) io_skipspace();
X    (void) io_scan(thetib, brkchr);
X    spush(thetib);
X}
X
XNORMAL_CODE(kernel_word, rightbracket, "word", doword);
X
X
X/* VOCABULARIES */
X
XNORMAL_CONSTANT(kernel_context, kernel_word, "context", (long) context);
X
XNORMAL_CONSTANT(kernel_current, kernel_context, "current", (long) &current);
X
Xvoid dolast()
X{
X    spush((theframed ? (long) theframed : current -> parameter));
X}
X
XNORMAL_CODE(last, kernel_current, "last", dolast);
X
Xvoid dodefinitions()
X{
X    current = context[0];
X}
X
XNORMAL_CODE(definitions, last, "definitions", dodefinitions);
X
Xvoid doonly()
X{
X    long v;
X
X    /* Flush the entry cache */
X    spush(FALSE);
X    dorestore();
X
X    /* Remove all vocabularies except the first */
X    for (v = 1; v < CONTEXTSIZE; v++) context[v] = (ENTRY *) NIL;
X
X    /* And make it definition vocabulary */
X    current = context[0];
X}
X
XNORMAL_CODE(only, definitions, "only", doonly);
X
Xvoid dorestore()
X{
X    register long i;		/* Iteration variable */
X    register ENTRY *e;		/* Pointer to parameter entry */
X    register ENTRY *p;		/* Pointer to current entry */
X
X    /* Access parameter and check if an entry */
X    e = (ENTRY *) spop;
X    if (e) {
X
X	/* Flush all enties until the parameter symbol */
X	for (p = (ENTRY *) current -> parameter; p && (p != e); p = p -> link)
X	    cache[hash(p -> name)] = (ENTRY *) NIL;
X
X	/* If the entry was found remove all symbols until this entry */
X	if (p == e) current -> parameter = (long) e;
X    }
X    else {
X	
X	/* Flush the entry cache */
X	for (i = 0; i < CACHESIZE; i++) cache[i] = (ENTRY *) NIL;
X    }
X}
X
XNORMAL_CODE(restore, only, "restore", dorestore);
X
Xvoid dotick()
X{
X    long flag;
X
X    spush(' ');
X    doword();
X    dofind();
X    flag = spop;
X    if (!flag) {
X	(void) printf("%s: unknown symbol\n", tos);
X	doabort();
X    }
X}
X
XNORMAL_CODE(tick, restore, "'", dotick);
X
Xvoid dobrackettick()
X{
X    dotick();
X    doliteral();
X}
X
XCOMPILATION_IMMEDIATE_CODE(brackettick, tick, "[']", dobrackettick);
X
Xvoid dolookup() 
X{
X    register ENTRY *v;		/* Vocabulary pointer */
X    register ENTRY *e;		/* Entry pointer */
X    register char  *s;		/* Symbol to be found */
X    
X    /* Fetch parameters and initate entry pointer */
X    v = (ENTRY *) spop;
X    s = (char *) tos;
X    
X    /* Iterate over the linked list of entries */
X    for (e = (ENTRY *) v -> parameter; e; e = e -> link)
X
X	/* Compare the symbol and entry string */
X	if (STREQ(s, e -> name)) {
X
X	    /* Check if the entry is currently visible */
X	    if (!(((e -> mode & COMPILATION) && (!state.parameter)) ||
X		  ((e -> mode & EXECUTION) && (state.parameter))  ||
X		  ((e -> mode & PRIVATE) && (v != current)))) {
X
X		/* Return the entry and compilation mode */
X		tos = (long) e;
X		spush((e -> mode & IMMEDIATE ? 1 : -1));
X		return;
X	    }
X	}
X    spush(FALSE);
X}
X
XNORMAL_CODE(lookup, brackettick, "lookup", dolookup);
X
X#ifdef PROFILE
Xvoid docollision()
X{
X    /* Add collision statistics to profile information */
X}
X#endif
X
Xvoid dofind()
X{
X    ENTRY *e;			/* Entry in the entry cache */
X    char  *n;			/* Name string of entry to be found */
X    long  v;			/* Index into vocabulary set */
X    
X    /* Access the string to be found */
X    n = (char *) tos;
X
X    /* Check for cached entry */
X    if (e = cache[hash(n)]) {
X
X	/* Compare the string and the entry name */
X	if (STREQ(tos, e -> name)) {
X
X	    /* Check if the entry is currently visible */
X	    if (!(((e -> mode & COMPILATION) && (!state.parameter)) ||
X		  ((e -> mode & EXECUTION) && (state.parameter)))) {
X		tos = (long) e;
X		spush((e -> mode & IMMEDIATE ? 1 : -1));
X		return;
X	    }
X	}
X#ifdef PROFILE
X	else {
X	    docollision();
X	}
X#endif	
X    }
X    
X    /* For each vocabulary in the current search chain */
X    for (v = 0; context[v] && v < CONTEXTSIZE; v++) {
X	spush(context[v]);
X	dolookup();
X	if (tos) {
X	    cache[hash(n)] = (ENTRY *) snth(0);
X	    return;
X	}
X	else {
X	    spop;
X	}
X    }
X    spush(FALSE);
X}
X
XNORMAL_CODE(find, lookup, "find", dofind);
X
Xvoid doforget()
X{
X    dotick();
X    tos = (long) ((ENTRY *) tos) -> link; 
X    dorestore();
X}
X
XNORMAL_CODE(forget, find, "forget", doforget);
X
Xvoid dowords()
X{
X    ENTRY *e;			/* Pointer to entries */
X    long   v;			/* Index into vocabulary set */
X    long   l;			/* String length */
X    long   s;			/* Spaces between words */
X    long   c;			/* Column counter */
X    long   i;			/* Loop index */
X    
X    /* Iterate over all vocabularies in the search set */
X    for (v = 0; v < CONTEXTSIZE && context[v]; v++) {
X
X	/* Print vocabulary name */
X	(void) printf("VOCABULARY %s", context[v] -> name);
X	if (context[v] == current) (void) printf(" DEFINITIONS");
X	(void) putchar('\n');
X
X	/* Access linked list of enties and initiate column counter */
X	c = 0;
X
X	/* Iterate over all entries in the vocabulary */
X	for (e = (ENTRY *) context[v] -> parameter; e; e = e -> link) {
X
X	    /* Check if the entry is current visible */
X	    if (!(((e -> mode & COMPILATION) && (!state.parameter)) ||
X		  ((e -> mode & EXECUTION) && (state.parameter))  ||
X		  ((e -> mode & PRIVATE) && (context[v] != current)))) {
X		
X		/* Print the entry string. Check that space is available */
X		l = strlen(e -> name);
X		s = (c ? (COLUMNWIDTH - (c % COLUMNWIDTH)) : 0);
X		c = c + s + l;
X		if (c < LINEWIDTH) {
X		    for (i = 0; i < s; i++) (void) putchar(' '); 
X		}
X		else {
X		    (void) putchar('\n');
X		    c = l;
X		}
X		(void) printf("%s", e -> name);
X	    }
X	}
X
X	/* End the list of words and separate the vocabularies */
X	(void) putchar('\n');
X	(void) putchar('\n');
X    }
X}
X
XIMMEDIATE_CODE(words, forget, "words", dowords);
X
X
X/* DEFINING NEW VOCABULARY ENTRIES */
X
XENTRY *makeentry(name, code, mode, parameter)
X    char *name;			/* String for the new entry */
X    long code, mode, parameter; /* Entry parameters */
X{
X    /* Allocate space for the entry */
X    ENTRY *e = (ENTRY *) malloc(sizeof(ENTRY));
X
X    /* Insert into the current vocabulary and set parameters */
X    e -> link = (ENTRY *) current -> parameter;
X    current -> parameter = (long) e;
X
X    /* Set entry parameters */
X    e -> name = strcpy(malloc((unsigned) strlen(name) + 1), name);
X    e -> code = code;
X    e -> mode = mode;
X    e -> parameter = parameter;
X
X    /* Cache entry */
X    cache[hash(name)] = e;
X    
X    /* Return pointer to the new entry */
X    return e;
X}
X
Xvoid doentry()
X{
X    long flag, name, code, mode, parameter;
X    ENTRY *forward;
X    
X    /* Try to find entry to check for forward declarations */
X    forward = (ENTRY *) NIL;
X    dodup();
X    dofind();
X    flag = spop;
X    if (flag) {
X	forward = (ENTRY *) spop;
X    }
X    else {
X	spop;
X    }
X    
X    /* Access name, code, mode and parameter field parameters */
X    name = spop;
X    code = spop;
X    mode = spop;
X    parameter = spop;
X
X    /* Create the new entry */
X    (void) makeentry((char *) name, code, mode, parameter);
X
X    /* If found and forward the redirect parameter field of initial entry */
X    if (forward && forward -> code == FORWARD) {
X	forward -> parameter = current -> parameter;
X	if (verbose)
X	    (void) printf("%s: forward definition resolved\n", forward -> name);
X    }
X}
X
XNORMAL_CODE(kernel_entry, words, "entry", doentry);
X
Xvoid doforward()
X{
X    spush(0);
X    spush(NORMAL);
X    spush(FORWARD);
X    spush(' ');
X    doword();
X    doentry();
X}
X
XNORMAL_CODE(forward, kernel_entry, "forward", doforward);
X
Xstatic ENTRY *thelast = (ENTRY *) NIL;
X
Xvoid docolon()
X{
X    align(dp);
X    dohere();
X    spush(HIDDEN);
X    spush(COLON);
X    spush(' ');
X    doword();
X    doentry();
X    dorightbracket();
X    thelast = (ENTRY *) current -> parameter;
X}
X
XNORMAL_CODE(colon, forward, ":", docolon);
X
Xvoid dosemicolon()
X{
X    spush((theframed ? &parenunlinksemicolon : &parensemicolon));
X    dothread();
X    doleftbracket();
X    doremovelocals();
X    if (thelast) {
X	thelast -> mode = NORMAL;
X	cache[hash(thelast -> name)] = thelast;
X	thelast = (ENTRY *) NIL;
X    }
X}
X
XCOMPILATION_IMMEDIATE_CODE(semicolon, colon, ";", dosemicolon);
X
Xvoid docreate()
X{
X    align(dp);
X    dohere();
X    spush(NORMAL);
X    spush(CREATE);
X    spush(' ');
X    doword();
X    doentry();
X}
X
XNORMAL_CODE(create, semicolon, "create", docreate);
X
Xvoid dovariable()
X{
X    spush(0);
X    spush(NORMAL);
X    spush(VARIABLE);
X    spush(' ');
X    doword();
X    doentry();
X}
X
XNORMAL_CODE(variable, create, "variable", dovariable);
X
Xvoid doconstant()
X{
X    spush(NORMAL);
X    spush(CONSTANT);
X    spush(' ');
X    doword();
X    doentry();
X}
X
XNORMAL_CODE(constant, variable, "constant", doconstant);
X
Xvoid dovocabulary()
X{
X    spush(&forth);
X    spush(NORMAL);
X    spush(VOCABULARY);
X    spush(' ');
X    doword();
X    doentry();
X}
X
XNORMAL_CODE(vocabulary, constant, "vocabulary", dovocabulary);
X
Xvoid dofield()
X{
X    spush(NORMAL);
X    spush(FIELD);
X    spush(' ');
X    doword();
X    doentry();
X}
X
XNORMAL_CODE(field, vocabulary, "field", dofield);
X
X
X/* INITIALIZATION OF THE KERNEL */
X
Xvoid kernel_initiate(first, last, users, parameters, returns)
X    ENTRY *first, *last;
X    int users, parameters, returns;
X{
X    /* Link user symbols into vocabulary chain if given */
X    if (first && last) {
X	forth.parameter = (long) first;
X	last -> link = (ENTRY *) &field;
X    }
X    
X    /* Create the foreground task object */
X    foreground = maketask((long) users, (long) parameters, (long) returns, NIL);
X    
X    s0 = foreground -> s0;
X    sp = foreground -> sp;
X    r0 = foreground -> r0;
X    rp = foreground -> rp;
X    ip = foreground -> ip;
X    fp = foreground -> fp;
X    ep = foreground -> ep;
X
X    /* Make the foreground task the current task */
X    tp = foreground;
X
X}
X
Xvoid kernel_finish()
X{
X    /* Future clean up function for kernel */
X}
END_OF_kernel.c
if test 57109 -ne `wc -c <kernel.c`; then
    echo shar: \"kernel.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
echo shar: End of archive 7 \(of 7\).
cp /dev/null ark7isdone
MISSING=""
for I in 1 2 3 4 5 6 7 ; do
    if test ! -f ark${I}isdone ; then
	MISSING="${MISSING} ${I}"
    fi
done
if test "${MISSING}" = "" ; then
    echo You have unpacked all 7 archives.
    rm -f ark[1-9]isdone
else
    echo You still need to unpack the following archives:
    echo "        " ${MISSING}
fi
##  End of shell archive.
exit 0