TILE Forth Release 2.0, package 3 of 6
Mikael Patel
mip at IDA.LiU.SE
Tue Jul 17 04:56:35 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 3 (of 6)."
# Contents: PORTING lib/debugger.f83 lib/internals.f83 lib/queues.f83
# lib/structures.f83 src/compiler.v src/error.c src/forth.c
# src/locals.v src/multi-tasking.v
# Wrapped by mip at mina on Fri Jun 29 16:49:09 1990
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f PORTING -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"PORTING\"
else
echo shar: Extracting \"PORTING\" \(6232 characters\)
sed "s/^X//" >PORTING <<'END_OF_PORTING'
XTHREADED INTERPRETIVE LANGUAGE ENVIRONMENT (TILE) PORTING [RELEASE 2.0]
X
XJune 28, 1990
X
XMikael R.K. Patel
XComputer Aided Design Laboratory (CADLAB)
XDepartment of Computer and Information Science
XLinkoping University
XS-581 83 LINKOPING
XSWEDEN
XEmail: mip at ida.liu.se
X
X
XINTRODUCTION
X
XThis brief document describes some to the section in the tile forth
Xkernel which may have to be changed to port the code to other machines.
XAny changes made should be made in a "#ifdef" section and reported.
X
X
X1. KERNEL DEFINITIONS
X
X1.1 Vocabulary listing parameters (File: kernel.c)
X
XThe column and line width used by "words" may be altered by changing
Xthe lines:
X
X#define COLUMNWIDTH 15
X#define LINEWIDTH 75
X
X
X1.2 Set of search vocabularies (File: kernel.c)
X
XThe set of search vocabularies, "context", is realized as a vector.
XThe maximum number of vocabularies in is defined by:
X
X#define CONTEXTSIZE 64
X
XAn error will occur it the set is filled. No checking is currently
Xperformed.
X
X
X1.3 Lookup cache (File: kernel.c)
X
XThe lookup function in the kernel is supported by a simple cache.
XA hash function (see below) is used to map a string into the cache
Xand there, if possible, find the entry. The size of the cache
Xis given by:
X
X#define CACHESIZE 256
X#define hash(s) ((s[0] + (s[1] << 4)) & (CACHESIZE - 1))
X
XThe hash function is tailored for the current cache size and thus
Xspecial care must be taken when altering these.
X
X
X1.4 Internal structures (File: kernel.c)
X
XThe "pad" and the "tib" may be changed by altering:
X
X#define PADSIZE 84
X#define TIBSIZE 256
X
X
X1.5 Word alignment (File: kernel.h)
X
XAlignment of threaded code and data structures are performed by the
Xmacro:
X
X#define align(p) p = (PTR32) ((INT32) ((PTR8) p + 3) & -4)
X
XThis macro currently aligns to word (long) boundaries and is used by
X"colon" and "create".
X
X
X1.6 Typing system (File: kernel.h)
X
XThe kernel is written in its own typing system. The typing system may
Xbe extended to allow other data types etc. All types in the kernel
Xare written with uppercase words.
X
X#define VOID void
X
Xtypedef char* PTR8;
Xtypedef short* PTR16;
Xtypedef long* PTR32;
X
Xtypedef VOID (*SUBR)();
X
X#define NIL 0
X
Xtypedef long BOOL;
X
X#define TRUE ((BOOL) -1)
X#define FALSE ((BOOL) 0)
X
Xtypedef unsigned NUM;
Xtypedef unsigned char NUM8;
Xtypedef unsigned short NUM16;
Xtypedef unsigned long NUM32;
X
Xtypedef int INT;
Xtypedef char INT8;
Xtypedef short INT16;
Xtypedef long INT32;
X
Xtypedef float FLOAT32;
Xtypedef double FLOAT64;
X
Xtypedef char CHAR;
Xtypedef char* CSTR;
Xtypedef char* PSTR;
X
Xtypedef union {
X BOOL BOOL;
X NUM32 NUM32;
X INT32 INT32;
X FLOAT32 FLOAT32;
X CSTR CSTR;
X PTR8 PTR8;
X PTR16 PTR16;
X PTR32 PTR32;
X SUBR SUBR;
X QUEUE QUEUE;
X TASK TASK;
X ENTRY ENTRY;
X CODE_ENTRY CODE_ENTRY;
X VOCABULARY_ENTRY VOCABULARY_ENTRY;
X} UNIV, *PTR;
X
X
X1.7 Initialization of the kernel (File: kernel.c)
X
XThe initialization function for the kernel requires five parameters.
XThe two first allows the application such as forth.c to extend the
Xbasic forth vocabulary by giving the first and last entry in the
Xapplication vocabulary. The three following parameters specify the
Xsize of the foreground task, the forth interpreter. See the file
Xforth.c for an example.
X
X
X2. IO MANAGEMENT
X
X2.1 File and path name size (File: io.c)
X
XThe maximum length of a file or path name is defined as:
X
X#define FILENAMESIZE 128
X#define PATHNAMESIZE 128
X
XThese length are not test for currently. An error may occur if
Xa file or path name is longer than the given sizes.
X
X
X2.2 File buffer stack (File: io.c)
X
XThe io management package implements a stack of input file buffers to
Xallow loading of files from within other files etc. The maximum depth
Xof this stack is defined as:
X
X#define INFSTACKSIZE 32
X
XThe depth should be chosen to the maximum number of open files.
X
X
X2.3 Set of loaded files (File: io.c)
X
XThe file loading mechanism automatically looks if the file already
Xhas been opened. The set of opened files is maintained as a vector.
XThe maximum number of loaded files is:
X
X#define INFILESSIZE 64
X
XThe vector contains the fully expanded names of the loaded files.
XAn error may occur if this limit is succeeded. It is not checked for
Xcurrently.
X
X
X2.4 Set of paths (File: io.c)
X
XThe io packages also maintains an ordered collection of paths which
Xare used to expand file names with when search for the file. The
Xmaximum size of this collection is defined by:
X
X#define PATHSSIZE 32
X
XThis collection is automatically appended by the $TILEPATH environ-
Xment variable when the io package is initiated.
X
X
X2.5 White space (File: io.h)
X
XThe definition of "white" space is defined as:
X
X#define ISSPACE(c) ((c) <= ' ')
X
XThis eliminates space and any control characters. Some application
Xmight want to redefine this.
X
X
X2.6. Directory separator character (File: io.h)
X
XThe directory separator character is defined as:
X
X#define DIRSEPCHAR '/'
X
XThis makes the code more portable to other machines.
X
X
X2.6 Non-blocking read operation (File: io.c)
X
XTo achieve multi-tasking during input wait the input package function
X"io_fillbuf" uses a non-blocking read operation. Some environments
Xdo not support this. Thus this may require re-implementation.
X
X
X3. ERROR MANAGEMENT
X
X3.1 Signals (File: error.c)
X
XError handing is realized using two basic mechanisms; first signals from
Xthe execution environment and second by user defined exceptions in
Xthe kernel (high level code).
X
XThe signal message table and the appropriate operations, "error_restart",
Xor "error_fatal", may have to be changed to give the right performance.
X
XPlease see these functions and "error_initiate" where the actual binding
Xof signals and actions is performed.
X
X
X4. MEMORY MANAGEMENT
X
X4.1 Memory allocation (File: forth.c)
X
XCurrently memory for the dictionary, strings, entries, and task blocks
Xare allocated using "malloc".
X
XThe size of the dictionary is determined when calling the initialization
Xfunction in the memory management package, "memory_initiate". The
Xcurrent default size is defined as:
X
X#define DICTIONARYSIZE 1024L * 1024L
X
XAnd may be too large for "small" machines.
END_OF_PORTING
if test 6232 -ne `wc -c <PORTING`; then
echo shar: \"PORTING\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f lib/debugger.f83 -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"lib/debugger.f83\"
else
echo shar: Extracting \"lib/debugger.f83\" \(4652 characters\)
sed "s/^X//" >lib/debugger.f83 <<'END_OF_lib/debugger.f83'
X\
X\ FORTH DEBUGGER DEFINITIONS
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: 28 June 1990
X\
X\ Dependencies:
X\ (forth) forth, compiler, structures, blocks and lists.
X\
X\ Description:
X\ Basic debugging function built on a general advice function
X\ management. Allows black-box tracing, break points and
X\ colon definitions call profiling.
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.( Loading Debugger definitions...) cr
X
X#include internals.f83
X#include blocks.f83
X#include lists.f83
X#include structures.f83
X
Xvocabulary debugger
X
Xblocks structures lists compiler forth debugger definitions
X
Xstruct.type ADVICE ( -- )
X ptr +block private ( Pointer to code definition)
X ptr +entry private ( Pointer to entry structure)
X ptr +advice private ( Pointer to advice function)
X long +profile private ( Call counter for profiling)
Xstruct.end
X
X: [advice] ( advice -- )
X dup +advice @ execute ( Access and execute the advice)
X; private
X
X: [colon] ( advice -- )
X 1 over +profile +! ( Increment profile counter)
X +block @ call ( Call the code definition)
X; private
X
X: [trace] ( advice -- )
X ." --> " dup >r +entry @ .name .s cr ( Print function entry)
X r@ [colon] ( Call the code definition)
X ." <-- " r> +entry @ .name .s cr ( Print function exit)
X; private
X
X: [break] ( advice -- )
X >r ( Save pointer to advice block)
X begin
X .s ." Break at: " ( Print stack status and break)
X r@ +entry @ .name cr ( Print name of entry)
X [compile] ascii ( Scan a command)
X case
X ascii a ( Abort command)
X of abort endof
X ascii c ( Call command)
X of r> [colon] exit endof
X ascii e ( Execute command)
X of r@ [colon] endof
X ascii f ( Forth command)
X of interpret endof
X ascii p ( Profile command)
X of r@ +profile @ . cr endof
X ascii r ( Return command)
X of r> drop exit endof
X ." a(bort), c(ontinue), e(xecute), p(rofile) or r(eturn)" cr
X endcase
X again
X; private
X
X: tail-recurse ( -- )
X compile (branch) ( Compile a branch to the beginning)
X last >body +block @ <resolve ( And resolve the address)
X; compilation immediate
X
X: ?advice ( entry -- flag)
X +code @ ['] [advice] >body = ( Check for advice handler)
X;
X
X: advice ( action -- )
X ' dup ?advice not ( Access entry and check coding)
X abort" advice: not an adviced definition" ( Abort if wrong code type)
X >body ( Access advice block)
X 0 over +profile ! ( Initiate the profile counter)
X +advice ! ( Define a new advice action)
X;
X
X: colon ( -- )
X ['] [colon] advice ( Use colon as the advice action)
X;
X
X: trace ( -- )
X ['] [trace] advice ( Use trace as the advice action)
X;
X
X: break ( -- )
X ['] [break] advice ( Use break as the advice action)
X;
X
X: .profile ( -- )
X 5 spaces ." Calls" ( Print a profile header with calls)
X 1 spaces ." Function" cr ( And the name of the function)
X last ( Print profile for all definitions)
X block[ ( entry -- )
X dup ?advice ( Check for adviced function)
X if dup >body +profile @ ( Access profile information)
X 10 .r space ( Print in a nice format)
X .name cr ( Print name)
X else
X drop
X then
X ]; map-list
X;
X
X: : ( -- )
X : ( Use the old colon definition)
X new ADVICE ( Create an advice block)
X dup last +parameter ! ( Store the advice block into the last)
X ['] [advice] >body last +code ! ( Make the last entry use the advice)
X last over +entry ! ( Save pointer to the entry)
X ['] [colon] over +advice ! ( Colon is the initiate advice action)
X 0 over +profile ! ( Initiate the profile counter)
X here swap +block ! ( Setup pointer to block definition)
X;
X
Xforth only
END_OF_lib/debugger.f83
if test 4652 -ne `wc -c <lib/debugger.f83`; then
echo shar: \"lib/debugger.f83\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f lib/internals.f83 -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"lib/internals.f83\"
else
echo shar: Extracting \"lib/internals.f83\" \(3893 characters\)
sed "s/^X//" >lib/internals.f83 <<'END_OF_lib/internals.f83'
X\
X\ INTERNAL TILE FORTH DATA STRUCTURES
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: 19 June 1990
X\
X\ Dependencies:
X\ (forth) forth, string, enumerates, bitfields, structures,
X\ blocks, lists, and sets.
X\
X\ Description:
X\ High level extensions to the forth kernel. Implementation
X\ dependent sections such as entry and vocabulary structures.
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.( Loading Internal definitions...) cr
X
X#include enumerates.f83
X#include bitfields.f83
X#include structures.f83
X#include blocks.f83
X#include lists.f83
X#include sets.f83
X
Xsets lists blocks bitfields structures enumerates string forth definitions
X
X( Memory word size and integer range)
X
X8 constant BITS/BYTE
Xcell constant BYTES/WORD
XBYTES/WORD BITS/BYTE * constant BITS/WORD
X
X1 BITS/WORD 1- << constant MIN_INT
XMIN_INT 1- constant MAX_INT
X
X( Entry and vocabulary structures)
X
Xstruct.type ENTRY ( -- )
X ptr +link ( Pointer to previous entry)
X ptr +name ( Pointer to null-ended string)
X long +mode ( Mode bit field)
X long +code ( Code type or pointer to code)
X long +parameter ( Parameter field or pointer to dito)
Xstruct.end
X
Xbitfield.type MODES ( -- )
X bit IMMEDIATE ( Execution always)
X bit EXECUTION ( Execution only)
X bit COMPILATION ( Compilation only)
X bit PRIVATE ( Private only)
X4 bits RESERVED ( Bit fields reserved for future use)
Xbitfield.end ( Bit 8-31 are free for applications)
X
Xenum.type CODES ( -- )
X enum CODE ( Primitive code)
X enum COLON ( Colon definition)
X enum VARIABLE ( Variable)
X enum CONSTANT ( Constant)
X enum VOCABULARY ( Vocabulary)
X enum CREATE ( Created symbol)
X enum USER ( User variable local to task)
X enum LOCAL ( Local frame variable)
X enum FORWARD ( Forward reference)
X enum FIELD ( Field access variable)
X enum EXCEPTION ( Exception variable)
Xenum.end ( Otherwise forth level manager)
X
X: .entry ( entry -- )
X ." entry#" dup . cr ( Print entry address)
X ." link: " dup +link @ . cr ( Print link)
X ." name: " dup +name @ $. cr ( Print name)
X ." mode: " dup +mode @ . cr ( Print mode)
X ." code: " dup +code @ . cr ( Print code)
X ." parameter: " +parameter @ . ( Print parameter field)
X;
X
X: .context ( -- )
X ." context: " context ( Access context vocabulary set)
X block[ ( entry -- )
X .name space ( Print name of all vocabularies)
X ];
X map-set
X;
X
X: .current ( -- )
X ." current: " current @ .name space ( Print name of current vocabulary)
X;
X
X: .entries ( type -- )
X context ( Access search vocabularies)
X block[ ( type vocabulary -- type)
X +parameter @ ( Access list of entries)
X block[ ( type entry -- type)
X 2dup +code @ = ( Check if the entry is a vocabulary)
X if .name space ( Print its name and continue)
X else drop then
X ];
X map-list
X ];
X map-set
X drop
X;
X
Xforth only
END_OF_lib/internals.f83
if test 3893 -ne `wc -c <lib/internals.f83`; then
echo shar: \"lib/internals.f83\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f lib/queues.f83 -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"lib/queues.f83\"
else
echo shar: Extracting \"lib/queues.f83\" \(3860 characters\)
sed "s/^X//" >lib/queues.f83 <<'END_OF_lib/queues.f83'
X\
X\ DOUBLE LINKED LISTS
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: 26 February 1990
X\
X\ Dependencies:
X\ (forth) forth, structures, blocks
X\
X\ Description:
X\ Allows definition and basic manipulation of queue data structures.
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.( Loading Queue definitions... ) cr
X
X#include structures.f83
X#include blocks.f83
X
Xblocks structures queues definitions
X
Xstruct.type QUEUE ( -- )
X ptr +succ private ( Pointer to successor)
X ptr +pred private ( Pointer to predecessor)
Xstruct.init ( queue -- )
X dup over +succ ! ( Initiate as an empty queue)
X dup +pred !
Xstruct.end
X
X: succ ( queue -- succ)
X +succ @ ( Access successor item)
X;
X
X: pred ( queue -- pred)
X +pred @ ( Access predecessor item)
X;
X
X#ifundef ?empty-queue ( Check if the kernel supports queues)
X
X: ?empty-queue ( queue -- bool)
X dup +succ @ = ( Pointer to itself)
X;
X
X: enqueue ( item queue -- )
X 2dup +pred @ swap +pred ! ( item.pred = queue.pred)
X 2dup swap +succ ! ( item.succ = queue)
X 2dup +pred @ +succ ! ( queue.pred.succ = item)
X +pred ! ( queue.pred = item)
X;
X
X: dequeue ( item -- )
X dup +succ @ over +pred @ +succ ! ( item.pred.succ = item.succ)
X dup +pred @ over +succ @ +pred ! ( item.succ.pred = item.pred)
X dup over +succ ! ( item.succ = item)
X dup +pred ! ( item.pred = item)
X;
X
X#then
X
X: size-queue ( queue -- int)
X 0 swap dup >r ( Save pointer to queue header)
X begin
X swap 1+ swap +succ @ ( Increment size and step to next)
X dup r@ = ( Is this the last element?)
X until
X r> 2drop ( Drop parameters and return size)
X;
X
X: map-queue ( queue block[item -- ] -- )
X over >r ( Save pointer to queue header)
X begin
X over +succ @ >r ( Save pointer to next item)
X dup >r ( Save block on return stack)
X call ( Call the block with the item)
X 2r> tuck ( Restore the parameters)
X r@ = ( Check if end of queue)
X until
X r> drop 2drop ( Drop all temporary parameters)
X;
X
X: ?map-queue ( queue block[item -- bool] -- )
X over >r ( Save pointer to queue header)
X begin
X over +succ @ >r ( Save pointer to next item)
X dup >r ( Save block on return stack)
X call ( Call the block with the item)
X if 2r> true ( Exit the iteration)
X else
X 2r> tuck ( Restore the parameters)
X r@ = ( Check if end of queue)
X then
X until
X r> drop 2drop ( Drop all temporary parameters)
X;
X
X: ?member-queue ( element queue -- bool)
X dup >r ( Save pointer to queue header)
X begin
X 2dup = ( Is this the element?)
X if 2drop r> drop true exit then ( Well drop the parameters and return)
X +succ @ dup r@ = ( Step to the next. Last element?)
X until
X 2drop r> drop false
X;
X
X: .queue ( queue -- )
X ." queue#" dup . ( Print address of queue)
X ." succ: " dup +succ @ . ( Print successor)
X ." pred: " +pred @ . ( Print predecessor)
X;
X
Xforth only
END_OF_lib/queues.f83
if test 3860 -ne `wc -c <lib/queues.f83`; then
echo shar: \"lib/queues.f83\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f lib/structures.f83 -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"lib/structures.f83\"
else
echo shar: Extracting \"lib/structures.f83\" \(3971 characters\)
sed "s/^X//" >lib/structures.f83 <<'END_OF_lib/structures.f83'
X\
X\ STRUCTURE DEFINITIONS
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: 26 February 1990
X\
X\ Dependencies:
X\ (forth) none
X\
X\ Description:
X\ Allows aggregates of data to be described as structures. General-
X\ ization of structures in traditional programming languages. Allows
X\ definition, initialization and action part. Basic object based
X\ action may be defined in a style similar to the "does" section of
X\ a creating word.
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.( Loading Structure definitions...) cr
X
Xvocabulary structures
X
Xstructures definitions
X
X0 field +size ( struct -- size) private
Xcell field +initiate ( struct -- initiate) private
X
X: as ( -- struct)
X ' >body ( Quote next symbol and access body)
X [compile] literal ( If compiling generate a literal)
X; immediate
X
X: this ( -- ptr)
X last >body ( Access the body of the last symbol)
X;
X
X: initiate ( ptr struct -- )
X +initiate @ ?dup ( Access initiate. code pointer)
X if >r else drop then ( If available perform initialization)
X;
X
X: make ( struct -- ptr)
X here dup >r ( Save pointer to instance)
X over +size @ allot ( Access size and allocate memory)
X swap initiate r> ( Perform initialization)
X;
X
X: new ( -- ptr)
X [compile] as ( Take the next symbol, "as")
X ?compile make ( And "make" an instance)
X; immediate
X
X: sizeof ( -- size)
X ' >body +size @ ( Access size of structure)
X [compile] literal ( And make literal if compiling)
X; immediate
X
X: assign ( a b -- )
X [compile] sizeof ?compile cmove ( Access size and assign instance)
X; immediate
X
X: struct.type ( -- struct offset0)
X create here 0 0 , 0 , ( Allocate initial struct information)
Xdoes> ( struct.type -- )
X create make drop ( Create a new instance)
X;
X
X: bytes ( offset1 n -- offset2)
X over dup ( Check for zero offset)
X if field + ( Create an access field of "n" bytes)
X else
X create , + immediate ( Create an efficient field)
X does> ( field -- )
X drop ( Does nothing at runtime )
X then
X;
X
X: align ( offset1 -- offset2)
X dup 1 and + ( Align field offset to even address)
X;
X
X: field ( bytes -- )
X create , nil , ( Create a predefined field type)
Xdoes> ( field -- )
X @ bytes ( At run-time create field names)
X; private
X
X: struct ( -- )
X [compile] sizeof bytes ( Create a structure sized field name)
X;
X
X( Initial set of field names)
X1 field byte ( -- )
X2 field word ( -- )
X4 field long ( -- )
X4 field ptr ( -- )
X4 field enum ( -- )
X
X: struct.init ( struct offset3 -- )
X align over +size ! ( Assign size of structure type)
X here swap +initiate ! ] ( And pointer to initialization code)
X;
X
X: struct.does ( -- )
X [compile] does> ( Do what does-does)
X; immediate compilation
X
X: struct.end ( [] or [struct offset3] -- )
X compiling ( Check compilation status)
X if [compile] ; ( If compiling then end definition)
X else swap +size ! then ( Else assign size of structure type)
X; immediate
X
Xforth only
X
END_OF_lib/structures.f83
if test 3971 -ne `wc -c <lib/structures.f83`; then
echo shar: \"lib/structures.f83\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f src/compiler.v -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"src/compiler.v\"
else
echo shar: Extracting \"src/compiler.v\" \(4856 characters\)
sed "s/^X//" >src/compiler.v <<'END_OF_src/compiler.v'
X/*
X C BASED FORTH-83 MULTI-TASKING KERNEL: COMPILER EXTENSION LEVEL DEFINITIONS
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: 24 April 1990
X
X Dependencies:
X (cc) kernel.c, kernel.h
X
X Description:
X Compiler extension vocabulary of the tile forth multi-tasking
X kernel.
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
XVOID doparenbranch()
X{
X fbranch(*ip);
X}
X
XCOMPILATION_CODE(parenbranch, forth, "(branch)", doparenbranch);
X
XVOID doparenqbranch()
X{
X BOOL flag;
X
X /* Pop flag */
X flag = spop(BOOL);
X
X /* Check flag on top of stack and branch if false */
X if (flag)
X fskip();
X else
X fbranch(*ip);
X}
X
XCOMPILATION_CODE(parenqbranch, parenbranch, "(?branch)", doparenqbranch);
X
XVOID doparendo()
X{
X /* Build a loop frame on return stack */
X rpush(ip++);
X rpush(spop(INT32));
X rpush(spop(INT32));
X}
X
XCOMPILATION_CODE(parendo, parenqbranch, "(do)", doparendo);
X
XVOID doparenqdo()
X{
X /* Check if the start and stop value are equal */
X if (tos.INT32 == snth(0).INT32) {
X
X /* If equal then branch over the loop block */
X sndrop(1);
X fbranch(*ip);
X }
X else {
X
X /* else build a loop frame on the return stack */
X rpush(ip++);
X rpush(spop(INT32));
X rpush(spop(INT32));
X }
X}
X
XCOMPILATION_CODE(parenqdo, parendo, "(?do)", doparenqdo);
X
XVOID doparenloop()
X{
X /* Increment the index by one and check if within loop range */
X rnth(1) += 1;
X if (rnth(0) > rnth(1)) {
X
X /* Branch if still within range */
X fbranch(*ip);
X return;
X }
X
X /* Else remove the loop frame from the return stack and skip */
X rndrop(3);
X fskip();
X}
X
XCOMPILATION_CODE(parenloop, parenqdo, "(loop)", doparenloop);
X
XVOID doparenplusloop()
X{
X INT32 d;
X
X /* Pop the decrement value */
X d = spop(INT32);
X
X /* Increment the index with the top of stack value */
X rnth(1) += d;
X
X /* Check direction and if the index is still within the loop range */
X if (d > 0) {
X if (rnth(0) > rnth(1)) {
X fbranch(*ip);
X return;
X }
X }
X else {
X if (rnth(0) < rnth(1)) {
X fbranch(*ip);
X return;
X }
X }
X
X /* Else remove the loop frame from the return stack and skip */
X rndrop(3);
X fskip();
X}
X
XCOMPILATION_CODE(parenplusloop, parenloop, "(+loop)", doparenplusloop);
X
X
X/* COMPILATION LITERALS */
X
XVOID doparenliteral()
X{
X spush(*ip++, INT32);
X}
X
XCOMPILATION_CODE(parenliteral, parenplusloop, "(literal)", doparenliteral);
X
XVOID doparendotquote()
X{
X (VOID) fprintf(io_outf, "%s", *ip++);
X}
X
XCOMPILATION_CODE(parendotquote, parenliteral, "(.\")", doparendotquote);
X
XVOID doparenabortquote()
X{
X BOOL flag;
X
X /* Pop flag from top of stack */
X flag = spop(BOOL);
X
X /* Check flag on top of stack. If true then abort and give message */
X if (flag) {
X doparendotquote();
X doabort();
X }
X else fskip();
X}
X
XCOMPILATION_CODE(parenabortquote, parendotquote, "(abort\")", doparenabortquote);
X
XVOID doparensemicolon()
X{
X fsemicolon();
X}
X
XCOMPILATION_CODE(parensemicolon, parendotquote, "(;)", doparensemicolon);
X
XVOID doparendoes()
X{
X fdoes();
X}
X
XCOMPILATION_CODE(parendoes, parensemicolon, "(does>)", doparendoes);
X
X
X/* THREADING PRIMITIVES */
X
XVOID dothread()
X{
X *dp++ = spop(INT32);
X}
X
XNORMAL_CODE(thread, parendoes, "thread", dothread);
X
XVOID dounthread()
X{
X unary(*(PTR32), INT32);
X}
X
XNORMAL_CODE(unthread, thread, "unthread", dounthread);
X
X
XVOID doforwardmark()
X{
X dohere();
X spush(0, INT32);
X docomma();
X}
X
XCOMPILATION_CODE(forwardmark, unthread, ">mark", doforwardmark);
X
XVOID dobackwardmark()
X{
X dohere();
X}
X
XCOMPILATION_CODE(backwardmark, forwardmark, "<mark", dobackwardmark);
X
XVOID doforwardresolve()
X{
X dohere();
X doover();
X dominus();
X doswap();
X dostore();
X}
X
XCOMPILATION_CODE(forwardresolve, backwardmark, ">resolve", doforwardresolve);
X
XVOID dobackwardresolve()
X{
X dohere();
X dominus();
X docomma();
X}
X
XCOMPILATION_CODE(backwardresolve, forwardresolve, "<resolve", dobackwardresolve);
X
END_OF_src/compiler.v
if test 4856 -ne `wc -c <src/compiler.v`; then
echo shar: \"src/compiler.v\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f src/error.c -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"src/error.c\"
else
echo shar: Extracting \"src/error.c\" \(4818 characters\)
sed "s/^X//" >src/error.c <<'END_OF_src/error.c'
X/*
X C BASED FORTH-83 MULTI-TASKING KERNEL ERROR MANAGEMENT
X
X Copyright (c) 1989-1990 by Mikael 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: 7 March 1989
X
X Last updated on: 20 June 1990
X
X Dependencies:
X (cc) signal.h, fcntl.h, kernel.h, memory.h, io.h, and error.h
X
X Description:
X Handles low level signal to error message conversion and printing.
X Low level signals from the run-time environment are transformation
X to forth level exceptions and may be intercepted by an exception
X block.
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 <signal.h>
X#include <fcntl.h>
X#include "kernel.h"
X#include "memory.h"
X#include "io.h"
X#include "error.h"
X
X
X/* ENVIRONMENT FOR LONGJMP AND RESTART AFTER ERROR SIGNAL */
X
Xjmp_buf restart;
X
X
X/* SIGNAL MESSAGE TABLE AND SIZE */
X
X#define SIGNALMSGSIZE 20
X
Xstatic char *signalmsg[SIGNALMSGSIZE] = {
X "io error",
X "hangup",
X "interrupt",
X "quit",
X "illegal instruction",
X "trace trap",
X "abort",
X "emulator trap",
X "arithmetic exception",
X "kill",
X "bus error",
X "segmentation violation",
X "bad argument to system call",
X "write to a pipe or other socket with no one to read it",
X "alarm clock",
X "software termination",
X "urgent condition on IO channel",
X "sendable stop signal not from tty",
X "stop signal from tty",
X "continue after stop"
X };
X
X
XVOID error_signal(sig)
X long sig;
X{
X /* Check which task received the signal */
X if (tp == foreground)
X (VOID) fprintf(io_errf, "foreground#%d: ", foreground);
X else
X (VOID) fprintf(io_errf, "task#%d: ", tp);
X
X /* Print the signal number and a short description */
X if (sig < SIGNALMSGSIZE)
X (VOID) fprintf(io_errf, "signal#%d: %s\n", sig, signalmsg[sig]);
X else
X (VOID) fprintf(io_errf, "exception#%d: %s\n", sig, ((ENTRY) sig) -> name);
X
X /* Abort the current virtual machine call */
X doabort();
X}
X
XVOID error_fatal(sig)
X int sig; /* Signal number */
X{
X /* Notify the error signal */
X error_signal((long) sig);
X
X /* Clean up the mess after all the packages */
X io_finish();
X error_finish();
X kernel_finish();
X memory_finish();
X
X /* Exit and pass on the signal number */
X exit(sig);
X}
X
XVOID error_restart(sig)
X int sig; /* Signal number */
X{
X /* Check the type of signal and perform an appropriate action */
X switch (sig) {
X case SIGTSTP:
X (VOID) fcntl(STDIN, F_SETFL, 0);
X (VOID) kill(getpid(), SIGSTOP);
X return;
X case SIGCONT:
X (VOID) fcntl(STDIN, F_SETFL, FNDELAY);
X return;
X default:
X /* Check if the lowest file descriptor is a tty */
X if (isatty(io_infstack[0] -> fd)) {
X
X /* Close all other files */
X io_flush();
X
X /* Check for interrupt in input management */
X if ((sig == SIGINT || sig == SIGQUIT) && !running) {
X
X /* Notify the type of signal */
X error_signal((long) sig);
X }
X else
X /* Warm start the kernel and pass on the signal number */
X longjmp(restart, sig);
X }
X else error_fatal(sig);
X }
X}
X
XVOID error_initiate()
X{
X /* Add error_fatal and error_restart as signal handlers */
X (VOID) signal(SIGHUP, error_fatal);
X (VOID) signal(SIGINT, error_restart);
X (VOID) signal(SIGQUIT, error_restart);
X (VOID) signal(SIGILL, error_restart);
X (VOID) signal(SIGTRAP, error_fatal);
X (VOID) signal(SIGIOT, error_fatal);
X (VOID) signal(SIGEMT, error_fatal);
X (VOID) signal(SIGFPE, error_restart);
X (VOID) signal(SIGBUS, error_restart);
X (VOID) signal(SIGSEGV, error_restart);
X (VOID) signal(SIGSYS, error_restart);
X (VOID) signal(SIGPIPE, error_restart);
X (VOID) signal(SIGALRM, error_restart);
X (VOID) signal(SIGTERM, error_fatal);
X (VOID) signal(SIGURG, error_restart);
X (VOID) signal(SIGSTOP, error_fatal);
X (VOID) signal(SIGTSTP, error_restart);
X (VOID) signal(SIGCONT, error_restart);
X}
X
XVOID error_finish()
X{
X /* Future clean up function for the error package */
X}
X
END_OF_src/error.c
if test 4818 -ne `wc -c <src/error.c`; then
echo shar: \"src/error.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f src/forth.c -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"src/forth.c\"
else
echo shar: Extracting \"src/forth.c\" \(5294 characters\)
sed "s/^X//" >src/forth.c <<'END_OF_src/forth.c'
X/*
X C BASED FORTH-83 MULTI-TASKING KERNEL APPLICATION: TILE FORTH
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: 26 June 1990
X
X Dependencies:
X (cc) kernel.h, error.h, memory.h, and io.h
X
X Description:
X A 32-bit Forth-83 Standard written in C. Illustrating the use of
X the multi-tasking forth kernel, memory, io and error packages.
X
X Allows parameters to be given to forth and selection of inter-
X action symbol. Thus providing the basic interface for making forth
X programs act as compile-and-go applications.
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
X/* EXTERNAL DEFINITIONS */
X
X#include "kernel.h"
X#include "error.h"
X#include "memory.h"
X#include "io.h"
X
X
X/* VERSION BANNER */
X
X#define BANNER "TILE Forth version 3.26, Copyright (c) 1990, by Mikael Patel\n"
X
X
X/* STRUCTURE SIZES */
X
X#define DICTIONARYSIZE 1024L * 1024L
X#define USERSIZE 1024L
X#define PARAMSIZE 256L
X#define RETURNSIZE 256L
X
X
X/* ACCESS TO APPLICATION ARGUMENTS */
X
Xstatic INT32 ARGC;
Xstatic PTR32 ARGV;
Xstatic INT32 ARGS;
Xstatic CSTR ARGI;
X
X
X/* ARGUMENT CHECK AND ACCESS MACROS */
X
X#define ARGEQ(i, s) (*argv[i] == *s && *(argv[i] + 1) == *(s + 1))
X#define ARGEV(i) (atol(argv[i] + 2))
X
X
X/* APPLICATION IO DISPATCH. RUN ON IO-WAIT FOR PERIODICAL ACTIONS */
X
XVOID io_dispatch()
X{
X /* Any application action which requires periodical attention */
X}
X
X
X/* EXAMPLE OF APPLICATION VOCABULARY */
X
XVOID doarguments()
X{
X spush(ARGC - ARGS, INT32);
X}
X
XNORMAL_CODE(arguments, forth, "argc", doarguments);
X
XVOID doargument()
X{
X if (!tos.INT32 && !ARGI)
X tos.INT32 = *ARGV;
X else
X tos.INT32 = *((PTR32) (INT32) ARGV + tos.INT32 + ARGS);
X}
X
XNORMAL_CODE(argument, arguments, "argv", doargument);
X
X
X/* MAIN WITH APPLICATION STARTUP OF FORTH TOP-LOOP */
X
Xmain(argc, argv)
X int argc;
X char *argv[];
X{
X INT32 i, flag;
X INT32 dictionarysize, usersize, paramsize, returnsize;
X
X /* Initiate default size values */
X dictionarysize = DICTIONARYSIZE;
X usersize = USERSIZE;
X paramsize = PARAMSIZE;
X returnsize = RETURNSIZE;
X
X /* Check for size arguments */
X i = 1;
X flag = i < argc;
X while (flag) {
X
X /* Assume no more arguments */
X flag = FALSE;
X
X /* Look for dictionary size argument */
X if (ARGEQ(i, "-d")) {
X dictionarysize = ARGEV(i);
X flag = TRUE;
X }
X
X /* Look for parameter stack size argument */
X if (ARGEQ(i, "-p")) {
X paramsize = ARGEV(i);
X flag = TRUE;
X }
X
X /* Look for return stack size argument */
X if (ARGEQ(i, "-r")) {
X returnsize = ARGEV(i);
X flag = TRUE;
X }
X
X /* Look for user area size argument */
X if (ARGEQ(i, "-u")) {
X usersize = ARGEV(i);
X flag = TRUE;
X }
X
X /* Check for more arguments to parse */
X if (flag) {
X i++;
X flag = i < argc;
X }
X }
X
X /* Initiate memory, error, io, and kernel */
X io_initiate(BANNER);
X error_initiate();
X memory_initiate(dictionarysize);
X kernel_initiate(&argument, &arguments, usersize, paramsize, returnsize);
X
X /* Set up argument counter and pointer */
X ARGC = argc;
X ARGV = (PTR32) argv;
X ARGS = argc - 1;
X ARGI = (CSTR) 0;
X
X /* Load argument files before taking input from standard input */
X for(; i < argc; i++) {
X
X /* Look for argument or start symbol switch */
X if (STREQ(argv[i], "-a")) {
X ARGS = i;
X i = argc;
X }
X else {
X if (STREQ(argv[i], "-s")) {
X ARGI = argv[i + 1];
X ARGS = i + 1;
X i = argc;
X }
X else {
X
X /* Use the argument as an input file name and try loading it*/
X if (io_infile(argv[i]) == IO_UNKNOWN_FILE) {
X (VOID) fprintf(io_errf, "%s: file not found\n", argv[i]);
X kernel_finish();
X io_finish();
X error_finish();
X memory_finish();
X exit(0);
X }
X else
X doquit();
X }
X }
X }
X
X /* Use standard input as input stream */
X (VOID) io_infile((CSTR) STDIN);
X
X /* Check if there was a start symbol argument */
X if (ARGI) {
X
X /* Find the symbol in the vocabulary */
X verbose = FALSE;
X spush(ARGI, CSTR);
X dofind();
X if (tos.BOOL) {
X dodrop();
X docommand();
X }
X else
X (VOID) fprintf(io_errf, "%s ??\n", ARGI);
X }
X else {
X /* Else start the normal interaction loop */
X verbose = TRUE;
X doquit();
X }
X
X /* Clean up the kernel, io, error and memory package before exit */
X kernel_finish();
X memory_finish();
X error_finish();
X io_finish();
X exit(0);
X}
X
X
X
END_OF_src/forth.c
if test 5294 -ne `wc -c <src/forth.c`; then
echo shar: \"src/forth.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f src/locals.v -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"src/locals.v\"
else
echo shar: Extracting \"src/locals.v\" \(4708 characters\)
sed "s/^X//" >src/locals.v <<'END_OF_src/locals.v'
X/*
X C BASED FORTH-83 MULTI-TASKING KERNEL: LOCAL VARIABLES AND ARGUMENT BINDING
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: 20 April 1990
X
X Dependencies:
X (cc) kernel.c, kernel.h
X
X Description:
X Local variables and argument binding extension vocabulary of
X the tile forth multi-tasking kernel.
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
Xstatic ENTRY theframed = NIL;
X
XVOID doremovelocals()
X{
X /* Check if the last definition used an argument definition */
X if (theframed != NIL) {
X
X /* Restore the vocabulary structure */
X spush(theframed, ENTRY);
X dorestore();
X theframed = NIL;
X }
X}
X
XVOID doparenlink()
X{
X flink();
X}
X
XCOMPILATION_CODE(parenlink, forth, "(link)", doparenlink);
X
XVOID doparenunlink()
X{
X funlink();
X}
X
XCOMPILATION_CODE(parenunlink, parenlink, "(unlink)", doparenunlink);
X
XVOID doparenunlinksemicolon()
X{
X funlink();
X fsemicolon();
X}
X
XCOMPILATION_CODE(parenunlinksemicolon, parenunlink, "(unlink;)", doparenunlinksemicolon);
X
XVOID doparenunlinkdoes()
X{
X funlink();
X fdoes();
X fsemicolon();
X}
X
XCOMPILATION_CODE(parenunlinkdoes, parenunlinksemicolon, "(unlinkdoes>)", doparenunlinkdoes);
X
XVOID doparenlocal()
X{
X spush(((PTR32) (INT32) fp - *ip++), PTR32);
X}
X
XCOMPILATION_CODE(parenlocal, parenunlinkdoes, "(local)", doparenlocal);
X
XVOID doparenlocalstore()
X{
X *((PTR32) (INT32) fp - *ip++) = spop(INT32);
X}
X
XCOMPILATION_CODE(parenlocalstore, parenlocal, "(local!)", doparenlocalstore);
X
XVOID doparenlocalfetch()
X{
X spush(*((PTR32) (INT32) fp - *ip++), INT32);
X}
X
XCOMPILATION_CODE(parenlocalfetch, parenlocalstore, "(local@)", doparenlocalfetch);
X
XVOID doassignlocal()
X{
X *((PTR32) (INT32) fp - ((ENTRY) *ip++) -> parameter) = spop(INT32);
X}
X
XCOMPILATION_CODE(assignlocal, parenlocalfetch, "->", doassignlocal);
X
XCOMPILATION_CODE(localexit, assignlocal, "exit", doparenunlinksemicolon);
X
XVOID docurlebracket()
X{
X BOOL frameflag = TRUE;
X BOOL argflag = TRUE;
X INT32 arguments = 0;
X INT32 locals = 0;
X
X /* Check only one active lexical levels allowed */
X if (theframed) {
X if (io_source())
X (VOID) fprintf(io_errf, "%s:%i:", io_source(), io_line());
X (VOID) fprintf(io_errf, "%s: illegal argument binding\n", theframed -> name);
X doremovelocals();
X doabort();
X return;
X }
X
X /* Save pointer to latest defintion to allow removal of local names */
X theframed = current -> last;
X
X /* While the end of the frame description is not found */
X while (frameflag) {
X
X /* Scan the next symbol */
X spush(' ', INT32);
X doword();
X
X if (io_eof()) {
X if (io_source())
X (VOID) fprintf(io_errf, "%s:%i:", io_source(), io_line());
X (VOID) fprintf(io_errf, "locals: end of file during scan of parameter list\n");
X doabort();
X return;
X }
X
X /* Check if it marks the end of the argument section */
X if (STREQ(tos.CSTR, "|")) {
X argflag = 0;
X }
X else {
X /* else check if its the end of the frame description */
X if (STREQ(tos.CSTR, "}")) {
X frameflag = FALSE;
X }
X else {
X /* Or the beginning of the return description */
X if (STREQ(tos.CSTR, "--")) {
X sdrop();
X spush('}', INT32);
X doword();
X frameflag = FALSE;
X }
X else {
X /* If not then make the symbol a local variable */
X if (argflag)
X arguments++;
X else
X locals++;
X (VOID) make_entry(tos.CSTR,
X (INT32) LOCAL,
X (INT32) COMPILATION,
X arguments + locals);
X }
X }
X }
X sdrop();
X }
X
X /* Compile the parameter binding linkage */
X spush(&parenlink, CODE_ENTRY);
X dothread();
X
X /* And the appropriate frame size */
X spush(arguments, INT32);
X docomma();
X spush(locals, INT32);
X docomma();
X}
X
XCOMPILATION_IMMEDIATE_CODE(curlebracket, localexit, "{", docurlebracket);
X
END_OF_src/locals.v
if test 4708 -ne `wc -c <src/locals.v`; then
echo shar: \"src/locals.v\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f src/multi-tasking.v -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"src/multi-tasking.v\"
else
echo shar: Extracting \"src/multi-tasking.v\" \(5643 characters\)
sed "s/^X//" >src/multi-tasking.v <<'END_OF_src/multi-tasking.v'
X/*
X C BASED FORTH-83 MULTI-TASKING KERNEL: MULTI-TASKING EXTENSIONS
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: 20 April 1990
X
X Dependencies:
X (cc) kernel.c, kernel.h
X
X Description:
X Multi-tasking kernel extension vocabulary.
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
Xstatic ENTRY toterminate = (ENTRY) &terminate;
X
XNORMAL_CONSTANT(foreground_entry, forth, "foreground", (INT32) &foreground);
X
XNORMAL_CONSTANT(running_entry, foreground_entry, "running", (INT32) &tp);
X
XVOID douser()
X{
X spush(NORMAL, INT32);
X spush(USER, INT32);
X spush(' ', INT32);
X doword();
X doentry();
X}
X
XNORMAL_CODE(user, running_entry, "user", douser);
X
XTASK make_task(users, params, returns, action)
X INT32 users, params, returns, action;
X{
X INT32 size;
X TASK t;
X
X /* Calculate size of task and allocate */
X size = sizeof(task_header) + users + (params + returns) * sizeof(INT32);
X t = (TASK) malloc((unsigned) size);
X
X /* Initiate queues structure, status and environment */
X t -> queue.succ = t -> queue.pred = (QUEUE) t;
X t -> status = READY;
X
X t -> s0 = t -> sp = (PTR32) ((PTR8) t + size - returns * sizeof(INT32));
X t -> r0 = t -> rp = (PTR32) ((PTR8) t + size);
X t -> ip = (action ? (PTR32) action : (PTR32) &toterminate);
X t -> fp = NIL;
X t -> ep = NIL;
X
X /* Return task pointer */
X return t;
X}
X
XVOID dotask()
X{
X INT32 users, params, returns, action;
X
X action = spop(INT32);
X returns = spop(INT32);
X params = spop(INT32);
X users = spop(INT32);
X spush(make_task(users, params, returns, action), TASK);
X}
X
XNORMAL_CODE(task_entry, user, "task", dotask);
X
XVOID dofork()
X{
X TASK t;
X INT32 size;
X
X register INT32 n;
X register PTR8 to;
X register PTR8 from;
X
X
X /* Allocate memory for the new task */
X size = ((PTR8) r0) - ((PTR8) tp);
X t = (TASK) malloc((unsigned) size);
X
X /* Push top of stack for clean state */
X sdrop();
X
X /* Copy the current task */
X n = size;
X to = (PTR8) t;
X from = (PTR8) tp;
X while (--n != -1) *to++ = *from++;
X
X /* Assign the new fields */
X t -> s0 = (PTR32) ((INT32) ((PTR8) t) + ((PTR8) s0) - ((PTR8) tp));
X t -> sp = (PTR32) ((INT32) ((PTR8) t) + ((PTR8) sp) - ((PTR8) tp));
X t -> ip = ip;
X t -> r0 = (PTR32) ((INT32) ((PTR8) t) + ((PTR8) r0) - ((PTR8) tp));
X t -> rp = (PTR32) ((INT32) ((PTR8) t) + ((PTR8) rp) - ((PTR8) tp));
X t -> fp = (fp ? (PTR32) ((INT32) ((PTR8) t) + ((PTR8) fp) - ((PTR8) tp)) : NIL);
X t -> ep = (ep ? (PTR32) ((INT32) ((PTR8) t) + ((PTR8) ep) - ((PTR8) tp)) : NIL);
X
X /* Pop back top of stack */
X sdup();
X
X /* Push pointer to child task as result to parent task */
X spush(t, TASK);
X
X /* Schedule the child task and push parent */
X spush(t, TASK);
X t = tp;
X doschedule();
X
X /* Push pointer to parent task as result to child task */
X tos.TASK = t;
X}
X
XNORMAL_CODE(fork_entry, task_entry, "fork", dofork);
X
XVOID doresume()
X{
X TASK t;
X
X t = tos.TASK;
X
X /* Check if the task to resume is the current task and active */
X if (t -> status && t != tp) {
X
X /* Store the state of the current task */
X tp -> sp = (PTR32) sp;
X tp -> s0 = (PTR32) s0;
X tp -> ip = ip;
X tp -> rp = rp;
X tp -> r0 = r0;
X tp -> fp = fp;
X tp -> ep = ep;
X
X /* Indicate task switch to the virtual machine */
X running = FALSE;
X
X /* Restore the parameter task */
X sp = (PTR) t -> sp;
X s0 = (PTR) t -> s0;
X ip = t -> ip;
X rp = t -> rp;
X r0 = t -> r0;
X fp = t -> fp;
X ep = t -> ep;
X tp = t;
X }
X
X /* Load top of stack again */
X sdrop();
X}
X
XNORMAL_CODE(resume, fork_entry, "resume", doresume);
X
XVOID doschedule()
X{
X /* Put the task after the current task */
X spush(tp -> queue.succ, QUEUE);
X doenqueue();
X
X /* Resume the task now */
X dodetach();
X
X /* Restore parameter and return stack */
X spush(tp, TASK);
X rpush(&toterminate);
X
X /* Mark the task as running */
X tp -> status = RUNNING;
X}
X
XNORMAL_CODE(schedule, resume, "schedule", doschedule);
X
XVOID dodetach()
X{
X /* Resume the next task in the system task queue */
X spush(tp -> queue.succ, QUEUE);
X doresume();
X}
X
XNORMAL_CODE(detach, schedule , "detach", dodetach);
X
XVOID doterminate()
X{
X TASK t = tp;
X
X /* Check if the task is the foreground task */
X if (tp == foreground) {
X
X /* Empty the return stack and signal end of execution to inner loop */
X rinit();
X running = FALSE;
X tasking = FALSE;
X
X /* Foreground should always terminate on last exit */
X ip = (PTR32) &toterminate;
X }
X else {
X
X /* else remove the current task from the system task queue */
X dodetach();
X t -> status = TERMINATED;
X spush(t, TASK);
X dodequeue();
X }
X}
X
XNORMAL_CODE(terminate, detach, "terminate", doterminate);
X
END_OF_src/multi-tasking.v
if test 5643 -ne `wc -c <src/multi-tasking.v`; then
echo shar: \"src/multi-tasking.v\" unpacked with wrong size!
fi
# end of overwriting check
fi
echo shar: End of archive 3 \(of 6\).
cp /dev/null ark3isdone
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