Source Code 1992 March/Source_Code_CD-ROM_Walnut_Creek_March_1992.iso/usenet/altsrcs/1/1594

Internet Message Format | 1990-12-28 | 52.9 KB

From: [e-mail] (Mikael Patel)
Newsgroups: alt.sources
Subject: TILE Forth Release 2.0, package 6 of 6
Message-ID: <[e-mail]>
Date: 16 Jul 90 18:59:37 GMT


#! /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 6 (of 6)."
# Contents:  src/kernel.c
# Wrapped by mip@mina on Fri Jun 29 16:49:14 1990
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f src/kernel.c -a "${1}" != "-c" ; then
  echo shar: Will not over-write existing file \"src/kernel.c\"
else
echo shar: Extracting \"src/kernel.c\" \(49941 characters\)
sed "s/^X//" >src/kernel.c <<'END_OF_src/kernel.c'
X/*
X  C BASED FORTH-83 MULTI-TASKING KERNEL
X
X  Copyright (c) 1988-1990 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: [e-mail]
X
X  Started on: 30 June 1988
X
X  Last updated on: 25 June 1990
X
X  Dependencies:
X      (cc) kernel.h, error.h, memory.h, io.c, compiler.v,
X         locals.v, string.v, float.v, memory.v, queues.v,
X         multi-tasking.v, and exceptions.v.
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 floating point numbers, argument binding and local
X       variables, exception handling, queue data management, multi-tasking,
X       symbol hiding and casting, forwarding, null terminated string,
X       memory allocation, file search paths, and source library module
X       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 code_entry qnumber;
Xextern code_entry terminate;
Xextern code_entry abort_entry;
Xextern entry toexception;
Xextern entry span;
Xextern entry state;
Xextern code_entry vocabulary;
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
XINT32 verbose;            /* Application or programming mode */
XINT32 quited;            /* Interpreter toploop state */
XINT32 running;            /* Task switch flag */
XINT32 tasking;            /* Multi-tasking flag */
X
XTASK tp;            /* Task pointer */
XTASK foreground;        /* Foreground task pointer */
X
X
X/* FORTH MACHINE REGISTERS */
X
XUNIV tos;            /* Top of stack register */
XPTR sp;                /* Parameter stack pointer */
XPTR s0;                /* Bottom of parameter stack pointer */
X
XPTR32 ip;            /* Instruction pointer */
XPTR32 rp;            /* Return stack pointer */
XPTR32 r0;            /* Bottom of return stack pointer */
X
XPTR32 fp;            /* Argument frame pointer */
XPTR32 ep;            /* Exception frame pointer */
X
X
X/* VOCABULARY SEARCH LISTS */
X
X#define CONTEXTSIZE 64
X
Xstatic VOCABULARY_ENTRY current = &forth;
Xstatic VOCABULARY_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
XPTR32 dictionary;
XPTR32 dp;
X
X
X/* INTERNAL STRUCTURE AND SIZES */
X
Xstatic INT32 hld;
Xstatic ENTRY thelast = NIL;
X
X#define PADSIZE 84
Xstatic CHAR thepad[PADSIZE];
X
X#define TIBSIZE 256
Xstatic CHAR thetib[TIBSIZE];
X
X
X/* INNER MULTI-TASKING FORTH VIRTUAL MACHINE */
X
XVOID doinner()
X{
X    INT32 e;
X
X    /* Exception marking and handler */
X    if (e = setjmp(restart)) {
X    spush(e, INT32);
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    register ENTRY p = (ENTRY) *ip++;
X
X    /* Select on type of entry */
X    switch (p -> code) {
X      case CODE:
X        ((SUBR) (p -> parameter))();
X        break;
X      case COLON:
X        rpush(ip);
X        fjump(p -> parameter);
X        break;
X      case VARIABLE:
X        spush(&(p -> parameter), PTR32);
X        break;
X      case CONSTANT:
X        spush(p -> parameter, INT32);
X        break;
X      case VOCABULARY:
X        doappend((VOCABULARY_ENTRY) p);
X        break;
X      case CREATE:
X        spush(p -> parameter, INT32);
X        break;
X      case USER:
X        spush(((INT32) tp) + p -> parameter, INT32);
X        break;
X      case LOCAL:
X        spush(*((PTR32) (INT32) fp - p -> parameter), INT32);
X        break;
X      case FORWARD:
X        if (p -> parameter)
X        docall((ENTRY) p -> parameter);
X        else {
X        if (io_source())
X            (VOID) fprintf(io_errf, "%s:%i:", io_source(), io_line());
X        (VOID) fprintf(io_errf, "%s: unresolved forward entry\n", p -> name);
X        doabort();
X        }
X        break;
X      case EXCEPTION:
X        spush(p, ENTRY);
X        break;
X      case FIELD:
X        unary(p -> parameter +, INT32);
X        break;
X      default: /* DOES: FORTH LEVEL INTERPRETATION */
X        rpush(ip);
X        spush(p -> parameter, INT32);
X        fjump(p -> code);
X        break;
X    }
X    }
X}
X
XVOID docommand()
X{
X    INT32 e;
X
X    /* Exception marking and handler */
X    if (e = setjmp(restart)) {
X    spush(e, INT32);
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    ((SUBR) (p -> parameter))();
X    return;
X      case COLON:
X    rpush(ip);
X    fjump(p -> parameter);
X    return;
X      case VARIABLE:
X    spush(&(p -> parameter), PTR32);
X    return;
X      case CONSTANT:
X    spush(p -> parameter, INT32);
X    return;
X      case VOCABULARY:
X    doappend((VOCABULARY_ENTRY) p);
X    return;
X      case CREATE:
X    spush(p -> parameter, INT32);
X    return;
X      case USER:
X    spush(((INT32) tp) + p -> parameter, INT32);
X    return;
X      case LOCAL:
X    spush(*((PTR32) (INT32) fp - p -> parameter), INT32);
X    return;
X      case FORWARD:
X    if (p -> parameter)
X        docall((ENTRY) p -> parameter);
X    else {
X        if (io_source())
X        (VOID) fprintf(io_errf, "%s:%i:", io_source(), io_line());
X        (VOID) fprintf(io_errf, "%s: unresolved forward entry\n", p -> name);
X        doabort();
X    }
X    return;
X      case EXCEPTION:
X    spush(p, ENTRY);
X    return;
X      case FIELD:
X    unary(p -> parameter +, INT32);
X    return;
X      default: /* DOES: FORTH LEVEL INTERPRETATION */
X    rpush(ip);
X    spush(p -> parameter, INT32);
X    fjump(p -> code);
X    return;
X    }
X}
X
XVOID doappend(p)
X    VOCABULARY_ENTRY p;
X{
X    INT32 v;
X
X    /* Flush the entry cache */
X    spush(FALSE, BOOL);
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 AND EXTERNAL VOCABULARIES */
X
Xvocabulary_entry forth = {NIL, "forth", NORMAL, VOCABULARY, (ENTRY) &vocabulary, (ENTRY) &qnumber};
X
X
X/* COMPILER EXTENSIONS */
X
X#include "compiler.v"
X
XNORMAL_VOCABULARY(compiler, forth, "compiler", &backwardresolve, NIL);
X
X
X/* LOCAL VARIABLES AND ARGUMENT BINDING */
X
X#include "locals.v"
X
XNORMAL_VOCABULARY(locals, compiler, "locals", &curlebracket, NIL);
X
X
X/* NULL TERMINATED STRING */
X
X#include "string.v"
X
XNORMAL_VOCABULARY(string, locals, "string", &sprint, NIL);
X
X
X/* FLOATING POINT */
X
X#include "float.v"
X
XNORMAL_VOCABULARY(float_entry, string, "float", &qfloat, &qfloat);
X
X
X/* MEMORY MANAGEMENT */
X
X#include "memory.v"
X
XNORMAL_VOCABULARY(memory, float_entry, "memory", &free_entry, NIL);
X
X
X/* DOUBLE LINKED LISTS */
X
X#include "queues.v"
X
XNORMAL_VOCABULARY(queues, memory, "queues", &dequeue, NIL);
X
X
X/* MULTI-TASKING EXTENSIONS */
X
X#include "multi-tasking.v"
X
XNORMAL_VOCABULARY(multitasking, queues, "multi-tasking", &terminate, NIL);
X
X
X/* SIGNAL AND EXCEPTION MANAGEMENT */
X
X#include "exceptions.v"
X
XNORMAL_VOCABULARY(exceptions, multitasking, "exceptions", &raise, NIL);
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, INT32);
X}
X
XNORMAL_CODE(boolean, true, "boolean", doboolean);
X
XVOID donot()
X{
X    unary(~, INT32);
X}
X
XNORMAL_CODE(not, boolean, "not", donot);
X
XVOID doand()
X{
X    binary(&, INT32);
X}
X
XNORMAL_CODE(and, not, "and", doand);
X
XVOID door()
X{
X    binary(|, INT32);
X}
X
XNORMAL_CODE(or, and, "or", door);
X
XVOID doxor()
X{
X    binary(^, INT32);
X}
X
XNORMAL_CODE(xor, or, "xor", doxor);
X
XVOID doqwithin()
X{
X    register INT32 value;
X    register INT32 upper;
X    register INT32 lower;
X
X    upper = spop(INT32);
X    lower = spop(INT32);
X    value = spop(INT32);
X
X    spush((value > upper) || (value < lower) ? FALSE : TRUE, BOOL);
X}
X
XNORMAL_CODE(qwithin, xor, "?within", doqwithin);
X
X
X/* STACK MANIPULATION */
X
XVOID dodepth()
X{
X    register PTR32 t;
X
X    t = (PTR32) sp;
X    spush(((PTR32) s0 - t), INT32);
X}
X
XNORMAL_CODE(depth, qwithin, "depth", dodepth);
X
XVOID dodrop()
X{
X    sdrop();
X}
X
XNORMAL_CODE(drop, depth, "drop", dodrop);
X
XVOID donip()
X{
X    snip();
X}
X
XNORMAL_CODE(nip, drop, "nip", donip);
X
XVOID doswap()
X{
X    sswap();
X}
X
XNORMAL_CODE(swap, nip, "swap", doswap);
X
XVOID dorot()
X{
X    srot();
X}
X
XNORMAL_CODE(rot, swap, "rot", dorot);
X
XVOID dodashrot()
X{
X    sdashrot();
X}
X
XNORMAL_CODE(dashrot, rot, "-rot", dodashrot);
X
XVOID doroll()
X{
X    register UNIV e;
X    register PTR s;
X
X    /* Fetch roll parameters: number and element */
X    e = snth(tos.INT32);
X
X    /* Roll the stack */
X    for (s = sp + tos.INT32; 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, dashrot, "roll", doroll);
X
XVOID doqdup()
X{
X    if (tos.INT32) sdup();
X}
X
XNORMAL_CODE(qdup, roll, "?dup", doqdup);
X
XVOID dodup()
X{
X    sdup();
X}
X
XNORMAL_CODE(dup_entry, qdup, "dup", dodup);
X
XVOID doover()
X{
X    sover();
X}
X
XNORMAL_CODE(over, dup_entry, "over", doover);
X
XVOID dotuck()
X{
X    stuck();
X}
X
XNORMAL_CODE(tuck, over, "tuck", dotuck);
X
XVOID dopick()
X{
X    tos = snth(tos.INT32);
X}
X
XCOMPILATION_CODE(pick, tuck, "pick", dopick);
X
XVOID dotor()
X{
X    rpush(spop(INT32));
X}
X
XCOMPILATION_CODE(tor, pick, ">r", dotor);
X
XVOID dofromr()
X{
X    spush(rpop(), INT32);
X}
X
XCOMPILATION_CODE(fromr, tor, "r>", dofromr);
X
XVOID docopyr()
X{
X    spush(*rp, INT32);
X}
X
XCOMPILATION_CODE(copyr, fromr, "r@", docopyr);
X
XVOID dotwotor()
X{
X    rpush(spop(INT32));
X    rpush(spop(INT32));
X}
X
XCOMPILATION_CODE(twotor, copyr, "2>r", dotwotor);
X
XVOID dotwofromr()
X{
X    spush(rpop(), INT32);
X    spush(rpop(), INT32);
X}
X
XCOMPILATION_CODE(twofromr, twotor, "2r>", dotwofromr);
X
XVOID dotwodrop()
X{
X    sndrop(1);
X}
X
XNORMAL_CODE(twodrop, twofromr, "2drop", dotwodrop);
X
XVOID dotwoswap()
X{
X    register UNIV t;
X
X    t = tos;
X    tos = snth(1);
X    snth(1) = t;
X
X    t = snth(0);
X    snth(0) = snth(2);
X    snth(2) = t;
X}
X
XNORMAL_CODE(twoswap, twodrop, "2swap", dotwoswap);
X
XVOID dotworot()
X{
X    register UNIV t;
X
X    t = tos;
X    tos = snth(3);
X    snth(3) = snth(1);
X    snth(1) = t;
X
X    t = snth(0);
X    snth(0) = snth(4);
X    snth(4) = snth(2);
X    snth(2) = t;
X}
X
XNORMAL_CODE(tworot, twoswap, "2rot", dotworot);
X
XVOID dotwodup()
X{
X    spush(snth(1).INT32, INT32);
X    spush(snth(1).INT32, INT32);
X}
X
XNORMAL_CODE(twodup, tworot, "2dup", dotwodup);
X
XVOID dotwoover()
X{
X    spush(snth(3).INT32, INT32);
X    spush(snth(3).INT32, INT32);
X}
X
XNORMAL_CODE(twoover, twodup, "2over", dotwoover);
X
X
X/* COMPARISON */
X
XVOID dolessthan()
X{
X    relation(<, INT32);
X}
X
XNORMAL_CODE(lessthan, twoover, "<", dolessthan);
X
XVOID doequals()
X{
X    relation(==, INT32);
X}
X
XNORMAL_CODE(equals, lessthan, "=", doequals);
X
XVOID dogreaterthan()
X{
X    relation(>, INT32);
X}
X
XNORMAL_CODE(greaterthan, equals, ">", dogreaterthan);
X
XVOID dozeroless()
X{
X    compare(< 0, INT32);
X}
X
XNORMAL_CODE(zeroless, greaterthan, "0<", dozeroless);
X
XVOID dozeroequals()
X{
X    compare(== 0, INT32);
X}
X
XNORMAL_CODE(zeroequals, zeroless, "0=", dozeroequals);
X
XVOID dozerogreater()
X{
X    compare(> 0, INT32);
X}
X
XNORMAL_CODE(zerogreater, zeroequals, "0>", dozerogreater);
X
XVOID doulessthan()
X{
X    relation(<, NUM32);
X}
X
XNORMAL_CODE(ulessthan, zerogreater, "u<", doulessthan);
X
X
X/* CONSTANTS */
X
XNORMAL_CONSTANT(nil, ulessthan, "nil", NIL);
X
XNORMAL_CONSTANT(minusfour, nil, "-4", -4);
X
XNORMAL_CONSTANT(minustwo, minusfour, "-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
XNORMAL_CONSTANT(four, two, "4", 4);
X
X
X/* ARITHMETRIC */
X
XVOID doplus()
X{
X    binary(+, INT32);
X}
X
XNORMAL_CODE(plus, four, "+", doplus);
X
XVOID dominus()
X{
X    binary(-, INT32);
X}
X
XNORMAL_CODE(minus, plus, "-", dominus);
X
XVOID dooneplus()
X{
X    unary(++, INT32);
X}
X
XNORMAL_CODE(oneplus, minus, "1+", dooneplus);
X
XVOID dooneminus()
X{
X    unary(--, INT32);
X}
X
XNORMAL_CODE(oneminus, oneplus, "1-", dooneminus);
X
XVOID dotwoplus()
X{
X    unary(2 +, INT32);
X}
X
XNORMAL_CODE(twoplus, oneminus, "2+", dotwoplus);
X
XVOID dotwominus()
X{
X    unary(-2 +, INT32);
X}
X
XNORMAL_CODE(twominus, twoplus, "2-", dotwominus);
X
XVOID dotwotimes()
X{
X    tos.INT32 <<= 1;
X}
X
XNORMAL_CODE(twotimes, twominus, "2*", dotwotimes);
X
XVOID doleftshift()
X{
X    binary(<<, INT32);
X}
X
XNORMAL_CODE(leftshift, twotimes, "<<", doleftshift);
X
XVOID dotimes()
X{
X    binary(*, INT32);
X}
X
XNORMAL_CODE(times_entry, leftshift, "*", dotimes);
X
XVOID doumtimes()
X{
X    binary(*, NUM32);
X}
X
XNORMAL_CODE(utimes_entry, times_entry, "um*", doumtimes);
X
XVOID doumdividemod()
X{
X    register NUM32 t;
X
X    t = snth(0).NUM32;
X    snth(0).NUM32 = t % tos.NUM32;
X    tos.NUM32 = t / tos.NUM32;
X}
X
XNORMAL_CODE(umdividemod, utimes_entry, "um/mod", doumdividemod);
X
XVOID dotwodivide()
X{
X    tos.INT32 >>= 1;
X}
X
XNORMAL_CODE(twodivide, umdividemod, "2/", dotwodivide);
X
XVOID dorightshift()
X{
X    binary(>>, INT32);
X}
X
XNORMAL_CODE(rightshift, twodivide, ">>", dorightshift);
X
XVOID dodivide()
X{
X    binary(/, INT32);
X}
X
XNORMAL_CODE(divide, rightshift, "/", dodivide);
X
XVOID domod()
X{
X    binary(%, INT32);
X}
X
XNORMAL_CODE(mod, divide, "mod", domod);
X
XVOID dodividemod()
X{
X    register INT32 t;
X
X    t = snth(0).INT32;
X    snth(0).INT32 = t % tos.INT32;
X    tos.INT32 = t / tos.INT32;
X}
X
XNORMAL_CODE(dividemod, mod, "/mod", dodividemod);
X
XVOID dotimesdividemod()
X{
X    register INT32 t;
X
X    t = spop(INT32);
X    tos.INT32 = tos.INT32 * snth(0).INT32;
X    snth(0).INT32 = tos.INT32 % t;
X    tos.INT32 = tos.INT32 / t;
X}
X
XNORMAL_CODE(timesdividemod, dividemod, "*/mod", dotimesdividemod);
X
XVOID dotimesdivide()
X{
X    register INT32 t;
X
X    t = spop(INT32);
X    binary(*, INT32);
X    spush(t, INT32);
X    binary(/, INT32);
X}
X
XNORMAL_CODE(timesdivide, timesdividemod, "*/", dotimesdivide);
X
XVOID domin()
X{
X    register INT32 t;
X
X    t = spop(INT32);
X    tos.INT32 = (t < tos.INT32 ? t : tos.INT32);
X}
X
XNORMAL_CODE(min, timesdivide, "min", domin);
X
XVOID domax()
X{
X    register INT32 t;
X
X    t = spop(INT32);
X    tos.INT32 = (t > tos.INT32 ? t : tos.INT32);
X}
X
XNORMAL_CODE(max, min, "max", domax);
X
XVOID doabs()
X{
X    tos.INT32 = (tos.INT32 < 0 ? - tos.INT32 : tos.INT32);
X}
X
XNORMAL_CODE(abs_entry, max, "abs", doabs);
X
XVOID donegate()
X{
X    unary(-, INT32);
X}
X
XNORMAL_CODE(negate, abs_entry, "negate", donegate);
X
X
X/* MEMORY */
X
XVOID dofetch()
X{
X    unary(*(PTR32), INT32);
X}
X
XNORMAL_CODE(fetch, negate, "@", dofetch);
X
XVOID dostore()
X{
X    register PTR32 t;
X
X    t = spop(PTR32);
X    *t = spop(INT32);
X}
X
XNORMAL_CODE(store, fetch, "!", dostore);
X
XVOID dowfetch()
X{
X    unary(*(PTR16), INT32);
X}
X
XNORMAL_CODE(wfetch, store, "w@", dowfetch);
X
XVOID dowstore()
X{
X    register PTR16 t;
X
X    t = spop(PTR16);
X    *t = spop(INT32);
X}
X
XNORMAL_CODE(wstore, wfetch, "w!", dowstore);
X
XVOID docfetch()
X{
X    unary(*(CSTR), INT32);
X}
X
XNORMAL_CODE(cfetch, wstore, "c@", docfetch);
X
XVOID docstore()
X{
X    register CSTR t;
X
X    t = spop(CSTR);
X    *t = spop(INT32);
X}
X
XNORMAL_CODE(cstore, cfetch, "c!", docstore);
X
XVOID doffetch()
X{
X    register INT32 pos;
X    register INT32 width;
X
X    width = spop(INT32);
X    pos = spop(INT32);
X    tos.INT32 = (tos.INT32 >> pos) & ~(-1 << width);
X}
X
XNORMAL_CODE(ffetch, cstore, "f@", doffetch);
X
XVOID dolessffetch()
X{
X    register INT32 pos;
X    register INT32 width;
X
X    width = spop(INT32);
X    pos = spop(INT32);
X    tos.INT32 = (tos.INT32 >> pos) & ~(-1 << width);
X    if ((1 << (width - 1)) & tos.INT32) {
X    tos.INT32 = (tos.INT32) | (-1 << width);
X    }
X}
X
XNORMAL_CODE(lessffetch, ffetch, "<f@", dolessffetch);
X
XVOID dofstore()
X{
X    register INT32 pos;
X    register INT32 width;
X    register INT32 value;
X
X    width = spop(INT32);
X    pos = spop(INT32);
X    value = spop(INT32);
X    tos.INT32 = ((tos.INT32 & ~(-1 << width)) << pos) | (value & ~((~(-1 << width)) << pos));
X}
X
XNORMAL_CODE(fstore, lessffetch, "f!", dofstore);
X
XVOID dobfetch()
X{
X    register INT32 bit;
X
X    bit = spop(INT32);
X    tos.INT32 = (((tos.INT32 >> bit) & 1) ? TRUE : FALSE);
X}
X
XNORMAL_CODE(bfetch, fstore, "b@", dobfetch);
X
XVOID dobstore()
X{
X    register INT32 bit;
X    register INT32 value;
X
X    bit = spop(INT32);
X    value = spop(INT32);
X    tos.INT32 = (tos.INT32 ? (value | (1 << bit)) : (value & ~(1 << bit)));
X}
X
XNORMAL_CODE(bstore, bfetch, "b!", dobstore);
X
XVOID doplusstore()
X{
X    register PTR32 t;
X
X    t = spop(PTR32);
X    *t += spop(INT32);
X}
X
XNORMAL_CODE(plusstore, bstore, "+!", doplusstore);
X
XVOID dotwofetch()
X{
X    register PTR32 t;
X
X    t = tos.PTR32;
X    spush(*t++, INT32);
X    snth(0).INT32 = *t;
X}
X
XNORMAL_CODE(twofetch, plusstore, "2@", dotwofetch);
X
XVOID dotwostore()
X{
X    register PTR32 t;
X
X    t = spop(PTR32);
X    *t++ = spop(INT32);
X    *t = spop(INT32);
X}
X
XNORMAL_CODE(twostore, twofetch, "2!", dotwostore);
X
X
X/* STRINGS */
X
XVOID docmove()
X{
X    register INT32 n;
X    register CSTR to;
X    register CSTR from;
X
X    n = spop(INT32);
X    to = spop(CSTR);
X    from = spop(CSTR);
X
X    while (--n != -1) *to++ = *from++;
X}
X
XNORMAL_CODE(cmove, twostore, "cmove", docmove);
X
XVOID docmoveup()
X{
X    register INT32 n;
X    register CSTR to;
X    register CSTR from;
X
X    n = spop(INT32);
X    to = spop(CSTR);
X    from = spop(CSTR);
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 INT32 with;
X    register INT32 n;
X    register CSTR from;
X
X    with = spop(INT32);
X    n = spop(INT32);
X    from = spop(CSTR);
X
X    while (--n != -1) *from++ = with;
X}
X
XNORMAL_CODE(fill, cmoveup, "fill", dofill);
X
XVOID docount()
X{
X    register CSTR t;
X
X    t = spop(CSTR);
X    spush(*t++, INT32);
X    spush(t, CSTR);
X}
X
XNORMAL_CODE(count, fill, "count", docount);
X
XVOID dobounds()
X{
X    register CSTR n;
X
X    n = snth(0).CSTR;
X    snth(0).CSTR = snth(0).CSTR + tos.INT32;
X    tos.CSTR = n;
X}
X
XNORMAL_CODE(bounds, count, "bounds", dobounds);
X
XVOID dodashtrailing()
X{
X    register CSTR p;
X
X    p = snth(0).CSTR + tos.INT32;
X    tos.INT32 += 1;
X    while (--tos.INT32 && (*--p == ' '));
X}
X
XNORMAL_CODE(dashtrailing, bounds, "-trailing", dodashtrailing);
X
XVOID dodashmatch()
X{
X    register INT32 n;
X    register CSTR s;
X    register CSTR t;
X
X    n = spop(INT32);
X    s = spop(CSTR);
X    t = spop(CSTR);
X
X    if (n) {
X    while ((n) && (*s++ == *t++)) n--;
X    spush(n ? TRUE : FALSE, BOOL);
X    }
X    else {
X    spush(TRUE, BOOL);
X    }
X}
X
XNORMAL_CODE(dashmatch, dashtrailing, "-match", dodashmatch);
X
X
X/* NUMERICAL CONVERSION */
X
XNORMAL_VARIABLE(base, dashmatch, "base", 10);
X
XVOID dobinary()
X{
X    base.parameter = 2;
X}
X
XNORMAL_CODE(binary_entry, base, "binary", dobinary);
X
XVOID dooctal()
X{
X    base.parameter = 8;
X}
X
XNORMAL_CODE(octal, binary_entry, "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 INT32 b;
X    register INT32 n;
X
X    b = base.parameter;
X    n = snth(0).INT32;
X
X    for (;;) {
X    c = *tos.CSTR;
X    if (c < '0' || c > 'z' || (c > '9' && c < 'a')) {
X        snth(0).INT32 = 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).INT32 = n;
X        return;
X        }
X        n = (n * b) + c;
X        tos.INT32 += 1;
X    }
X    }
X}
X
XNORMAL_CODE(convert, hex, "convert", doconvert);
X
XVOID dolesssharp()
X{
X    hld = (INT32) thepad + PADSIZE;
X}
X
XNORMAL_CODE(lesssharp, convert, "<#", dolesssharp);
X
XVOID dosharp()
X{
X    register NUM32 n;
X
X    n = tos.NUM32;
X    tos.NUM32 = n / (unsigned INT32) base.parameter;
X    n = n % (unsigned INT32) base.parameter;
X    *(CSTR) --hld = n + ((n > 9) ? 'a' - 10 : '0');
X}
X
XNORMAL_CODE(sharp, lesssharp, "#", dosharp);
X
XVOID dosharps()
X{
X    do { dosharp(); } while (tos.INT32);
X}
X
XNORMAL_CODE(sharps, sharp, "#s", dosharps);
X
XVOID dohold()
X{
X    *(CSTR) --hld = spop(INT32);
X}
X
XNORMAL_CODE(hold, sharps, "hold", dohold);
X
XVOID dosign()
X{
X    INT32 flag;
X
X    flag = spop(INT32);
X    if (flag < 0) *(CSTR) --hld = '-';
X}
X
XNORMAL_CODE(sign, hold, "sign", dosign);
X
XVOID dosharpgreater()
X{
X    tos.INT32 = hld;
X    spush((INT32) thepad + PADSIZE - hld, INT32);
X}
X
XNORMAL_CODE(sharpgreater, sign, "#>", dosharpgreater);
X
XVOID doqnumber()
X{
X    CSTR s0;
X    CSTR s1;
X
X    s0 = spop(CSTR);
X    spush(0, INT32);
X    if (*s0 == '-') {
X    spush(s0 + 1, CSTR);
X    }
X    else {
X    spush(s0, CSTR);
X    }
X    doconvert();
X    s1 = spop(CSTR);
X    if (*s1 == '\0') {
X    if (*s0 == '-') unary(-, INT32);
X    spush(TRUE, BOOL);
X    }
X    else {
X    tos.CSTR = s0;
X    spush(FALSE, BOOL);
X    }
X}
X
XNORMAL_CODE(qnumber, sharpgreater, "?number", doqnumber);
X
X
X/* CONTROL STRUCTURES */
X
XINT32 docheck(this)
X    int this;
X{
X    ENTRY last;
X    INT32 follow = spop(INT32);
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 = spop(ENTRY);
X    if (io_source())
X        (VOID) fprintf(io_errf, "%s:%i:", io_source(), io_line());
X    (VOID) fprintf(io_errf, "%s: illegal control structure\n", last -> name);
X    doabort();
X
X    return FALSE;
X    }
X}
X
XVOID dodo()
X{
X    spush(&parendo, CODE_ENTRY);
X    dothread();
X    doforwardmark();
X    dobackwardmark();
X    spush(LOOP+PLUSLOOP, INT32);
X}
X
XCOMPILATION_IMMEDIATE_CODE(do_entry, qnumber, "do", dodo);
X
XVOID doqdo()
X{
X    spush(&parenqdo, CODE_ENTRY);
X    dothread();
X    doforwardmark();
X    dobackwardmark();
X    spush(LOOP+PLUSLOOP, INT32);
X}
X
XCOMPILATION_IMMEDIATE_CODE(qdo_entry, do_entry, "?do", doqdo);
X
XVOID doloop()
X{
X    if (docheck(LOOP)) {
X    spush(&parenloop, CODE_ENTRY);
X    dothread();
X    dobackwardresolve();
X    doforwardresolve();
X    }
X}
X
XCOMPILATION_IMMEDIATE_CODE(loop, qdo_entry, "loop", doloop);
X
XVOID doplusloop()
X{
X    if (docheck(PLUSLOOP)) {
X    spush(&parenplusloop, CODE_ENTRY);
X    dothread();
X    dobackwardresolve();
X    doforwardresolve();
X    }
X}
X
XCOMPILATION_IMMEDIATE_CODE(plusloop, loop, "+loop", doplusloop);
X
XVOID doleave()
X{
X    rndrop(2);
X    fjump(rpop());
X    fbranch(*ip);
X}
X
XCOMPILATION_CODE(leave, plusloop, "leave", doleave);
X
XVOID doi()
X{
X    spush(rnth(1), INT32);
X}
X
XCOMPILATION_CODE(i_entry, leave,"i", doi);
X
XVOID doj()
X{
X    spush(rnth(4), INT32);
X}
X
XCOMPILATION_CODE(j_entry, i_entry, "j", doj);
X
XVOID doif()
X{
X    spush(&parenqbranch, CODE_ENTRY);
X    dothread();
X    doforwardmark();
X    spush(ELSE+THEN, INT32);
X}
X
XCOMPILATION_IMMEDIATE_CODE(if_entry, j_entry, "if", doif);
X
XVOID doelse()
X{
X    if (docheck(ELSE)) {
X    spush(&parenbranch, CODE_ENTRY);
X    dothread();
X    doforwardmark();
X    doswap();
X    doforwardresolve();
X    spush(THEN, INT32);
X    }
X}
X
XCOMPILATION_IMMEDIATE_CODE(else_entry, if_entry, "else", doelse);
X
XVOID dothen()
X{
X    if (docheck(THEN)) {
X    doforwardresolve();
X    }
X}
X
XCOMPILATION_IMMEDIATE_CODE(then_entry, else_entry, "then", dothen);
X
XVOID docase()
X{
X    spush(0, INT32);
X    spush(OF+ENDCASE, INT32);
X}
X
XCOMPILATION_IMMEDIATE_CODE(case_entry, then_entry, "case", docase);
X
XVOID doof()
X{
X    if (docheck(OF)) {
X    spush(&over, CODE_ENTRY);
X    dothread();
X    spush(&equals, CODE_ENTRY);
X    dothread();
X    spush(&parenqbranch, CODE_ENTRY);
X    dothread();
X    doforwardmark();
X    spush(&drop, CODE_ENTRY);
X    dothread();
X    spush(ENDOF, INT32);
X    }
X}
X
XCOMPILATION_IMMEDIATE_CODE(of_entry, case_entry, "of", doof);
X
XVOID doendof()
X{
X    if (docheck(ENDOF)) {
X    spush(&parenbranch, CODE_ENTRY);
X    dothread();
X    doforwardmark();
X    doswap();
X    doforwardresolve();
X    spush(OF+ENDCASE, INT32);
X    }
X}
X
XCOMPILATION_IMMEDIATE_CODE(endof, of_entry, "endof", doendof);
X
XVOID doendcase()
X{
X    if (docheck(ENDCASE)) {
X    spush(&drop, CODE_ENTRY);
X    dothread();
X    while (tos.INT32) doforwardresolve();
X    dodrop();
X    }
X}
X
XCOMPILATION_IMMEDIATE_CODE(endcase, endof, "endcase", doendcase);
X
XVOID dobegin()
X{
X    dobackwardmark();
X    spush(AGAIN+UNTIL+WHILE, INT32);
X}
X
XCOMPILATION_IMMEDIATE_CODE(begin, endcase, "begin", dobegin);
X
XVOID dountil()
X{
X    if (docheck(UNTIL)) {
X    spush(&parenqbranch, CODE_ENTRY);
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, CODE_ENTRY);
X    dothread();
X    doforwardmark();
X    spush(REPEAT, INT32);
X    }
X}
X
XCOMPILATION_IMMEDIATE_CODE(while_entry, until, "while", dowhile);
X
XVOID dorepeat()
X{
X    if (docheck(REPEAT)) {
X    spush(&parenbranch, CODE_ENTRY);
X    dothread();
X    doswap();
X    dobackwardresolve();
X    doforwardresolve();
X    }
X}
X
XCOMPILATION_IMMEDIATE_CODE(repeat, while_entry, "repeat", dorepeat);
X
XVOID doagain()
X{
X    if (docheck(AGAIN)) {
X    spush(&parenbranch, CODE_ENTRY);
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, CODE_ENTRY);
X    dothread();
X    }
X    dolast();
X    dotobody();
X    spush(&parenbranch, CODE_ENTRY);
X    dothread();
X    dobackwardresolve();
X}
X
XCOMPILATION_IMMEDIATE_CODE(tailrecurse, recurse, "tail-recurse", dotailrecurse);
X
XVOID doexit()
X{
X    fsemicolon();
X}
X
XCOMPILATION_CODE(exit_entry, tailrecurse, "exit", doexit);
X
XVOID doexecute()
X{
X    ENTRY t;
X
X    t = spop(ENTRY);
X    docall(t);
X}
X
XNORMAL_CODE(execute, exit_entry, "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.INT32 < 0) {
X    (VOID) fputc('-', io_outf);
X    unary(-, INT32);
X    }
X    doudot();
X}
X
XNORMAL_CODE(dot, bye, ".", dodot);
X
XVOID dodotr()
X{
X    INT32 s, t;
X
X    t = spop(INT32);
X    s = tos.INT32;
X    doabs();
X    dolesssharp();
X    dosharps();
X    spush(s, INT32);
X    dosign();
X    dosharpgreater();
X    spush(t, INT32);
X    sover();
X    dominus();
X    dospaces();
X    dotype();
X}
X
XNORMAL_CODE(dotr, dot, ".r", dodotr);
X
XVOID doudot()
X{
X    dolesssharp();
X    dosharps();
X    dosharpgreater();
X    dotype();
X    dospace();
X}
X
XNORMAL_CODE(udot, dotr, "u.", doudot);
X
XVOID doudotr()
X{
X    INT32 t;
X
X    t = spop(INT32);
X    dolesssharp();
X    dosharps();
X    dosharpgreater();
X    spush(t, INT32);
X    sover();
X    dominus();
X    dospaces();
X    dotype();
X}
X
XNORMAL_CODE(udotr, udot, "u.r", doudotr);
X
XVOID doascii()
X{
X    spush(' ', INT32);
X    doword();
X    docfetch();
X    doliteral();
X}
X
XIMMEDIATE_CODE(ascii, udotr, "ascii", doascii);
X
XVOID dodotquote()
X{
X    (VOID) io_scan(thetib, '"');
X    spush(thetib, CSTR);
X    dosdup();
X    spush(&parendotquote, CODE_ENTRY);
X    dothread();
X    docomma();
X}
X
XCOMPILATION_IMMEDIATE_CODE(dotquote, ascii, ".\"", dodotquote);
X
XVOID dodotparen()
X{
X    (VOID) io_scan(thetib, ')');
X    spush(thetib, CSTR);
X    dosprint();
X}
X
XIMMEDIATE_CODE(dotparen, dotquote, ".(", dodotparen);
X
XVOID dodots()
X{
X    PTR s;
X
X    /* Print the stack depth */
X    (VOID) fprintf(io_outf, "[%d] ", s0 - sp);
X
X    /* Check if there are any elements on the stack */
X    if (s0 - sp > 0) {
X
X    /* Print them and don't forget top of stack */
X    for (s = s0 - 2; s >= sp; s--) {
X        (VOID) fprintf(io_outf, "\\");
X        spush(s -> INT32, INT32);
X        if (tos.INT32 < 0) {
X        (VOID) fputc('-', io_outf);
X        unary(-, INT32);
X        }
X        dolesssharp();
X        dosharps();
X        dosharpgreater();
X        dotype();
X    }
X    (VOID) fprintf(io_outf, "\\");
X    dodup();
X    dodot();
X    }
X}
X
XNORMAL_CODE(dots, dotparen, ".s", dodots);
X
XVOID docr()
X{
X    (VOID) fputc('\n', io_outf);
X}
X
XNORMAL_CODE(cr, dots, "cr", docr);
X
XVOID doemit()
X{
X    CHAR c;
X
X    c = (CHAR) spop(INT32);
X    (VOID) fputc(c, io_outf);
X}
X
XNORMAL_CODE(emit, cr, "emit", doemit);
X
XVOID dotype()
X{
X    INT32 n;
X    CSTR s;
X
X    n = spop(INT32);
X    s = spop(CSTR);
X    while (n--) (VOID) fputc(*s++, io_outf);
X}
X
XNORMAL_CODE(type, emit, "type", dotype);
X
XVOID dospace()
X{
X    (VOID) fputc(' ', io_outf);
X}
X
XNORMAL_CODE(space, type, "space", dospace);
X
XVOID dospaces()
X{
X    INT32 n;
X
X    n = spop(INT32);
X    while (n-- > 0) (VOID) fputc(' ', io_outf);
X}
X
XNORMAL_CODE(spaces, space, "spaces", dospaces);
X
XVOID dokey()
X{
X    spush(io_getchar(), INT32);
X}
X
XNORMAL_CODE(key, spaces, "key", dokey);
X
XVOID doexpect()
X{
X    CHAR  c;
X    CSTR s0;
X    CSTR s1;
X    INT32  n;
X
X    /* Pop buffer pointer and size */
X    n = spop(INT32);
X    s0 = s1 = spop(CSTR);
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    io_newline();
X
X    /* Set span to number of characters received */
X    span.parameter = (INT32) (s1 - s0);
X}
X
XNORMAL_CODE(expect, key, "expect", doexpect);
X
XNORMAL_VARIABLE(span, expect, "span", 0);
X
XVOID doline()
X{
X    spush(io_line(), INT32);
X}
X
XNORMAL_CODE(line, span, "line", doline);
X
XVOID dosource()
X{
X    spush(io_source(), CSTR);
X}
X
XNORMAL_CODE(source, line, "source", dosource);
X
X
X/* PROGRAM BEGINNING AND TERMINATION */
X
XVOID doforth83()
X{
X
X}
X
XNORMAL_CODE(forth83, source, "forth-83", doforth83);
X
XVOID dointerpret()
X{
X    INT32 flag;            /* Flag value returned by for words */
X
X#ifdef CASTING
X    INT32 cast;            /* Casting operation flag */
X#endif
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        if (io_source())
X        (VOID) fprintf(io_errf, "%s:%i:", io_source(), io_line());
X        (VOID) fprintf(io_errf, "interpret: stack underflow\n");
X        doabort();
X    }
X
X    /* Scan for the next symbol */
X    spush(' ', INT32);
X    doword();
X
X    /* Exit top loop if end of input stream */
X    if (io_eof()) {
X        sdrop();
X        return;
X    }
X
X    /* Search for the symbol in the current vocabulary search set*/
X    dofind();
X    flag = spop(INT32);
X
X#ifdef CASTING
X    /* Check for vocabulary casting prefix */
X    for (cast = flag; !cast;) {
X        CSTR s = tos.CSTR;
X        INT32 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        unary(++, INT32);
X
X        /* Search for the symbol again */
X        dofind();
X        flag = spop(INT32);
X
X        /* If found check that its a vocabulary */
X        if (flag) {
X            ENTRY v = spop(ENTRY);
X
X            /* Check that the symbol is really a vocabulary */
X            if (v -> code == VOCABULARY) {
X
X            /* Scan for a new symbol */
X            spush(' ', INT32);
X            doword();
X
X            /* Exit top loop if end of input stream */
X            if (io_eof()) {
X                sdrop();
X                return;
X            }
X
X            /* And look for it in the given vocabulary */
X            spush(v, ENTRY);
X            dolookup();
X            flag = spop(INT32);
X            cast = flag;
X            }
X        }
X        else {
X            /* Restore string after vocabulary name test */
X            s[l] = ')';
X            unary(--, INT32);
X        }
X        }
X    }
X#endif
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 literal */
X        dorecognize();
X        flag = spop(INT32);
X        if (flag) {
X        doliteral();
X        }
X        else {
X        /* Print source file and line number */
X        if (io_source())
X            (VOID) fprintf(io_errf, "%s:%i:", io_source(), io_line());
X
X        /* If not print error message and abort */
X        (VOID) fprintf(io_errf, "%s ??\n", tos.CSTR);
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(abort_entry, quit, "abort", doabort);
X
XVOID doabortquote()
X{
X    spush('"', INT32);
X    doword();
X    dosdup();
X    spush(&parenabortquote, CODE_ENTRY);
X    dothread();
X    docomma();
X}
X
XCOMPILATION_IMMEDIATE_CODE(abortquote, abort_entry, "abort\"", doabortquote);
X
X
X/* DICTIONARY ADDRESSES */
X
XVOID dohere()
X{
X    spush(dp, PTR32);
X}
X
XNORMAL_CODE(here, abortquote, "here", dohere);
X
XNORMAL_CONSTANT(pad, here, "pad", (INT32) thepad);
X
XNORMAL_CONSTANT(tib, pad, "tib", (INT32) thetib);
X
XVOID dotobody()
X{
X    tos.INT32 = tos.ENTRY -> parameter;
X}
X
XNORMAL_CODE(tobody, tib, ">body", dotobody);
X
XVOID dodotname()
X{
X    ENTRY e = spop(ENTRY);
X
X    (VOID) fprintf(io_outf, "%s", e -> name);
X}
X
XNORMAL_CODE(dotname, tobody, ".name", dodotname);
X
XNORMAL_CONSTANT(cell, dotname, "cell", 4);
X
XVOID docells()
X{
X    tos.INT32 <<= 2;
X}
X
XNORMAL_CODE(cells, cell, "cells", docells);
X
XVOID docellplus()
X{
X    tos.INT32 += 4;
X}
X
XNORMAL_CODE(cellplus, cells, "cell+", docellplus);
X
X
X/* COMPILER AND INTERPRETER WORDS */
X
XVOID dosharpif()
X{
X    INT32 symbol;
X    BOOL flag;
X
X    flag = spop(BOOL);
X
X    if (!flag) {
X    do {
X        spush(' ', INT32);
X        doword();
X        symbol = spop(INT32);
X        if (STREQ(symbol, "#if")) {
X        dosharpelse();
X        spush(' ', INT32);
X        doword();
X        symbol = spop(INT32);
X        }
X    } while (!((STREQ(symbol, "#else") || STREQ(symbol, "#then"))));
X    }
X}
X
XIMMEDIATE_CODE(sharpif, cellplus, "#if", dosharpif);
X
XVOID dosharpelse()
X{
X    INT32 symbol;
X
X    do {
X    spush(' ', INT32);
X    doword();
X    symbol = spop(INT32);
X    if (STREQ(symbol, "#if")) {
X        dosharpelse();
X        spush(' ', INT32);
X        doword();
X        symbol = spop(INT32);
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(' ', INT32);
X    doword();
X    dofind();
X    doswap();
X    dodrop();
X    dosharpif();
X}
X
XIMMEDIATE_CODE(sharpifdef, sharpthen, "#ifdef", dosharpifdef);
X
XVOID dosharpifundef()
X{
X    spush(' ', INT32);
X    doword();
X    dofind();
X    doswap();
X    dodrop();
X    dozeroequals();
X    dosharpif();
X}
X
XIMMEDIATE_CODE(sharpifundef, sharpifdef, "#ifundef", dosharpifundef);
X
XVOID dosharpinclude()
X{
X    INT32 flag;
X    CSTR  fname;
X
X    spush(' ', INT32);
X    doword();
X    fname = spop(CSTR);
X    if (flag = io_infile(fname) == IO_UNKNOWN_FILE) {
X    if (io_source())
X        (VOID) fprintf(io_errf, "%s:%i:", io_source(), io_line());
X    (VOID) fprintf(io_errf, "%s: file not found\n", fname);
X    }
X    else {
X    if (flag == IO_TOO_MANY_FILES) {
X        if (io_source())
X        (VOID) fprintf(io_errf, "%s:%i:", io_source(), io_line());
X        (VOID) fprintf(io_errf, "%s: too many files open\n", fname);
X    }
X    }
X}
X
XNORMAL_CODE(sharpinclude, sharpifundef, "#include", dosharpinclude);
X
XVOID dosharppath()
X{
X    INT32 flag;
X
X    spush(' ', INT32);
X    doword();
X    if (flag = io_path(tos.CSTR, IO_PATH_FIRST) == IO_UNKNOWN_PATH) {
X    if (io_source())
X        (VOID) fprintf(io_errf, "%s:%i:", io_source(), io_line());
X    (VOID) fprintf(io_errf, "%s: unknown environment variable\n", tos.CSTR);
X    }
X    else {
X    if (flag == IO_TOO_MANY_PATHS) {
X        if (io_source())
X        (VOID) fprintf(io_errf, "%s:%i:", io_source(), io_line());
X        (VOID) fprintf(io_errf, "%s: too many paths defined\n", tos.CSTR);
X    }
X    }
X    dodrop();
X}
X
XNORMAL_CODE(sharppath, sharpinclude, "#path", dosharppath);
X
XVOID doparen()
X{
X    CHAR c;
X
X    while (c = io_getchar())
X    if (io_eof()) {
X        if (io_source())
X        (VOID) fprintf(io_errf, "%s:%i:", io_source(), io_line());
X        (VOID) fprintf(io_errf, "kernel: end of file during comment\n");
X        return;
X    }
X    else
X        if (c == ')') return;
X        else
X        if (c == '(') doparen();
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(INT32);
X}
X
XNORMAL_CODE(comma, backslash, ",", docomma);
X
XVOID doallot()
X{
X    INT32 n;
X
X    n = spop(INT32);
X    dp = (PTR32) ((PTR8) dp + n);
X}
X
XNORMAL_CODE(allot, comma, "allot", doallot);
X
XVOID doalign()
X{
X    align(dp);
X}
X
XNORMAL_CODE(align_entry, allot, "align", doalign);
X
XVOID dodoes()
X{
X    if (theframed != NIL) {
X    spush(&parenunlinkdoes, CODE_ENTRY);
X    }
X    else {
X    spush(&parendoes, CODE_ENTRY);
X    }
X    dothread();
X    doremovelocals();
X}
X
XCOMPILATION_IMMEDIATE_CODE(does, align_entry, "does>", dodoes);
X
XVOID doimmediate()
X{
X    current -> last -> mode |= IMMEDIATE;
X}
X
XNORMAL_CODE(immediate, does, "immediate", doimmediate);
X
XVOID doexecution()
X{
X    current -> last -> mode |= EXECUTION;
X}
X
XNORMAL_CODE(execution, immediate, "execution", doexecution);
X
XVOID docompilation()
X{
X    current -> last -> mode |= COMPILATION;
X}
X
XNORMAL_CODE(compilation, execution, "compilation", docompilation);
X
XVOID doprivate()
X{
X    current -> last -> mode |= PRIVATE;
X}
X
XNORMAL_CODE(private_entry, compilation, "private", doprivate);
X
XVOID dorecognizer()
X{
X    current -> recognizer = current -> last;
X}
X
XNORMAL_CODE(recognizer, private_entry, "recognizer", dorecognizer);
X
XVOID dobracketcompile()
X{
X    dotick();
X    dothread();
X}
X
XCOMPILATION_IMMEDIATE_CODE(bracketcompile, recognizer, "[compile]", dobracketcompile);
X
XVOID docompile()
X{
X    spush(*ip++, INT32);
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, INT32);
X}
X
XNORMAL_CODE(compiling, state, "compiling", docompiling);
X
XVOID doliteral()
X{
X    if (state.parameter) {
X    spush(&parenliteral, CODE_ENTRY);
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;
X
X    brkchr = (CHAR) spop(INT32);
X    (VOID) io_skipspace();
X    (VOID) io_scan(thetib, brkchr);
X    spush(thetib, CSTR);
X}
X
XNORMAL_CODE(word_entry, rightbracket, "word", doword);
X
X
X/* VOCABULARIES */
X
XNORMAL_CONSTANT(context_entry, word_entry, "context", (INT32) context);
X
XNORMAL_CONSTANT(current_entry, context_entry, "current", (INT32) ¤t);
X
XVOID dolast()
X{
X    spush((theframed ? theframed : current -> last), ENTRY);
X}
X
XNORMAL_CODE(last, current_entry, "last", dolast);
X
XVOID dodefinitions()
X{
X    current = context[0];}
X
X
XNORMAL_CODE(definitions, last, "definitions", dodefinitions);
X
XVOID doonly()
X{
X    INT32 v;
X
X    /* Flush the entry cache */
X    spush(FALSE, BOOL);
X    dorestore();
X
X    /* Remove all vocabularies except the first */
X    for (v = 1; v < CONTEXTSIZE; v++) context[v] = 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 INT32 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 = spop(ENTRY);
X    if (e) {
X
X    /* Flush all enties until the parameter symbol */
X    for (p = current -> last; p && (p != e); p = p -> link)
X        cache[hash(p -> name)] = NIL;
X
X    /* If the entry was found remove all symbols until this entry */
X    if (p == e) current -> last = e;
X    }
X    else {
X
X    /* Flush the entry cache */
X    for (i = 0; i < CACHESIZE; i++) cache[i] = NIL;
X    }
X}
X
XNORMAL_CODE(restore, only, "restore", dorestore);
X
XVOID dotick()
X{
X    BOOL flag;
X
X    spush(' ', INT32);
X    doword();
X    dofind();
X    flag = spop(BOOL);
X    if (!flag) {
X    /* Print source file and line number */
X    if (io_source())
X        (VOID) fprintf(io_errf, "%s:%i:", io_source(), io_line());
X
X    /* If not print error message and abort */
X    (VOID) fprintf(io_errf, "%s ??\n", tos.CSTR);
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    VOCABULARY_ENTRY v;        /* Search vocabulary */
X    register ENTRY e;        /* Search entry */
X    register CSTR s;        /* And string */
X
X    /* Fetch parameters and initate entry pointer */
X    v = (VOCABULARY_ENTRY) spop(PTR32);
X    s = tos.CSTR;
X
X    /* Iterate over the linked list of entries */
X    for (e = v -> last; 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 (visible(e, v)) {
X        /* Return the entry and compilation mode */
X        tos.ENTRY = e;
X        spush((e -> mode & IMMEDIATE ? 1 : -1), INT32);
X        return;
X        }
X    }
X    spush(FALSE, BOOL);
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    CSTR  n;            /* Name string of entry to be found */
X    INT32 v;            /* Index into vocabulary set */
X
X    /* Access the string to be found */
X    n = tos.CSTR;
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.CSTR, 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.ENTRY = e;
X        spush((e -> mode & IMMEDIATE ? 1 : -1), INT32);
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], VOCABULARY_ENTRY);
X    dolookup();
X    if (tos.INT32) {
X        cache[hash(n)] = snth(0).ENTRY;
X        return;
X    }
X    else {
X        sdrop();
X    }
X    }
X    spush(FALSE, BOOL);
X}
X
XNORMAL_CODE(find, lookup, "find", dofind);
X
XVOID dorecognize()
X{
X    INT32 v;            /* Vocabulary index */
X    ENTRY r;            /* Recognizer function */
X
X    for (v = 0; context[v] && v < CONTEXTSIZE; v++) {
X
X    /* Check if a recognizer function is available */
X    if (r = context[v] -> recognizer) {
X        spush(r, ENTRY);
X        docommand();
X        if (tos.INT32) {
X        return;
X        }
X        else {
X        sdrop();
X        }
X    }
X    }
X
X    /* The string was not a literal symbol */
X    spush(FALSE, BOOL);
X}
X
XNORMAL_CODE(recognize, find, "recognize", dorecognize);
X
XVOID doforget()
X{
X    dotick();
X    tos.ENTRY = tos.ENTRY -> link;
X    dorestore();
X}
X
XNORMAL_CODE(forget, recognize, "forget", doforget);
X
XVOID dowords()
X{
X    ENTRY e;            /* Pointer to entries */
X    INT32 v;            /* Index into vocabulary set */
X    INT32 l;            /* String length */
X    INT32 s;            /* Spaces between words */
X    INT32 c;            /* Column counter */
X    INT32 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) fprintf(io_outf, "VOCABULARY %s", context[v] -> name);
X    if (context[v] == current) (VOID) fprintf(io_outf, " DEFINITIONS");
X    (VOID) fputc('\n', io_outf);
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 = context[v] -> last; e; e = e -> link) {
X
X        /* Check if the entry is current visible */
X        if (visible(e, context[v])) {
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) fputc(' ', io_outf);
X        }
X        else {
X            (VOID) fputc('\n', io_outf);
X            c = l;
X        }
X        (VOID) fprintf(io_outf, "%s", e -> name);
X        }
X    }
X
X    /* End the list of words and separate the vocabularies */
X    (VOID) fputc('\n', io_outf);
X    (VOID) fputc('\n', io_outf);
X    }
X}
X
XIMMEDIATE_CODE(words, forget, "words", dowords);
X
X
X/* DEFINING NEW VOCABULARY ENTRIES */
X
XENTRY make_entry(name, code, mode, parameter)
X    CSTR name;            /* String for the new entry */
X    INT32 code, mode, parameter; /* Entry parameters */
X{
X    /* Allocate space for the entry */
X    ENTRY e;
X
X    /* Check type of entry to allocate */
X    if (code == VOCABULARY)
X    e = (ENTRY) malloc(sizeof(vocabulary_entry));
X    else
X    e = (ENTRY) malloc(sizeof(entry));
X
X    /* Insert into the current vocabulary and set parameters */
X    e -> link = current -> last;
X    current -> last = e;
X
X    /* Set entry parameters */
X    e -> name = (CSTR) strcpy(malloc((unsigned) strlen(name) + 1), name);
X    e -> code = code;
X    e -> mode = mode;
X    e -> parameter = parameter;
X    if (code == VOCABULARY)
X    ((VOCABULARY_ENTRY) e) -> recognizer = NIL;
X
X    /* Check for entry caching */
X    if (current == context[0])
X    cache[hash(name)] = e;
X    else
X    cache[hash(name)] = NIL;
X
X    /* Return pointer to the new entry */
X    return e;
X}
X
XVOID doentry()
X{
X    INT32 flag;
X    CSTR  name;
X    INT32 code, mode, parameter;
X    ENTRY forward;
X
X    /* Try to find entry to check for forward declarations */
X    forward = NIL;
X    dodup();
X    dofind();
X    flag = spop(INT32);
X    if (flag) {
X    forward = spop(ENTRY);
X    }
X    else {
X    sdrop();
X    }
X
X    /* Access name, code, mode and parameter field parameters */
X    name = spop(CSTR);
X    code = spop(INT32);
X    mode = spop(INT32);
X    parameter = spop(INT32);
X
X    /* Create the new entry */
X    (VOID) make_entry(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 = (INT32) current -> last;
X    if (verbose) {
X        if (io_source())
X        (VOID) fprintf(io_errf, "%s:%i:", io_source(), io_line());
X        (VOID) fprintf(io_errf, "%s: forward definition resolved\n", forward -> name);
X    }
X    }
X}
X
XNORMAL_CODE(entry_entry, words, "entry", doentry);
X
XVOID doforward()
X{
X    spush(0, INT32);
X    spush(NORMAL, INT32);
X    spush(FORWARD, INT32);
X    spush(' ', INT32);
X    doword();
X    doentry();
X}
X
XNORMAL_CODE(forward, entry_entry, "forward", doforward);
X
XVOID docolon()
X{
X    align(dp);
X    dohere();
X    spush(HIDDEN, INT32);
X    spush(COLON, INT32);
X    spush(' ', INT32);
X    doword();
X    doentry();
X    dorightbracket();
X    thelast = current -> last;
X}
X
XNORMAL_CODE(colon, forward, ":", docolon);
X
XVOID dosemicolon()
X{
X    if (theframed != NIL) {
X    spush(&parenunlinksemicolon, CODE_ENTRY);
X    }
X    else {
X    spush(&parensemicolon, CODE_ENTRY);
X    }
X    dothread();
X    doleftbracket();
X    doremovelocals();
X    if (thelast != NIL) {
X    thelast -> mode = NORMAL;
X    if (current == context[0]) cache[hash(thelast -> name)] = thelast;
X    thelast = NIL;
X    }
X}
X
XCOMPILATION_IMMEDIATE_CODE(semicolon, colon, ";", dosemicolon);
X
XVOID docreate()
X{
X    align(dp);
X    dohere();
X    spush(NORMAL, INT32);
X    spush(CREATE, INT32);
X    spush(' ', INT32);
X    doword();
X    doentry();
X}
X
XNORMAL_CODE(create, semicolon, "create", docreate);
X
XVOID dovariable()
X{
X    spush(0, INT32);
X    spush(NORMAL, INT32);
X    spush(VARIABLE, INT32);
X    spush(' ', INT32);
X    doword();
X    doentry();
X}
X
XNORMAL_CODE(variable, create, "variable", dovariable);
X
XVOID doconstant()
X{
X    spush(NORMAL, INT32);
X    spush(CONSTANT, INT32);
X    spush(' ', INT32);
X    doword();
X    doentry();
X}
X
XNORMAL_CODE(constant, variable, "constant", doconstant);
X
XVOID dovocabulary()
X{
X    spush(&forth, VOCABULARY_ENTRY);
X    spush(NORMAL, INT32);
X    spush(VOCABULARY, INT32);
X    spush(' ', INT32);
X    doword();
X    doentry();
X}
X
XNORMAL_CODE(vocabulary, constant, "vocabulary", dovocabulary);
X
XVOID dofield()
X{
X    spush(NORMAL, INT32);
X    spush(FIELD, INT32);
X    spush(' ', INT32);
X    doword();
X    doentry();
X}
X
XNORMAL_CODE(field, vocabulary, "field", dofield);
X
X
X/* INITIALIZATION OF THE KERNEL */
X
XVOID kernel_initiate(last, first, users, parameters, returns)
X    ENTRY first, last;
X    INT32 users, parameters, returns;
X{
X    /* Link user symbols into vocabulary chain if given */
X    if (first && last) {
X    forth.last = last;
X    first -> link = (ENTRY) &field;
X    }
X
X    /* Create the foreground task object */
X    foreground = make_task(users, parameters, returns, (INT32) NIL);
X
X    /* Assign task fields */
X    foreground -> status = RUNNING;
X    s0 = (PTR) foreground -> s0;
X    sp = (PTR) 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
XVOID kernel_finish()
X{
X    /* Future clean up function for kernel */
X}
END_OF_src/kernel.c
if test 49941 -ne `wc -c <src/kernel.c`; then
    echo shar: \"src/kernel.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
echo shar: End of archive 6 \(of 6\).
cp /dev/null ark6isdone
MISSING=""
for I in 1 2 3 4 5 6 ; do
    if test ! -f ark${I}isdone ; then
    MISSING="${MISSING} ${I}"
    fi
done
if test "${MISSING}" = "" ; then
    echo You have unpacked all 6 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