mip@IDA.LiU.SE (Mikael Patel) (07/17/90)
#! /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 2 (of 6)."
# Contents: INSTALL Makefile bin/forthicon lib/bitfields.f83
# lib/blocks.f83 lib/double.f83 lib/enumerates.f83 lib/lists.f83
# lib/macros.f83 lib/ranges.f83 lib/rationals.f83 lib/sets.f83
# src/Makefile src/exceptions.v src/float.v src/queues.v
# src/string.v tst/exceptions.tst tst/task-sieve.tst
# tst/tree-sort.tst
# Wrapped by mip@mina on Fri Jun 29 16:49:07 1990
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f INSTALL -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"INSTALL\"
else
echo shar: Extracting \"INSTALL\" \(2113 characters\)
sed "s/^X//" >INSTALL <<'END_OF_INSTALL'
XTHREADED INTERPRETIVE LANGUAGE ENVIRONMENT (TILE) INSTALLATION
X
XJune 29, 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@ida.liu.se
X
X
X1. INTRODUCTION
X
XTo install the TILE forth environment create a directory with the
Xname "tile" and move all the "tile.kit" files to the new directory.
XThe kit files should be packed up with the command "sh". A number
Xof additional directories will be build. To compile the TILE forth
Xapplication issue the command "make". The sequence of commands is:
X
X% mkdir tile
X% mv tile.kit.* tile
X% cd tile
X% sh tile.kit.01
X% ...
X% make
X
XThe "make" command will compile the forth environment. You can use
Xthe option "opt" to generate an optimized version.
X
X
X2. SEARCH PATHS
X
XThe compiled forth application will be placed in the "tile/bin"
Xdirectory. To gain access to it and the manual pages you should
Xadd the following section to your ".login" file.
X
Xsetenv TILE $HOME/tile
Xset path = ($path $TILE/bin)
X#
Xsetenv TILEPATH $TILE/lib:$TILE/tst
Xsetenv MANPATH $TILE/man:/usr/share/man
X
X
X3. GNU EMACS FORTH-MODE
X
XThe programming environment is a forth-mode for GNU emacs. To make
Xit accessable to emacs you must add the following definitions to your
X".emacs" file (or load the library "src/forth.el" manually in emacs
Xeach time).
X
X;; *** Search path for directories to find files to load ***
X(set-variable 'load-path (append load-path '(nil "~/tile/scr")))
X
X;; *** TILE forth mode ***
X(setq forth-help-load-path '("~/tile/doc"))
X(autoload 'forth-mode "forth")
X(setq auto-mode-alist
X (append '(("\\.tst$" . forth-mode)
X ("\\.f83$" . forth-mode))
X auto-mode-alist))
X
X
XDepending on which directory you have used ($HOME or some system
Xdirectory) the directory specification will have to be changed. If
Xcorrectly installed emacs will automatically load the forth-mode
Xon files with the extensions "f83" and "tst" and start the forth
Xapplication in a sub-window. For more information about the
Xforth-mode just give the command "M-X describe-mode" in emacs.
END_OF_INSTALL
if test 2113 -ne `wc -c <INSTALL`; then
echo shar: \"INSTALL\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f Makefile -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"Makefile\"
else
echo shar: Extracting \"Makefile\" \(1755 characters\)
sed "s/^X//" >Makefile <<'END_OF_Makefile'
X# NAME
X# Makefile - for management of the tile forth environment
X# SYNOPSIS
X# make [option]
X# DESCRIPTION
X# General environment coordinator for the threaded interpreter language
X# environment (TILE). Allows packaging for distribution etc.
X# OPTIONS
X# forth
X# Compiles the forth compiler/interpreter.
X# new
X# Recompile the forth application without optimization.
X# opt
X# Recompile the forth application with optimization.
X# kit
X# Pack the available files for mailing
X# tar
X# Pack the available files for ftp'ing
X# SEE ALSO
X# make(1), makekit(1), tar(1)
X# AUTHOR
X# Copyright (c) 1990, Mikael R.K. Patel
X# Computer Aided Design Laboratory (CADLAB)
X# Department of Computer and Information Science
X# Linkoping University
X# S-581 83 LINKOPING
X# SWEDEN
X# Email: mip@ida.liu.se
X# HISTORY
X# Started on: 23 May 1990
X# Last updated on: 28 June 1990
X#
X
X# Compile tile forth
Xforth:
X cd src ; make
X
X# Recompile tile forth
Xnew:
X cd src ; make new
X
X# Recompile tile forth
Xopt:
X cd src ; make opt
X
X# Packs the available source and documenation for mailing
Xkit:
X touch src/forth.o
X touch bin/forth
X mv src/*.o tmp
X mv bin/forth tmp
X makekit -ntile.kit. \
X Makefile COPYING README PORTING INSTALL \
X bin bin/* src src/* lib lib/* tst tst/* \
X doc man man/man1 man/man3 man/man1/tile.1 \
X > tile.kit.index
X mv tile.kit.* shar
X mv tmp/*.o src
X mv tmp/forth bin
X makekit -ntile.doc. \
X doc/* man/man3/* \
X > tile.doc.index
X mv tile.doc.* shar
X
X
X# Packs the available source and documentation for ftp'ing
Xtar:
X touch src/forth.o
X touch bin/forth
X mv src/*.o tmp
X mv bin/forth tmp
X tar -cvf tile.tar \
X Makefile COPYING README PORTING INSTALL \
X bin src lib tst doc man
X compress tile.tar
X mv tile.tar.Z shar
X mv tmp/*.o src
X mv tmp/forth bin
X
X
END_OF_Makefile
if test 1755 -ne `wc -c <Makefile`; then
echo shar: \"Makefile\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f bin/forthicon -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"bin/forthicon\"
else
echo shar: Extracting \"bin/forthicon\" \(1933 characters\)
sed "s/^X//" >bin/forthicon <<'END_OF_bin/forthicon'
X/* Format_version=1, Width=64, Height=64, Depth=1, Valid_bits_per_item=16
X */
X 0xFFFF,0xFFFF,0xFFFF,0xFFFF,0x8000,0x0000,0x0000,0x0001,
X 0x8000,0x0000,0x0000,0x0001,0x8000,0x0000,0x0000,0x0001,
X 0x8FFF,0xFFFF,0xF800,0x0001,0x8800,0x0000,0x0800,0x0001,
X 0x8800,0x0000,0x0800,0x0001,0x8804,0x0000,0x0800,0x0001,
X 0x8804,0x0000,0x0800,0x0001,0x8834,0x8960,0x0800,0x0001,
X 0x884C,0x8991,0xC800,0x0001,0x8844,0x8912,0x3E00,0x0001,
X 0x8844,0x8912,0x69E0,0x0001,0x8844,0x8912,0x281E,0x0001,
X 0x884C,0x9991,0xC801,0x8001,0x8834,0x6960,0x0800,0x4001,
X 0x8800,0x0100,0x0800,0x4001,0x8800,0x0100,0x0800,0x2001,
X 0x8800,0x0100,0x0800,0x2001,0x8800,0x0000,0x0800,0x2001,
X 0x8FFF,0xFFFF,0xF800,0x2001,0x8000,0x0000,0x0000,0x2001,
X 0x8000,0x0000,0x0000,0x4001,0x8000,0x0000,0x0000,0x4001,
X 0x8000,0x0000,0x0000,0x8001,0x8000,0x0000,0x0003,0x0001,
X 0x8000,0x0000,0x0004,0x0001,0x8000,0x0000,0x0008,0x0001,
X 0x8000,0x0FFF,0xFFFF,0xF001,0x8000,0x0800,0x0000,0x1001,
X 0x8000,0x0800,0x0000,0x1001,0x8000,0x0800,0x0000,0x1001,
X 0x8000,0x0800,0x0000,0x1001,0x8000,0x0810,0x0000,0x1001,
X 0x8000,0x0810,0x0003,0x9001,0x8000,0x087C,0x0007,0x5001,
X 0x8000,0x0810,0x0005,0xD001,0x8000,0x0810,0x0004,0x5001,
X 0x8000,0x0800,0x0003,0xB001,0x8000,0x0800,0x0000,0x1001,
X 0x8000,0x0800,0x0000,0x1801,0x8000,0x0800,0x0000,0x1801,
X 0x8000,0x0800,0x0000,0x1801,0x8000,0x0FFF,0xFFFF,0xF401,
X 0x8000,0x0000,0x0000,0x0201,0x8000,0x0000,0x0000,0x0201,
X 0x8000,0x0000,0x0000,0x0201,0x81E0,0x0000,0x0000,0x0101,
X 0x803E,0x0000,0x0000,0x0101,0x8003,0xE000,0x0000,0x0101,
X 0x8000,0x3F00,0x0000,0x0101,0x8000,0x03F0,0x0000,0x0101,
X 0x8000,0x003F,0x0000,0x0101,0x8000,0x0003,0xF000,0x0201,
X 0x8000,0x0000,0x3F80,0x0201,0x8000,0x0000,0x03F8,0x0401,
X 0x8000,0x0000,0x003F,0x8401,0x8000,0x0000,0x0003,0xFC01,
X 0x8000,0x0000,0x0000,0x3401,0x8000,0x0000,0x0000,0x1C01,
X 0x8000,0x0000,0x0000,0x0001,0x8000,0x0000,0x0000,0x0001,
X 0x8000,0x0000,0x0000,0x0001,0xFFFF,0xFFFF,0xFFFF,0xFFFF
END_OF_bin/forthicon
if test 1933 -ne `wc -c <bin/forthicon`; then
echo shar: \"bin/forthicon\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f lib/bitfields.f83 -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"lib/bitfields.f83\"
else
echo shar: Extracting \"lib/bitfields.f83\" \(2485 characters\)
sed "s/^X//" >lib/bitfields.f83 <<'END_OF_lib/bitfields.f83'
X\
X\ BIT FIELD MANAGEMENT
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@ida.liu.se
X\
X\ Started on: 30 June 1988
X\
X\ Last updated on: 26 June 1990
X\
X\ Dependencies:
X\ (forth) forth
X\
X\ Description:
X\ Forth level definitions for bit field manipulation. Bit fields are
X\ extracted and altered on the top of stack element. Additional
X\ functions are for bit and field access are also provided.
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 Bit Field definitions...) cr
X
X#ifundef b@ ( Check if bit and field access are not supported by the kernel)
X
X: b@ ( x pos -- bool)
X 1 swap << and boolean
X;
X
X: b! ( x y pos -- z)
X >r 1 tuck
X r@ << not and
X swap rot and
X r> << or
X;
X
X: f@ ( x pos width -- y)
X >r >> -1 r> << not and
X;
X
X: <f@ ( x pos width -- y)
X >r >> -1 r@ << not and
X dup 1 r@ 1- << and
X if -1 r> << or
X else r> drop then
X;
X
X: f! ( x y pos width -- z)
X swap >r -1 swap << not tuck
X r@ << not and
X swap rot and
X r> << or
X;
X
X#then
X
Xvocabulary bitfields
X
Xbitfields definitions
X
X0 field +width ( bits -- width) private
Xcell field +pos ( bits -- pos) private
X
X: bitfield.type ( -- pos0)
X create 0
Xdoes> ( bitfield -- )
X drop variable
X;
X
X: bits ( pos1 width -- pos2)
X create dup , over , +
Xdoes> ( bits -- pos width)
X 2@
X;
X
X: field ( width -- )
X create ,
Xdoes> ( field -- )
X @ bits
X; private
X
X( Initial set of bit field names)
X1 field bit ( -- )
X4 field nibble ( -- )
X8 field byte ( -- )
X16 field word ( -- )
X
X: bitfield.end ( pos3 -- )
X 32 > abort" bitfield.end: warning too many fields"
X;
X
Xforth only
END_OF_lib/bitfields.f83
if test 2485 -ne `wc -c <lib/bitfields.f83`; then
echo shar: \"lib/bitfields.f83\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f lib/blocks.f83 -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"lib/blocks.f83\"
else
echo shar: Extracting \"lib/blocks.f83\" \(2083 characters\)
sed "s/^X//" >lib/blocks.f83 <<'END_OF_lib/blocks.f83'
X\
X\ CODE BLOCK 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@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
X\
X\ Description:
X\ Code blocks as an alternative to passing functions as parameters.
X\ Major usage for iterator function such as "map" and "?map".
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 Block definitions...) cr
X
Xvocabulary blocks
X
Xcompiler blocks definitions
X
X4 cells field +block ( ptr -- block) private
X
X: block[ ( -- )
X compiling ( Check interpreter state)
X if here +block [compile] literal ( If compiling then create literal)
X compile (branch) >mark ( to code section and branch over)
X true ( Mark code compilation state)
X else
X here ( Return pointer to code section)
X false ( Mark non-code compilation state)
X ] ( Start compiling code for block)
X then
X; immediate
X
X: ]; ( -- block)
X [compile] ; ( Compile what semicolon does)
X if >resolve ( If within code resolve branch)
X ] ( And Continue compiling)
X then
X; immediate
X
X: call ( block -- )
X >r ( Perform the block definition)
X;
X
Xforth only
X
END_OF_lib/blocks.f83
if test 2083 -ne `wc -c <lib/blocks.f83`; then
echo shar: \"lib/blocks.f83\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f lib/double.f83 -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"lib/double.f83\"
else
echo shar: Extracting \"lib/double.f83\" \(2282 characters\)
sed "s/^X//" >lib/double.f83 <<'END_OF_lib/double.f83'
X\
X\ DOUBLE PARAMETER STACK WORD DEFINITIONS
X\
X\ Copyright (c) 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@ida.liu.se
X\
X\ Started on: 26 February 1990
X\
X\ Last updated on: 26 February 1990
X\
X\ Dependencies:
X\ (forth) forth, structures, macros
X\
X\ Description:
X\ Stack manipulation definitions for pairs of parameters.
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 Double Parameter definitions...) cr
X
X#include structures.f83
X#include macros.f83
X
Xstructures macros forth definitions
X
Xstruct.type DOUBLE ( low high -- )
X long +high
X long +low
Xstruct.init ( low high double -- )
X#ifundef 2!
X tuck +high ! +low !
X#else
X 2!
X#then
Xstruct.end
X
X: double ( low high -- )
X create , ,
Xdoes> ( double -- low high)
X#ifundef 2@
X dup +low @ swap +high @
X#else
X 2@
X#then
X;
X
X: .double ( addr -- )
X ." double#" dup . ." high: " dup +high @ . ." low: " +low @ .
X;
X
X
X#ifundef 2swap \ Check if the kernel supports double parameters
X
X: 2>r ( a b -- ) >r >r ; macro compilation
X: 2r> ( -- a b) r> r> swap ; macro compilation
X: 2drop ( a b - ) drop drop ; macro
X: 2swap ( a b c d -- c d a b) rot >r rot r> ; macro
X: 2rot ( a b c d e f -- c d e f a b) 2>r 2swap 2r> 2swap ;
X: 2dup ( a b -- a b a b) over over ; macro
X: 2over ( a b c d -- a b c d a b) 3 pick 3 pick ; macro
X: 2@f ( addr -- a b) dup +low @ swap +high @ ; macro
X: 2! ( a b addr -- ) tuck +high ! +low ! ; macro
X
X#then
X
Xforth only
X
END_OF_lib/double.f83
if test 2282 -ne `wc -c <lib/double.f83`; then
echo shar: \"lib/double.f83\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f lib/enumerates.f83 -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"lib/enumerates.f83\"
else
echo shar: Extracting \"lib/enumerates.f83\" \(1765 characters\)
sed "s/^X//" >lib/enumerates.f83 <<'END_OF_lib/enumerates.f83'
X\
X\ ENUMERATE VARIABLES
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@ida.liu.se
X\
X\ Started on: 30 June 1988
X\
X\ Last updated on: 27 June 1990
X\
X\ Dependencies:
X\ (forth) forth
X\
X\ Description:
X\ Forth level definition of enumerate types and variables.
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 Enumeration definitions...) cr
X
Xvocabulary enumerates
X
Xenumerates definitions
X
X: enum.type ( -- id0)
X create 0 ( Create symbol and start definition)
Xdoes> ( enum.type -- )
X drop variable ( Create variable for enumerate type)
X;
X
X: enum.null ( id1 -- id2)
X 1+ ( Advance to next identity)
X;
X
X: >enum ( value -- )
X constant ( Create an item using value given)
X;
X
X: enum ( id1 -- id2)
X dup >enum enum.null ( Create an item and advance ident.)
X;
X
X: enum.end ( id3 -- )
X drop ( Drop identity value)
X;
X
Xforth only
X
END_OF_lib/enumerates.f83
if test 1765 -ne `wc -c <lib/enumerates.f83`; then
echo shar: \"lib/enumerates.f83\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f lib/lists.f83 -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"lib/lists.f83\"
else
echo shar: Extracting \"lib/lists.f83\" \(2352 characters\)
sed "s/^X//" >lib/lists.f83 <<'END_OF_lib/lists.f83'
X\
X\ SINGLE LINKED LISTS
X\
X\ Copyright (c) 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@ida.liu.se
X\
X\ Started on: 1 May 1990
X\
X\ Last updated on: 19 June 1990
X\
X\ Dependencies:
X\ (forth) forth, blocks
X\
X\ Description:
X\ Management of single linked lists. Requires that the list
X\ structures have the link as the first field.
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 Lists definitions...) cr
X
X#include blocks.f83
X
Xvocabulary lists
X
Xblocks lists definitions
X
X: list ( n -- )
X create nil , allot
X;
X
X: empty-list ( list -- )
X nil swap !
X;
X
X: search-list ( element list -- [element last] or [false])
X begin
X 2dup =
X over @ 0= or not
X while
X @
X repeat
X dup @ if 2drop false then
X;
X
X: append-list ( element list -- )
X search-list ?dup if ! then
X;
X
X: insert-list ( element list -- )
X 2dup @ swap ! !
X;
X
X: size-list ( list -- int)
X 0 swap
X begin
X ?dup
X while
X swap 1+ swap @
X repeat
X;
X
X: map-list ( list block[element -- ] -- )
X >r
X begin
X ?dup
X while
X dup r@ swap >r
X call
X r> @
X repeat
X r> drop
X;
X
X: ?map-list ( list block[element -- bool] -- )
X >r
X begin
X ?dup
X while
X dup r@ swap >r
X call
X if 2r> 2drop exit then
X r> @
X repeat
X r> drop
X;
X
X: apply-list ( offset list -- )
X begin
X ?dup
X while
X 2dup 2>r + @
X execute
X 2r> @
X repeat
X;
X
X: ?member-list ( element list -- bool)
X search-list if drop false else true then
X;
X
X: ?empty-list ( list -- bool)
X 0=
X;
X
Xforth only
END_OF_lib/lists.f83
if test 2352 -ne `wc -c <lib/lists.f83`; then
echo shar: \"lib/lists.f83\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f lib/macros.f83 -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"lib/macros.f83\"
else
echo shar: Extracting \"lib/macros.f83\" \(2424 characters\)
sed "s/^X//" >lib/macros.f83 <<'END_OF_lib/macros.f83'
X\
X\ MACRO 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@ida.liu.se
X\
X\ Started on: 30 June 1988
X\
X\ Last updated on: 19 June 1990
X\
X\ Dependencies:
X\ (forth) forth, structures
X\
X\ Description:
X\ Allows colon definitions to be marked as macros and thus expand
X\ when used in compilation (else executed).
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 Macro definitions...) cr
X
X#include internals.f83
X#include structures.f83
X
Xvocabulary macros
X
Xstructures forth macros definitions
X
Xstruct.type MACRO ( -- ) private
X ptr +body private ( Pointer to macro code body)
X long +size private ( Size of code body in bytes)
Xstruct.init ( body size MACRO -- )
X tuck +size ! +body ! ( Initiate macro structure block)
Xstruct.end
X
X: [macro] ( macro -- )
X compiling ( Check compilation state. If compiling)
X if dup +body @ here ( Allocate space for copy of macro body)
X rot +size @ dup allot cmove ( Allocate and copy)
X else ( If execution mode)
X +body @ >r ( Access body and execute)
X then
X; private
X
X: macro ( -- )
X last >body here over - sizeof ptr - ( Create a new MACRO structure)
X new MACRO last +parameter ! ( Modify parameter field of last)
X immediate ( and mode field to immediate)
X ['] [macro] >body last +code ! ( and code field to macro management)
X;
X
X: .macro ( -- )
X ." macro#" ' >body dup . ( Access macro and print address)
X ." size: " dup +size @ . ( and the size )
X ." body: " +body @ . ( and pointer to body of macro)
X;
X
Xforth only
X
END_OF_lib/macros.f83
if test 2424 -ne `wc -c <lib/macros.f83`; then
echo shar: \"lib/macros.f83\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f lib/ranges.f83 -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"lib/ranges.f83\"
else
echo shar: Extracting \"lib/ranges.f83\" \(2712 characters\)
sed "s/^X//" >lib/ranges.f83 <<'END_OF_lib/ranges.f83'
X\
X\ RANGE 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@ida.liu.se
X\
X\ Started on: 30 June 1988
X\
X\ Last updated on: 28 June 1990
X\
X\ Dependencies:
X\ (forth) forth, blocks, and structures.
X\
X\ Description:
X\ Allows definition and manipulation of integer ranges.
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 Range definitions...) cr
X
X#include blocks.f83
X#include structures.f83
X
Xvocabulary ranges
X
Xblocks structures ranges definitions
X
Xstruct.type RANGE ( -- range)
X long +to ( range -- ptr) private
X long +from ( range -- ptr) private
Xstruct.end
X
X: range ( from to -- )
X create , ,
Xdoes> ( range -- from to)
X 2@
X;
X
X: ?member-range ( x from to -- bool)
X ?within
X;
X
X: ?intersection-range ( from1 to1 from2 to2 -- bool)
X -rot < >r swap < r> or not
X;
X
X: size-range ( from to -- int)
X swap - 1+
X;
X
X: union-range ( from1 to1 from2 to2 -- from3 to3)
X rot max >r min r>
X;
X
X: intersection-range ( from1 to1 from2 to2 -- from3 to3)
X 2over 2over ?intersection-range
X if rot min >r max r>
X else
X 2drop 2drop 0 0
X then
X;
X
X: map-range ( from to block[index -- ] -- )
X swap 1+ rot do
X i swap dup >r call r>
X loop
X drop
X;
X
X: ?map-range ( from to block[index -- bool] -- )
X swap 1+ rot do
X i swap dup >r call r> swap
X if leave then
X loop
X drop
X;
X
X: ?range ( string -- [from to true] or [string false])
X >r 0 r@ dup c@ ascii [ =
X if 1+ dup c@ ascii - =
X if 1+ convert swap negate swap
X else convert then
X dup c@ ascii . = over c@ ascii . = and
X if 0 swap 2+ dup c@ ascii - =
X if 1+ convert swap negate swap
X else convert then
X dup c@ ascii ] = swap 1+ c@ 0= and
X if 2dup > not
X if r> drop compiling
X if swap [compile] literal then
X true exit
X then
X then
X then
X then
X 2drop r> false
X; recognizer
X
Xforth only
X
END_OF_lib/ranges.f83
if test 2712 -ne `wc -c <lib/ranges.f83`; then
echo shar: \"lib/ranges.f83\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f lib/rationals.f83 -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"lib/rationals.f83\"
else
echo shar: Extracting \"lib/rationals.f83\" \(3597 characters\)
sed "s/^X//" >lib/rationals.f83 <<'END_OF_lib/rationals.f83'
X\
X\ RATIONAL NUMBER MANAGEMENT
X\
X\ Copyright (c) 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@ida.liu.se
X\
X\ Started on: 25 May 1990
X\
X\ Last updated on: 28 June 1990
X\
X\ Dependencies:
X\ (forth) forth and structures
X\
X\ Description:
X\ Management of a rational number system. Allows recognition of
X\ rational literals, calculation with rational numbers, and output.
X\ The rational number system includes representation of undefined,
X\ infinity and normalization of rational numbers towards zero.
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 Rational number definitions...) cr
X
X#include structures.f83
X
Xvocabulary rationals
X
Xstructures rationals definitions
X
Xstruct.type RATIONAL ( -- rational)
X long +denomerator ( rational -- ptr) private
X long +numerator ( rational -- ptr) private
Xstruct.end
X
X: rational ( num denom -- )
X create , ,
Xdoes> ( rational -- num denom)
X 2@
X;
X
X 0 0 rational undefined ( -- num denom)
X 0 1 rational zero ( -- num denom)
X 1 0 rational infinity ( -- num denom)
X-1 0 rational -infinity ( -- num denom)
X
X: rnormalize ( num1 denom1 -- num2 denom2)
X ?dup
X if over 0=
X if 2drop zero exit then
X 2dup
X begin
X ?dup
X while
X tuck mod
X repeat
X tuck / -rot / swap
X dup 0<
X if negate swap negate swap then
X else
X ?dup
X if 0>
X if infinity else -infinity then
X else
X undefined
X then
X then
X;
X
X: rnegate ( num1 denom1 -- num2 denom2)
X swap negate swap
X;
X
X: r+ ( num1 denom1 num2 denom2 -- num3 denom3)
X >r over r@ =
X if nip + r>
X else
X over * rot r@ * + swap r> *
X then
X rnormalize
X;
X
X: r- ( num1 denom1 num2 denom2 -- num3 denom3)
X rnegate r+
X;
X
X: r* ( num1 denom1 num2 denom2 -- num3 denom3)
X >r rot * swap r> * rnormalize
X;
X
X: 1/r ( num1 denom1 -- num2 denom2)
X swap dup 0< if negate swap negate swap then
X;
X
X: r/ ( num1 denom1 num2 denom2 -- num3 denom3)
X swap r*
X;
X
X: r. ( num denom -- )
X ?dup
X if over 0=
X if 2drop ." zero"
X else
X swap 0 .r ." /" 0 .r
X then
X else
X ?dup
X if 0>
X if ." infinity" else ." -infinity" then
X else
X ." undefined"
X then
X then
X space
X;
X
X: ?r= ( num1 denom1 num2 denom2 -- bool)
X rot = -rot = and
X;
X
X: ?r> ( num1 denom1 num2 denom2 -- bool)
X r- drop 0>
X;
X
X: ?r< ( num1 denom1 num2 denom2 -- bool)
X r- drop 0<
X;
X
X: i>r ( x -- num denom)
X 1
X;
X
X: r>i ( num denom -- x)
X /
X;
X
X: ?rational ( string -- [num denom true] or [string false])
X >r 0 r@ dup c@ ascii - =
X if 1+ convert swap negate swap
X else convert then
X dup c@ ascii / =
X if 0 swap 1+ convert c@ 0=
X if r> drop rnormalize compiling
X if swap [compile] literal then
X true exit
X then
X then
X 2drop r> false
X; recognizer
X
X
Xforth only
X
END_OF_lib/rationals.f83
if test 3597 -ne `wc -c <lib/rationals.f83`; then
echo shar: \"lib/rationals.f83\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f lib/sets.f83 -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"lib/sets.f83\"
else
echo shar: Extracting \"lib/sets.f83\" \(3246 characters\)
sed "s/^X//" >lib/sets.f83 <<'END_OF_lib/sets.f83'
X\
X\ SETS IN VECTOR REPRESENTATION
X\
X\ Copyright (c) 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@ida.liu.se
X\
X\ Started on: 1 May 1990
X\
X\ Last updated on: 28 June 1990
X\
X\ Dependencies:
X\ (forth) forth, and blocks.
X\
X\ Description:
X\ Management of sets represented as a vector of cells. The set
X\ is terminated by the value zero (nil). Thus zero cannot be
X\ a member of a set. Used mainly for sets of entries. The tile
X\ forth vocabulary search path, "context", is defined as a set
X\ of vocabulary entry pointers.
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 Sets definitions...) cr
X
X#include blocks.f83
X
Xvocabulary sets
X
Xblocks sets definitions
X
X: SET ( size -- )
X create nil here ! cells allot
X;
X
X: { ( -- )
X align here ]
X;
X
X: } ( -- set)
X nil , [compile] [
X; immediate
X
X: empty-set ( set -- )
X nil swap !
X;
X
X: search-set ( element set -- [element last] or [false])
X swap >r
X begin
X dup @ r@ over =
X if r> 2drop drop false exit then
X while
X cell+
X repeat
X r> swap
X;
X
X: append-set ( element set -- )
X search-set ?dup if nil over cell+ ! ! then
X;
X
X: remove-set ( element set -- )
X swap >r
X begin
X dup @ r@ over =
X if r> 2drop
X begin
X dup cell+ dup @ rot !
X dup @ 0=
X until
X drop
X exit
X then
X while
X cell+
X repeat
X r> swap
X;
X
X: size-set ( set -- int)
X 0 swap
X begin
X dup @
X while
X swap 1+ swap cell+
X repeat
X drop
X;
X
X: map-set ( set block[element -- ] -- )
X >r
X begin
X dup @ ?dup
X while
X r@ rot >r
X call
X r> cell+
X repeat
X r> 2drop
X;
X
X: ?map-set ( set block[element -- bool] -- )
X >r
X begin
X dup @ ?dup
X while
X r@ rot >r
X call
X if 2r> 2drop exit then
X r> cell+
X repeat
X r> 2drop
X;
X
X: union-set ( set1 set2 -- set2)
X >r
X begin
X dup @ ?dup
X while
X r@ append-set
X cell+
X repeat
X drop r>
X;
X
X: intersection-set ( set1 set2 -- set2)
X tuck 2>r
X begin
X dup @ ?dup
X while
X r@ search-set
X if drop dup
X begin
X dup cell+ dup @ rot !
X dup @ 0=
X until
X drop
X else cell+ then
X repeat
X r> 2drop r>
X;
X
X: apply-set ( set -- )
X begin
X dup @ ?dup
X while
X execute cell+
X repeat
X drop
X;
X
X: ?member-set ( element set -- bool)
X search-set if drop false else true then
X;
X
X: ?empty-set ( set -- bool)
X @ 0=
X;
X
X: .set ( set -- )
X ." set#" dup . ." size: " size-set .
X;
X
Xforth only
END_OF_lib/sets.f83
if test 3246 -ne `wc -c <lib/sets.f83`; then
echo shar: \"lib/sets.f83\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f src/Makefile -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"src/Makefile\"
else
echo shar: Extracting \"src/Makefile\" \(2614 characters\)
sed "s/^X//" >src/Makefile <<'END_OF_src/Makefile'
X# NAME
X# Makefile - for the tile forth environment
X# SYNOPSIS
X# make [option]
X# DESCRIPTION
X# General compilation coordinator for the threaded interpreter language
X# environment (TILE). Allow compilation in different modes to simplify
X# program development; compiling, recompiling, debugging, profiling, and
X# benchmarks.
X# OPTIONS
X# new
X# Cleans up and compiles a fresh version.
X# opt
X# Use all optimization tricks known by cc.
X# dbx
X# Recompile for debugging with dbx.
X# gprof
X# Recompile for profiling with gprof.
X# lint
X# Verify the source code using lint.
X# bench
X# Some benchmarks to evaluate this threading method
X# SEE ALSO
X# make(1), cc(1), touch(1), dbx(1), grof(1), lint(1), time(1)
X# AUTHOR
X# Copyright (c) 1989, 1990, Mikael R.K. Patel
X# Computer Aided Design Laboratory (CADLAB)
X# Department of Computer and Information Science
X# Linkoping University
X# S-581 83 LINKOPING
X# SWEDEN
X# Email: mip@ida.liu.se
X# HISTORY
X# Started on: 01 April 1989
X# Last updated on: 27 June 1990
X#
X
X
X# Source and object files
XSRC = kernel.c io.c error.c memory.c forth.c
XVOCS = compiler.v exceptions.v locals.v memory.v queues.v multi-tasking.v string.v float.v
XOBJS = kernel.o io.o error.o memory.o
XHEADS = kernel.h io.h error.h memory.h
X
X# Template for your machine dependencies and libraries
X# LIBS = -lyourlibrary
X# CFLAGS = -youroption -DYOURMACHINE
X
Xforth: $(OBJS) forth.o
X $(CC) $(CFLAGS) -o $@ $(OBJS) forth.o $(LIBS)
X mv forth ../bin
X
X
X# Object code dependencies
Xforth.o: $(HEADS)
X
Xkernel.o: $(HEADS) $(VOCS)
X
Xmemory.o: $(HEADS)
X
Xerror.o: $(HEADS)
X
Xio.o: $(HEADS)
X
X
X# Cleans up and compiles a new version
Xnew:
X touch forth.o
X rm *.o
X make forth
X
X
X# Compiles with all optimization tricks
Xopt:
X touch forth.o
X rm *.o
X make forth "CFLAGS=$(CFLAGS) -O3"
X
X
X# Compiles for debugging with "dbx" or "dbxtool"
Xdbx:
X touch forth.o
X rm *.o
X make forth "CFLAGS=$(CFLAGS) -g"
X
X
X# Compiles for profiling with "gprof"
Xgprof:
X touch forth.o
X rm *.o
X make forth "CFLAGS=$(CFLAGS) -DPROFILE -Bstatic -pg"
X# forth
X# gprof forth
X
X# Verify the source code
Xlint:
X lint $(CFLAG) -DLINT $(SRC)
X
X
X# Run the benchmarks
Xbench:
X time forth byte-sieve.tst -s byte-sieve
X time forth colburn-sieve.tst -s colburn-sieve
X time forth fibonacci.tst -s recursive-fib
X time forth fibonacci.tst -s tail-recursive-fib
X time forth bubble-sort.tst -s bubble-sort
X time forth bubble-sort.tst -s bubble-sort-with-flag
X time forth tree-sort.tst -s tree-sort
X time forth matrix-mult.tst -s matrix-mult
X time forth permutations.tst -s permutations
X time forth towers-of-hanoi.tst -s towers-of-hanoi
X time forth task-sieve.tst -s task-sieve
X
END_OF_src/Makefile
if test 2614 -ne `wc -c <src/Makefile`; then
echo shar: \"src/Makefile\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f src/exceptions.v -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"src/exceptions.v\"
else
echo shar: Extracting \"src/exceptions.v\" \(3158 characters\)
sed "s/^X//" >src/exceptions.v <<'END_OF_src/exceptions.v'
X/*
X C BASED FORTH-83 MULTI-TASKING KERNEL: EXCEPTION MANAGEMENT
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@ida.liu.se
X
X Started on: 30 June 1988
X
X Last updated on: 22 April 1990
X
X Dependencies:
X (cc) kernel.c, kernel.h
X
X Description:
X Error signal and exception extension vocabulary of the
X 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
XVOID doexception()
X{
X spush(NIL, INT32);
X spush(NORMAL, INT32);
X spush(EXCEPTION, INT32);
X spush(' ', INT32);
X doword();
X doentry();
X}
X
XNORMAL_CODE(exception, forth, "exception", doexception);
X
XVOID doparenexceptionsemicolon()
X{
X fthrow();
X}
X
XCOMPILATION_CODE(parenexceptionsemicolon, exception, "(exception;)", doparenexceptionsemicolon);
X
XVOID doparenexceptionunlinksemicolon()
X{
X funlink();
X fthrow();
X}
X
XCOMPILATION_CODE(parenexceptionunlinksemicolon, parenexceptionsemicolon, "(exceptionunlink;)", doparenexceptionunlinksemicolon);
X
XVOID doparenexception()
X{
X fcatch();
X}
X
XCOMPILATION_CODE(parenexception, parenexceptionunlinksemicolon, "(exception>)", doparenexception);
X
XVOID doexceptionsharp()
X{
X ENTRY t;
X
X /* Set up pointer to last definition */
X dolast();
X t = spop(ENTRY);
X
X /* Compile an exit of the current definition */
X if (theframed != NIL) {
X spush(&parenexceptionunlinksemicolon, CODE_ENTRY);
X }
X else {
X spush(&parenexceptionsemicolon, CODE_ENTRY);
X }
X dothread();
X doremovelocals();
X
X /* Redefine the code type of the last definition */
X t -> code = (INT32) dp;
X
X /* Compile the run time exception management definition */
X spush(&parenexception, CODE_ENTRY);
X dothread();
X}
X
XCOMPILATION_IMMEDIATE_CODE(exceptionsharp, parenexception, "exception>", doexceptionsharp);
X
XVOID doraise()
X{
X INT32 s = spop(INT32);
X
X /* Check if there is an exception block available */
X if (ep != NIL) {
X
X /* Restore the call environment */
X rp = ep;
X ep = (PTR32) rpop();
X fp = (PTR32) rpop();
X ip = (PTR32) rpop();
X sp = (PTR) rpop();
X tos.INT32 = rpop();
X
X /* Pass on the signal or exception to the exception block */
X spush(s, INT32);
X }
X else {
X
X /* Call low level management of signal */
X (VOID) error_signal(s);
X }
X}
X
XNORMAL_CODE(raise, exceptionsharp, "raise", doraise);
X
END_OF_src/exceptions.v
if test 3158 -ne `wc -c <src/exceptions.v`; then
echo shar: \"src/exceptions.v\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f src/float.v -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"src/float.v\"
else
echo shar: Extracting \"src/float.v\" \(2373 characters\)
sed "s/^X//" >src/float.v <<'END_OF_src/float.v'
X/*
X C BASED FORTH-83 MULTI-TASKING KERNEL: FLOATING POINT NUMBERS
X
X Copyright (c) 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@ida.liu.se
X
X Started on: 12 April 1990
X
X Last updated on: 26 June 1990
X
X Dependencies:
X (cc) kernel.c, kernel.h
X
X Description:
X Floating point number extension vocabulary for the tile forth
X 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
X
XVOID doitof()
X{
X coerce(INT32, FLOAT32);
X}
X
XNORMAL_CODE(itof, forth, "i>f", doitof);
X
XVOID doftoi()
X{
X coerce(FLOAT32, INT32);
X}
X
XNORMAL_CODE(ftoi, itof, "f>i", doftoi);
X
XVOID dofplus()
X{
X binary(+, FLOAT32);
X}
X
XNORMAL_CODE(fplus, ftoi, "f+", dofplus);
X
XVOID dofminus()
X{
X binary(-, FLOAT32);
X}
X
XNORMAL_CODE(fminus, fplus, "f-", dofminus);
X
XVOID doftimes()
X{
X binary(*, FLOAT32);
X}
X
XNORMAL_CODE(ftimes, fminus, "f*", doftimes);
X
XVOID dofdivide()
X{
X binary(/, FLOAT32);
X}
X
XNORMAL_CODE(fdivide, ftimes, "f/", dofdivide);
X
XVOID dofonedivide()
X{
X unary(1.0 /, FLOAT32);
X}
X
XNORMAL_CODE(fonedivide, fdivide, "1/f", dofonedivide);
X
XVOID dofnegate()
X{
X unary(-, FLOAT32);
X}
X
XNORMAL_CODE(fnegate, fonedivide, "fnegate", dofnegate);
X
XVOID dofdot()
X{
X FLOAT32 f;
X
X f = tos.FLOAT32;
X sdrop();
X (VOID) fprintf(io_outf, "%g ", f);
X}
X
XNORMAL_CODE(fdot, fnegate, "f.", dofdot);
X
XVOID doqfloat()
X{
X FLOAT32 f;
X CHAR c;
X
X if (sscanf(tos.CSTR, "%f%1c", &f, &c) == 1) {
X tos.FLOAT32 = f;
X spush(TRUE, BOOL);
X }
X else {
X spush(FALSE, BOOL);
X }
X}
X
XNORMAL_CODE(qfloat, fdot, "?float", doqfloat);
X
END_OF_src/float.v
if test 2373 -ne `wc -c <src/float.v`; then
echo shar: \"src/float.v\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f src/queues.v -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"src/queues.v\"
else
echo shar: Extracting \"src/queues.v\" \(1855 characters\)
sed "s/^X//" >src/queues.v <<'END_OF_src/queues.v'
X/*
X C BASED FORTH-83 MULTI-TASKING KERNEL: DOUBLE LINKED LIST
X
X Copyright (c) 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@ida.liu.se
X
X Started on: 12 April 1990
X
X Last updated on: 26 June 1990
X
X Dependencies:
X (cc) kernel.c, kernel.h
X
X Description:
X Double linked list (queues) extension vocabulary for the tile
X 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
XVOID doqemptyqueue()
X{
X compare(== ((INT32) tos.QUEUE -> succ), INT32);
X}
X
XNORMAL_CODE(qemptyqueue, forth, "?empty-queue", doqemptyqueue);
X
XVOID doenqueue()
X{
X register QUEUE t, q;
X
X q = spop(QUEUE);
X t = spop(QUEUE);
X
X t -> pred = q -> pred;
X t -> succ = q;
X
X q -> pred -> succ = t;
X q -> pred = t;
X}
X
XNORMAL_CODE(enqueue, qemptyqueue, "enqueue", doenqueue);
X
XVOID dodequeue()
X{
X register QUEUE t;
X
X t = spop(QUEUE);
X
X t -> succ -> pred = t -> pred;
X t -> pred -> succ = t -> succ;
X
X t -> succ = t -> pred = t;
X}
X
XNORMAL_CODE(dequeue, enqueue, "dequeue", dodequeue);
X
END_OF_src/queues.v
if test 1855 -ne `wc -c <src/queues.v`; then
echo shar: \"src/queues.v\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f src/string.v -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"src/string.v\"
else
echo shar: Extracting \"src/string.v\" \(2827 characters\)
sed "s/^X//" >src/string.v <<'END_OF_src/string.v'
X/*
X C BASED FORTH-83 MULTI-TASKING KERNEL: NULL TERMINATED STRINGS
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@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 Null terminated string extension vocabulary for the tile forth
X 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
XVOID doparenquote()
X{
X spush(*ip++, INT32);
X}
X
XCOMPILATION_CODE(parenquote, forth, "(\")", doparenquote);
X
XVOID doquote()
X{
X /* Scan for the string */
X (VOID) io_scan(thetib, '"');
X
X /* Make a copy of it */
X spush(thetib, CSTR);
X dosdup();
X
X /* If compilation mode then thread a string literal */
X if (state.parameter) {
X spush(&parenquote, CODE_ENTRY);
X dothread();
X docomma();
X }
X}
X
XIMMEDIATE_CODE(quote, parenquote, "\"", doquote);
X
XVOID doslength()
X{
X tos.INT32 = (INT32) strlen(tos.CSTR);
X}
X
XNORMAL_CODE(slength, quote, "$length", doslength);
X
XVOID dosallot()
X{
X tos.CSTR = (CSTR) malloc((unsigned) tos.NUM32);
X}
X
XNORMAL_CODE(sallot, slength, "$allot", dosallot);
X
XVOID dosdup()
X{
X tos.CSTR = (CSTR) strcat((char *) malloc((unsigned) strlen(tos.CSTR) + 1), tos.CSTR);
X}
X
XNORMAL_CODE(sdup_entry, sallot, "$dup", dosdup);
X
XVOID dosfree()
X{
X CSTR s;
X
X s = spop(CSTR);
X free(s);
X}
X
XNORMAL_CODE(sfree, sdup_entry, "$free", dosfree);
X
XVOID dosequal()
X{
X CSTR s;
X
X s = spop(CSTR);
X tos.INT32 = (STREQ(tos.CSTR, s) ? TRUE : FALSE);
X}
X
XNORMAL_CODE(sequal, sfree, "$equal", dosequal);
X
XVOID doscompare()
X{
X CSTR s;
X
X s = spop(CSTR);
X tos.INT32 = (INT32) strcmp(tos.CSTR, s);
X}
X
XNORMAL_CODE(scompare, sequal, "$cmp", doscompare);
X
XVOID doscat()
X{
X CSTR s;
X
X s = spop(CSTR);
X tos.CSTR = (CSTR) strcat((char *) tos.CSTR, s);
X}
X
XNORMAL_CODE(scat, scompare, "$cat", doscat);
X
XVOID dosprint()
X{
X CSTR s;
X
X s = spop(CSTR);
X (VOID) fprintf(io_outf, "%s", s);
X}
X
XNORMAL_CODE(sprint, scat, "$.", dosprint);
X
END_OF_src/string.v
if test 2827 -ne `wc -c <src/string.v`; then
echo shar: \"src/string.v\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f tst/exceptions.tst -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"tst/exceptions.tst\"
else
echo shar: Extracting \"tst/exceptions.tst\" \(1812 characters\)
sed "s/^X//" >tst/exceptions.tst <<'END_OF_tst/exceptions.tst'
X.( Loading Exceptions test...) cr
X
X( Should be used in interactive mode only
X
X#include multi-tasking.f83
X
Xmulti-tasking exceptions forth definitions
X
X.( 1: Low level errors generated by hardware) cr
X10 0 / ( Try some real errors)
X0 @ ( Divide by zero, seg. violation)
X1198203980 @ ( and bus error. All on a SUN-3/60)
X
X.( 2: Example of simulating low level errors, i.e., signals) cr
X3 raise ( Simulates a quit signal)
X5 raise ( and a trace trap signal)
X0 raise ( and an input package error)
X
X.( 3: Example of user defined errors types, i.e., exceptions) cr
Xexception zero-divide ( User defined exception)
Xzero-divide raise ( And default error message)
X
X.( 4: Example showing that the errors are only local to a task) cr
X0 SEMAPHORE synch
X
X16 16 task.type FOO
Xtask.body
X ." Task#" running @ . ." scheduled" cr
X synch wait
X 10 0 /
X ." You shouldn't receive this message" cr
Xtask.end
X
XFOO foo
X
X16 16 task.type FIE
Xtask.body
X ." Task#" running @ . ." schedule" cr
X synch wait
X zero-divide raise
X ." You shouldn't receive this message" cr
Xtask.end
X
XFIE fie
X
Xwho
Xsynch signal ( Signal to the tasks to continue)
Xsynch signal
Xwho ( Show that they are terminated)
X
X.( 5: Forth level exception block definition examples) cr
X
X.( 5.1: Example of transformation of signal to exception) cr
X: div ( x y -- q)
X /
Xexception> ( x y signal -- )
X drop zero-divide raise ; ( Transform signal to an exception)
X
X10 0 div
X
X.( 5.2: Example of user level messages) cr
X: divide ( x y - )
X div
Xexception> ( x y signal -- )
X abort" divide: you shouldn't divide by zero" ;
X
X10 0 divide cr
X
X.( 5.3: Example of a retry expection handling) cr
X: divide ( x y -- )
X div
Xexception> ( x y exception -- )
X case
X zero-divide of 1+ recurse endof
X raise
X endcase ;
X
X10 0 divide . cr
X
X)
X
Xforth only
END_OF_tst/exceptions.tst
if test 1812 -ne `wc -c <tst/exceptions.tst`; then
echo shar: \"tst/exceptions.tst\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f tst/task-sieve.tst -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"tst/task-sieve.tst\"
else
echo shar: Extracting \"tst/task-sieve.tst\" \(1707 characters\)
sed "s/^X//" >tst/task-sieve.tst <<'END_OF_tst/task-sieve.tst'
X.( Loading Multi-tasking Sieve benchmark...) cr
X
X\ A fancy way of calculating prime numbers using dynamic creation of tasks.
X\ Adapted from Barnes, Programming in Ada, 3rd ed., Addison-Wesley, 1989
X\ ch. 14 Tasking, sec. 9 Examples of Task Types, pp. 324-327.
X
X#include structures.f83
X#include multi-tasking.f83
X
Xstructures multi-tasking forth definitions
X
XONE-TO-ONE CHAN parameter ( Parameter passing channel)
X
X16 16 task.type FILTER ( -- )
X ptr previous ( Channel to previous task)
X long prime ( The local prime number)
X ptr next ( Channel to next task)
Xtask.body
X parameter receive previous ! ( Receive previous task channel)
X parameter receive dup . prime ! ( And local prime number parameters)
X nil next ! ( Initiate next task channel to nil)
X begin ( For ever and ever do)
X previous @ receive dup ( Reveive the next number to check)
X prime @ mod ( Check if not divisibly)
X if next @ ?dup ( Check if there exists a next channel)
X if send ( Send to next filter task)
X else
X new-task FILTER drop ( Create a new filter task)
X ONE-TO-ONE new CHAN dup next ! ( Save reference to next channel)
X parameter send ( Send previous channel name)
X parameter send ( And the prime number)
X then
X else
X drop ( Drop if divisible)
X then ( And try again)
X again
Xtask.end
X
X: task-sieve ( -- )
X new-task FILTER drop ( Create the initial filter task)
X ONE-TO-ONE new CHAN ( And its previous channel)
X dup parameter send ( Send the parameters to the task)
X 2 parameter send
X 1024 3 do ( Send a stream of number and)
X i over send ( let the tasks filter out the)
X loop ( prime numbers)
X drop
X;
X
Xforth only
END_OF_tst/task-sieve.tst
if test 1707 -ne `wc -c <tst/task-sieve.tst`; then
echo shar: \"tst/task-sieve.tst\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f tst/tree-sort.tst -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"tst/tree-sort.tst\"
else
echo shar: Extracting \"tst/tree-sort.tst\" \(2637 characters\)
sed "s/^X//" >tst/tree-sort.tst <<'END_OF_tst/tree-sort.tst'
X.( Loading Tree Sort benchmark...) cr
X
X\ A classical benchmark of an O(log n) algorithm; Tree Sort
X\
X\ Part of the programs gathered by John Hennessy for the MIPS
X\ RISC project at Stanford. Translated to forth by Matin Freamen,
X\ Johns Hopkins University/Applied Physics Laboratory.
X
X: exchange ( x y -- ) dup @ rot dup @ >r ! r> swap ! ;
X
Xvariable seed
X
X: initiate-seed ( -- ) 74755 seed ! ;
X: random ( -- n ) seed @ 1309 * 13849 + 65535 and dup seed ! ;
X
X\ These structure access words were originally developed by
X\ at JHU/APL by Ben Ballard and John Hayes
X\ Structure access words
X\ Examples of use:
X\ structure foo \ declare a structure named foo
X\ wrd: .thing1 \ with a one word field named .thing1
X\ 2 wrds: .thing2 \ and a two word field named .thing2
X\ endstructure
X\
X\ structure foobar \ another structure
X\ wrd: .thing
X\ foo struct: .blah \ nested structure
X\ endstructure
X\
X\ foobar makestruct test \ allocate space for a structure instance
X\ 1234 test .blah .thing1 ! \ access structure
X
X: structure ( --- structure offset0)
X create here 0 , 0
Xdoes> ( structure -- size)
X @
X;
X
X: struct: ( offset1 size --- offset2)
X create over , +
Xdoes> ( structure field -- field-addr)
X @ +
X;
X
X: wrds: ( offset1 size --- offset2) cells struct: ;
X: wrd: ( offset1 --- offset2) cell struct: ;
X: endstructure ( structure size --- ) swap ! ;
X: makestruct ( size --- ) create allot ;
X: malloc ( structure -- instance) here swap allot ;
X
X\ The Tree Sort definitions:
X
Xstructure node ( -- )
X wrd: .left
X wrd: .right
X wrd: .val
Xendstructure
X
X5000 constant tree-size
Xvariable tree
X
X: create-node ( n t -- )
X node malloc dup >r swap !
X r@ .val !
X nil r@ .left !
X nil r> .right !
X;
X
X: insert-node ( n t -- )
X 2dup .val @ >
X if dup .left @ nil =
X if 2dup .left create-node
X else
X 2dup .left @ recurse
X then
X else 2dup .val @ <
X if dup .right @ nil =
X if 2dup .right create-node
X else
X 2dup .right @ recurse
X then
X then
X then
X 2drop
X;
X
X: verify-tree ( t -- f)
X true >r dup .left @ nil = not
X if dup .left @ .val @ over .val @ > not
X if r> drop false >r
X else dup .left @ recurse r> and >r then
X then
X dup .right @ nil = not
X if dup .right @ .val @ over .val @ < not
X if r> drop false >r
X else dup .right @ recurse r> and >r then
X then
X drop r>
X;
X
X: dump-tree ( t -- )
X dup nil = not
X if dup .right @ recurse
X dup .val @ .
X dup .left @ recurse
X then
X drop
X;
X
X: tree-sort ( -- )
X initiate-seed
X random tree create-node
X tree @
X tree-size 0 do
X random over insert-node
X loop
X verify-tree not abort" trees: wrong result"
X;
X
Xforth only
END_OF_tst/tree-sort.tst
if test 2637 -ne `wc -c <tst/tree-sort.tst`; then
echo shar: \"tst/tree-sort.tst\" unpacked with wrong size!
fi
# end of overwriting check
fi
echo shar: End of archive 2 \(of 6\).
cp /dev/null ark2isdone
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