TILE FORTH PACKAGE 7(7)
Mikael Patel
mip at massormetrix.ida.liu.se
Tue Dec 19 04:54:02 AEST 1989
#! /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 at 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 at 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) ¤t);
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
More information about the Alt.sources
mailing list