TILE Forth Release 2.0, package 6 of 6
Mikael Patel
mip at IDA.LiU.SE
Tue Jul 17 04:59:37 AEST 1990
#! /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 at 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: mip at ida.liu.se
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
More information about the Alt.sources
mailing list