mip@IDA.LiU.SE (Mikael Patel) (06/29/90)
--
Mikael R.K. Patel
Researcher and Lecturer
Computer Aided Design Laboratory (CADLAB)
Department of Computer and Information Science
Linkoping University, S-581 83 LINKOPING, SWEDEN
Phone: +46 13281821
Telex: 8155076 LIUIDA S Telefax: +46 13142231
Internet: mip@ida.liu.se UUCP: {uunet,mcsun,...}!liuida!mip
Bitnet: MIP@SELIUIDA SUNET: LIUIDA::MIPmip@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 1 (of 6)."
# Contents: README bin bin/forthtool bin/mkdoc bin/short bin/sop doc
# lib man man/man1 man/man3 src src/error.h src/io.h src/memory.c
# src/memory.h src/memory.v tst tst/bitfields.tst tst/blocks.tst
# tst/bubble-sort.tst tst/byte-sieve.tst tst/channels.tst
# tst/colburn-sieve.tst tst/debugger.tst tst/double.tst
# tst/enumerates.tst tst/fibonacci.tst tst/locals.tst tst/macros.tst
# tst/matrix-mult.tst tst/permutations.tst tst/queues.tst
# tst/ranges.tst tst/rationals.tst tst/rendezvous.tst
# tst/semaphores.tst tst/sets.tst tst/structures.tst
# tst/towers-of-hanoi.tst
# Wrapped by mip@mina on Fri Jun 29 16:49:03 1990
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f README -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"README\"
else
echo shar: Extracting \"README\" \(14371 characters\)
sed "s/^X//" >README <<'END_OF_README'
XTHREADED INTERPRETIVE LANGUAGE ENVIRONMENT (TILE) [RELEASE 2.0]
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
XTILE Forth is a 32-bit implementation of the Forth-83 Standard
Xwritten in C. Thus allowing it to be easily moved between different
Xcomputers compared to traditional Forth implementations in assembly.
X
XMost Forth implementations are done in assembly to be able to
Xutilize the underlying architecture as optimal as possible. TILE
XForth goes another direction. The main idea behind TILE Forth is to
Xachieve a portable forth implementation for workstations and medium
Xsize computer systems so that new groups of programmers may be exposed
Xto the flavor of an extensible language such as Forth.
X
XThe implementation of TILE Forth is selected so that, in principle,
Xany C-level procedure may become available on the interactive and
Xincremental forth level. Other models of implementation of a threaded
Xinterpreter in C are possible but are not as flexible.
X
XTILE Forth is organized as a set of modules to allow the kernel to be
Xused as a general threading engine for C. Environment dependencies such
Xas memory allocation, error handling and input/output have been separated
Xout of the kernel to increase flexibility. The forth application is "just"
Xan example of how to use the kernel.
X
XComparing forth implementation using the traditional benchmark such as
Xthe classical sieves calculation is difficult because of difference in
Xspeed between workstations and personal computers. The Byte sieves
Xbenchmark is reported to typically run in 16 seconds on a direct threaded
Xforth implementation. This benchmark will run in 27 seconds in TILE forth
Xon a SUN-3/60 and less than 13 seconds on a SUN SPARCstation 1. These times
Xare the total time for loading TILE forth, compiling and executing the
Xbenchmark. Comparing to, for instance, other interpretive languages such
Xas Lisp, where one of the classical benchmarks is calculation of the
XFibonacci function, the performance increase is over one magnitude.
X
XThe kernel supports the Standard Forth-83 word set except for the
Xblocks file word set which are not used. The kernel is extended with
Xmany of the concepts from modern programming languages. Here is a list
Xof some of the extensions; argument binding and local variables, queue
Xmanagement, low level compiler words, string functions, floating point
Xnumbers, exceptions and multi-tasking. The TILE Forth environment also
Xcontains a set of reusable source files for high level multi-tasking,
Xdata modeling and structuring modules, and a number of programming tools.
X
XTo allow interaction and incremental program development TILE Forth
Xincludes a programming environment as a mode in GNU Emacs. This environ-
Xment helps with program structuring, documentation search, and program
Xdevelopment. Each vocabulary in the kernel and the source library file is
Xdescribed by a manual, documentation and test file. This style of
Xprogramming is emphasized throughout the environment to increase
Xunderstanding and reusability of the library modules. During compilation
XTILE Forth's io-package keeps track for which modules have been loaded
Xso that they are only loaded once even if included by several modules.
X
XWriting a Forth in C gives some possibilities that normally are
Xnot available when performing the same task in assembly. TILE Forth
Xhas been profiled using the available tools under Unix. This information
Xhas been used to optimize the compiler so that it achieves a compilation
Xspeed of over 200.000 lines per minute on my machine (a disk-less SUN
XSPARCstation 1). Currently code is only saved in source form and
Xapplications are typically "compile-and-go".
X
XSo far TILE Forth has been ported and tested at over forty locations
Xwithout any major problems except where C compilers do not allow sub-
Xroutine pointers in data structures.
X
X
X2. EXTENSIONS
X
XWhat is new in the TILE forth? First of all the overall organization
Xof words. To increase portability and understanding of forth code modules
Xvocabularies are used as the primary packaging mechanism. New data types
Xsuch as rational and floating point numbers are implemented in separate
Xvocabularies. The vocabularies act as both a program module and an
Xabstract data type.
X
X2.1 Extendable interpreter
X
XTo allow extension of the literal symbol set (normally only integer
Xnumbers) each vocabulary is allowed to have a literal recognition
Xfunction. This function is executed by the interpreter when the symbol
Xsearch has failed. The literal recognizer for the forth vocabulary is
X"?number". This simple mechanism allows modules such as for rational and
Xfloating point numbers, and integer ranges to extend with their own
Xliteral function.
X
X2.2 Data description
X
XAs the Forth-83 Standard lack tools for description of data structures
XTILE Forth contains a fairly large library of tools for this purpose.
XThese are described more in detail in the next section.
X
X2.3 Argument binding and local variables
X
XWhen writing a forth function with many arguments stack shuffling
Xbecomes a real pain. Argument binding and local variables is a nice
Xway out of these situations. Also for the new-comer to Forth this
Xgives some support to this at first very cryptic language. Even
Xthe stack function may be rewritten using this mechanism:
X
X : 2drop { a b } ;
X : 2swap { a b c d } c d a b ;
X : fac { n } n 0> if n 1- recurse n * else 1 then ;
X
XThe argument frame is created on top of the parameter stack and is
Xdisposed when functions is exited. This implementations style of
Xreduces the cost of binding as most functions have more arguments
Xthen return values. A minimum number of data elements have to be
Xmove to create and manage the argument frame.
X
X2.4 Exception handling
X
XAnother extension in TILE Forth is exception handling with multiple
Xexception handling code block. The syntactical structure is very
Xclose to that of Ada, i.e., any colon definition may contain an error
Xhandling section. Should an error occur during the execution of the
Xfunction the stack status is restore to the situation at the call
Xof the function and the lastest exception block is executed with the
Xsignal or exception as a parameter;
X
X exception zero-divide ( -- exception)
X
X : div ( x y -- z)
X /
X exception> ( x y signal -- )
X drop zero-divide raise
X ;
X
XError situations may be indicated using an exception raise function.
XLow level errors, such as zero division, are transformed to exceptions
Xin TILE Forth.
X
X2.5 Entry visibility and forward declaration
X
XLast, some of the less significant extension are forward declaration
Xof entries, hidden or private entries, and extra entry modes. Forward
Xdeclaration of entries are automatically bound when the entry is later
Xgiven a definition. Should a binding not exist at run-time an error
Xmessage is given and the computation is aborted.
X
X forward eval ( ... )
X
X : apply ( ... ) ... eval ... ;
X : eval ( ... ) ... apply ... ;
X
XThree new entry modes have been added to the classical forth model
X(immediate). These allow hiding of entries in different situations.
XThe first two marks the last defined word's visibility according to
Xan interpreter state. These two modifiers are called "compilation"
Xand "execution" and are used as "immediate". A word like "if" is
X"compilation immediate" meaning it is visible when compiling and
Xthen always executed.
X
X compiler forth definitions
X
X : if ( -- ) compile (?branch) >mark ; compilation immediate
X
XThe "private" modifier is somewhat different. It concerns the
Xvisibility across vocabularies (modules and types). If a word is
Xmarked as "private" the word is only visible when the vocabulary in
Xwhich it is defined in is "current". This is very close to the concept
Xof hidden in modules and packages in Modula-2 and Ada.
X
X 4 field +name ( entry -- ptr) private
X
XThe above definition will only be visible in the vocabulary it was
Xdefined. The "private" modifier is useful to help isolate implementation
Xdependencies and reduce the name space which also increases compilation
Xspeed.
X
X
X3. SOURCE LIBRARY
X
XThe TILE Forth programming environment contains a number of tools to
Xmake programming in Forth a bit easier. If you have GNU Emacs, TILE
XForth may run in a specialized forth-mode. This mode supports automatic
Xprogram indentation (pretty printing), documentation search, and
Xinteractive and incremental program development, or "edit-compile-test"
Xstyle of program development.
X
XTo aid program development there is also a source code library with
Xmanual pages, documentation (glossary), and test and example code.
XMost of the source code are data modeling tools. In principle, from
Xbit field definition to object oriented structures are available. The
Xsource code library also contains debugging tools for tracing, break-
Xpoint'ing and profiling of programs.
X
XThe first level of data modeling tools are modules for describing;
X1) bit fields, 2) structures (records), 3) aggregates of data
X(vectors, stacks, buffers, etc), and 4) high level data objects
X(lists, sets, etc).
X
XThe next level of tools are some tools for high level syntactic sugar
Xfor multi-tasking concepts (semaphores, channels, etc), finite state
Xmachines (FSM), anonymous code block (blocks), a general top down parser
Xwith backtrack and semantic binding, and a simulation package. The source
Xlibrary will be extended during the coming releases.
X
X
X4. PROGRAMMING STYLE
X
XA source code module has, in general, the following structure; the
Xfirst section includes any modules needed (these are only loaded once).
XSecond follows global definitions for the module. Normally this is
Xa vocabulary for the module. Third comes the search chain to be used
Xthroughout the module. It is important not to change the search order
Xas 1) it becomes difficult for a reader to understand the code, 2)
Xany change in the search chain flushes the internal lookup cache
Xin TILE Forth and reduces compilation speed.
X
X .( Loading the Library...) cr
X
X #include someLibrary.f83
X ...
X
X ( Global data and definitions)
X
X : someGlobalDefinitions ( -- ) ... ;
X
X vocabulary theLibrary
X
X someLibrary ... theLibrary definitions
X
X ( Local data and definitions)
X
X : somePrivateDefinitions ( -- ) ... ; private
X ...
X : someDefinitions ( -- ) ... ;
X
X forth only
X
XTo create lexical levels within the same vocabulary the word "restore"
Xmay be used. It stores the vocabulary pointer to the given entry and
Xthus hides the words defined after this entry. The word "restore" has
Xmuch the same action as "forget" but without putting back the dictionary
Xpointer.
X
X
X5. SOURCE FILES
X
XThe TILE Forth source is broken down into the following files:
X
XREADME
X This short documentation of TILE.
X
XCOPYING
X The GNU General Public License.
X
XINSTALL
X Some help on how to install TILE Forth.
X
XPORTING
X Some help on how to port TILE Forth and typical problems
X
XMakefile
X Allows a number of compilation styles for debugging, profiling,
X sharing etc. New machines and conditional compilation symbols are
X added here.
X
Xsrc
X The C source library with the kernel code and GNU Emacs forth-mode.
X
Xlib
X The Forth-83 source library for data description and management,
X high level tasking, etc.
X
Xtst
X Test file for each Forth-83 source code file and a set of benchmarks.
X
Xman
X Manual pages for the TILE Forth C kernel and Forth-83 source code
X library.
X
Xdoc
X Documentation and glossaries for each source code file and kernel
X vocabularies.
X
Xbin
X Utility commands and the TILE forth compiler/interpreter.
X
X
X
X6. CONFIGURATION
X
XTILE forth is targeted for 32-bit machines and no special aid is
Xavailable to allow it to be compiled for other bit-widths. The
Xconfiguration is maintained by a "make" files.
X
XThis configuration file allows a number of different modes to support
Xtypical program development phases (on C level) such as debugging,
Xprofiling, optimization and packaging. Please see the information in
Xthese files.
X
X
X7. COPYING
X
XThis software is offered as shareware. You may use it freely, but
Xif you do use it and find it useful, you are encouraged to send the
Xauthor a contribution (>= $50) to the following address:
X
X TILE Technology HB
X Stragatan 19
X S-582 67 Linkoping
X SWEDEN
X
XIf you send me a contribution, I will send you manual pages and
Xdocumentation files and will answer questions by mail. Also your
Xname will be put on a distribution list for future releases.
X
XFor further information about copying see the file COPYING and
Xthe headers in the source code files. Commercial usage of the
Xkernel is not allowed without a license from the company above.
X
X
X8. NOTE
X
XDue to the 32-bit implementation in C a number of Forth-83 definitions
Xare not directly confirmed. Below is a short list of words that might
Xgive problems when porting Forth code to this environment:
X
X* The Block Word Set is not supported. Source code is saved as text
X files.
X
X* All stacks and words size are 32-bit. Thus special care must be
X taken with memory allocation and access.
X
X* Lowercase and uppercase are distinguished, and all forth words are
X lowercase.
X
X* A word in TILE is allowed arbitrary length as the name is stored as
X as a null terminated string.
X
X* Input such as "key" performs a read operation to the operating system
X thus will echo the characters.
X
X* Variables should not allocate extra memory. "create" should be used.
X
X* Double number arithmetic functions are not available.
X
XSome major changes have been made to the kernel in this second release.
XTo allow implementation of floating point numbers and increase porting
Xthe kernel is now written in its own extendable typing system. Some
Xextension have been removed such as the casting operator in the
Xinterpreter.
X
X
XACKNOWLEDGMENTS
X
XFirst of all I wish to express my gratitude to Goran Rydqvist for helped
Xme out with the first version of the kernel and who implemented the
Xforth-mode for GNU Emacs.
X
XSecond a special thanks to the beta test group who gave me valuable
Xfeedback. Especially Mitch Bradley, Bob Giovannucci Jr., Moises Lejter,
Xand Brooks David Smith.
X
XLast, I wish to thank the may users that have been in touch after the
Xfirst release and given me many comments and encouragements.
X
XThank you all.
END_OF_README
if test 14371 -ne `wc -c <README`; then
echo shar: \"README\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test ! -d bin ; then
echo shar: Creating directory \"bin\"
mkdir bin
fi
if test -f bin/forthtool -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"bin/forthtool\"
else
echo shar: Extracting \"bin/forthtool\" \(766 characters\)
sed "s/^X//" >bin/forthtool <<'END_OF_bin/forthtool'
X#! /bin/sh
X# NAME
X# forthtool - tile forth interaction tool in sunview
X# SYNOPSIS
X# forthtool [<parameter>...]
X# DESCRIPTION
X# Starts forth in a cmdtool window with TILE Forth icon when closed.
X# Allows cmdtool editing and session file saving. Any parameters
X# are passed on to forth.
X# OPTIONS
X# none
X# FILES
X# .forthicon icon for closed forthtool
X# SEE ALSO
X# tile(1), cmdtool(1), sunview(1)
X# AUTHOR
X# 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# Created on: 01 April 1989
X# Lasted updated: 23 May 1990
X
Xcmdtool -Wl "forthtool - forth" -WL Forth -WI $TILE/bin/forthicon forth $1 $2 $3 $4 $5 $6 $7 $8 $9
X
X
END_OF_bin/forthtool
if test 766 -ne `wc -c <bin/forthtool`; then
echo shar: \"bin/forthtool\" unpacked with wrong size!
fi
chmod +x bin/forthtool
# end of overwriting check
fi
if test -f bin/mkdoc -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"bin/mkdoc\"
else
echo shar: Extracting \"bin/mkdoc\" \(675 characters\)
sed "s/^X//" >bin/mkdoc <<'END_OF_bin/mkdoc'
X#! /bin/sh
X# NAME
X# mkdoc - create documenation file from manual pages
X# SYNOPSIS
X# mkdoc <files>
X# DESCRIPTION
X# Creates documentation (text) files from manual pages.
X# The documentation files are used by help function mode
X# in GNU Emacs (for the tile forth environment).
X# OPTIONS
X# none
X# SEE ALSO
X# nroff(1), tr(1).
X# AUTHOR
X# 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# Created on: 20 June 1990
X# Lasted updated: 20 June 1990
X
Xfor file in $1
Xdo
X nroff -man $file | tr -d "_\010" > $file.doc
Xdone
X
X
END_OF_bin/mkdoc
if test 675 -ne `wc -c <bin/mkdoc`; then
echo shar: \"bin/mkdoc\" unpacked with wrong size!
fi
chmod +x bin/mkdoc
# end of overwriting check
fi
if test -f bin/short -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"bin/short\"
else
echo shar: Extracting \"bin/short\" \(659 characters\)
sed "s/^X//" >bin/short <<'END_OF_bin/short'
X#! /bin/sh
X# NAME
X# short - a short description of available definitions in a tile file
X# SYNOPSIS
X# short <file>
X# DESCRIPTION
X# Gives all the defininition lines in a tile forth source file.
X#
X# OPTIONS
X# none
X# SEE ALSO
X# tile(1), grep(1)
X# AUTHOR
X# 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# Created on: 02 June 1990
X# Lasted updated: 02 June 1990
X
Xif [ "$1" = "" ]
Xthen
X echo "Usage: short file ..."
Xelse
X for file in $1
X do
X echo "Definitions in: $file"
X grep "\-\-" $file
X echo
X done
Xfi
X
END_OF_bin/short
if test 659 -ne `wc -c <bin/short`; then
echo shar: \"bin/short\" unpacked with wrong size!
fi
chmod +x bin/short
# end of overwriting check
fi
if test -f bin/sop -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"bin/sop\"
else
echo shar: Extracting \"bin/sop\" \(619 characters\)
sed "s/^X//" >bin/sop <<'END_OF_bin/sop'
X#! /bin/sh
X#
X# NAME
X# sop - stack operations
X# SYNOPSIS
X# sop files
X# DESCRIPTION
X# Find possible stack optimizations.
X# SEE ALSO
X# grep(1)
X# AUTHOR
X# 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# Created on: 01 March 1990
X# Lasted updated: 02 June 1990
X
Xif [ "$1" = "" ]
Xthen
X echo "Usage: sop file ..."
Xelse
X for file in $1
X do
X echo "Stack optimizations in: $file"
X egrep -n "swap drop | drop drop | rot rot | swap over | over over" $file
X echo
X done
X
Xfi
END_OF_bin/sop
if test 619 -ne `wc -c <bin/sop`; then
echo shar: \"bin/sop\" unpacked with wrong size!
fi
chmod +x bin/sop
# end of overwriting check
fi
if test ! -d doc ; then
echo shar: Creating directory \"doc\"
mkdir doc
fi
if test ! -d lib ; then
echo shar: Creating directory \"lib\"
mkdir lib
fi
if test ! -d man ; then
echo shar: Creating directory \"man\"
mkdir man
fi
if test ! -d man/man1 ; then
echo shar: Creating directory \"man/man1\"
mkdir man/man1
fi
if test ! -d man/man3 ; then
echo shar: Creating directory \"man/man3\"
mkdir man/man3
fi
if test ! -d src ; then
echo shar: Creating directory \"src\"
mkdir src
fi
if test -f src/error.h -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"src/error.h\"
else
echo shar: Extracting \"src/error.h\" \(396 characters\)
sed "s/^X//" >src/error.h <<'END_OF_src/error.h'
X/*
X C BASED FORTH-83 MULTI-TASKING KERNEL ERROR MANAGEMENT DEFINITIONS
X
X Copyright (c) 1989-1990 by Mikael R.K. Patel
X
X*/
X
X
X/* INCLUDE FILES: SETJUMP */
X
X#include <setjmp.h>
X
X
X/* WARM RESTART ENVIRONMENT FOR LONGJMP */
X
Xextern jmp_buf restart;
X
X
X/* EXPORTED FUNCTIONS AND PROCEDURES */
X
XVOID error_initiate();
XVOID error_restart();
XVOID error_fatal();
XVOID error_signal();
XVOID error_finish();
END_OF_src/error.h
if test 396 -ne `wc -c <src/error.h`; then
echo shar: \"src/error.h\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f src/io.h -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"src/io.h\"
else
echo shar: Extracting \"src/io.h\" \(1693 characters\)
sed "s/^X//" >src/io.h <<'END_OF_src/io.h'
X/*
X C BASED FORTH-83 MULTI-TASKING IO MANAGEMENT DEFINITIONS
X
X Copyright (c) 1988-1990 by Mikael R.K. Patel
X
X*/
X
X
X/* INCLUDE FILES: STANDARD INPUT/OUTPUT */
X
X#include <stdio.h>
X
X
X/* STANDARD INPUT AND OUTPUT DESCRIPTORS */
X
X#define STDIN 0
X#define STDOUT 1
X
X
X/* WHITE SPACE DEFINITION, CHARACTER MASK AND DIRECTORY SEPERATOR */
X
X#define ISSPACE(c) ((c) <= ' ')
X#define CMASK 0377
X#define DIRSEPCHAR '/'
X
X
X/* INFILE BUFFER DEFINITION */
X
X#define BUFSIZE 1024
X
Xtypedef struct {
X CSTR fn;
X INT ln;
X INT fd;
X INT bufp;
X INT cc;
X CHAR buf[BUFSIZE];
X} file_buffer, *INFILE_BUFFER;
X
Xextern INFILE_BUFFER io_infstack[];
Xextern INT io_infsp;
X
X
X/* OUTFILE AND ERROR FILE DEFINITION */
X
Xextern FILE *io_outf;
Xextern FILE *io_errf;
X
X
X/* APPEND ORDER FOR IO_PATH */
X
X#define IO_PATH_FIRST 0
X#define IO_PATH_LAST 1
X
X
X/* IO MANAGE ERROR CODES */
X
X#define IO_NO_ERROR 0
X#define IO_EOF -1
X#define IO_PATH_DEFINED -1
X#define IO_FILE_INCLUDED -1
X#define IO_UNKNOWN_FILE -2
X#define IO_UNKNOWN_PATH -2
X#define IO_TOO_MANY_PATHS -3
X#define IO_TOO_MANY_FILES -3
X
X
X/* EXPORTED MACROS, FUNCTIONS, AND PROCEDURES */
X
X#define io_getchar() \
X ((io_infstack[io_infsp] -> bufp < io_infstack[io_infsp] -> cc) ? \
X (long) io_infstack[io_infsp] -> buf[io_infstack[io_infsp] -> bufp++] & CMASK : \
X (long) io_fillbuf())
X
X#define io_eof() (io_infsp == -1)
X#define io_not_eof() (io_infsp > -1)
X
X#define io_source() (io_infstack[io_infsp] -> fn)
X#define io_line() (io_infstack[io_infsp] -> ln)
X#define io_newline() (++io_line())
X
XINT io_path();
XINT io_infile();
XINT io_fillbuf();
X
XVOID io_flush();
X
XVOID io_skip();
XVOID io_scan();
XVOID io_skipspace();
X
XVOID io_initiate();
XVOID io_finish();
END_OF_src/io.h
if test 1693 -ne `wc -c <src/io.h`; then
echo shar: \"src/io.h\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f src/memory.c -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"src/memory.c\"
else
echo shar: Extracting \"src/memory.c\" \(1692 characters\)
sed "s/^X//" >src/memory.c <<'END_OF_src/memory.c'
X/*
X C BASED FORTH-83 MULTI-TASKING KERNEL MEMORY 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@ida.liu.se
X
X Started on: 8 November 1989
X
X Last updated on: 26 June 1990
X
X Dependencies:
X (cc) memory.h, io.h, and kernel.h
X
X Description:
X Handles low level access to memory and dictionary allocation.
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#include "kernel.h"
X#include "io.h"
X#include "memory.h"
X
XVOID memory_initiate(size)
X INT32 size;
X{
X /* Allocate dictionary area and setup dictionary pointer */
X
X dictionary = (PTR32) malloc((unsigned) size);
X if (dictionary == NIL) {
X (VOID) fprintf(io_errf, "memory: cannot allocate dictionary area\n");
X exit(0);
X }
X dp = dictionary;
X}
X
XVOID memory_finish()
X{
X /* Future clean up function for memory management package */
X}
END_OF_src/memory.c
if test 1692 -ne `wc -c <src/memory.c`; then
echo shar: \"src/memory.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f src/memory.h -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"src/memory.h\"
else
echo shar: Extracting \"src/memory.h\" \(311 characters\)
sed "s/^X//" >src/memory.h <<'END_OF_src/memory.h'
X/*
X C BASED FORTH-83 MULTI-TASKING KERNEL MEMORY MANAGEMENT DEFINITIONS
X
X Copyright (c) 1989-1990 by Mikael R.K. Patel
X
X*/
X
X
X/* INCLUDED FILES: SYSTEM MEMORY ALLOCATION */
X
X#ifdef LINT
X#include <malloc.h>
X#endif
X
X/* EXPORTED MACROS, FUNCTIONS, AND PROCEDURES */
X
XVOID memory_initiate();
XVOID memory_finish();
END_OF_src/memory.h
if test 311 -ne `wc -c <src/memory.h`; then
echo shar: \"src/memory.h\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f src/memory.v -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"src/memory.v\"
else
echo shar: Extracting \"src/memory.v\" \(1670 characters\)
sed "s/^X//" >src/memory.v <<'END_OF_src/memory.v'
X/*
X C BASED FORTH-83 MULTI-TASKING KERNEL: MEMORY ALLOCATION
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 Memory allocation extension vocabulary for the multi-tasking
X tile forth 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 domalloc()
X{
X tos.PTR8 = (PTR8) malloc((unsigned) tos.NUM32);
X}
X
XNORMAL_CODE(malloc_entry, forth, "malloc", domalloc);
X
XVOID dorealloc()
X{
X PTR8 m = spop(PTR8);
X
X tos.PTR8 = (PTR8) realloc((char *) m, (unsigned) tos.NUM32);
X}
X
XNORMAL_CODE(realloc_entry, malloc_entry, "realloc", dorealloc);
X
XVOID dofree()
X{
X PTR8 m = spop(PTR8);
X
X free(m);
X}
X
XNORMAL_CODE(free_entry, realloc_entry, "free", dofree);
X
END_OF_src/memory.v
if test 1670 -ne `wc -c <src/memory.v`; then
echo shar: \"src/memory.v\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test ! -d tst ; then
echo shar: Creating directory \"tst\"
mkdir tst
fi
if test -f tst/bitfields.tst -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"tst/bitfields.tst\"
else
echo shar: Extracting \"tst/bitfields.tst\" \(1281 characters\)
sed "s/^X//" >tst/bitfields.tst <<'END_OF_tst/bitfields.tst'
X.( Loading Bit Field test...) cr
X
X#include bitfields.f83
X
Xbitfields
X
X.( 1: Create a demo bit field definition) cr
X
Xbitfield.type STATUS-REG
X bit ERROR
X3 bits ERROR.CODE
X nibble INDEX
X bit INDIRECT
X byte OP.CODE
Xbitfield.end
X
X
X.( 2: Print information about the fields) cr
X
XERROR . . cr
XERROR.CODE . . cr
XINDEX . . cr
XINDIRECT . . cr
XOP.CODE . . cr
X
X
X.( 3: Access some data with the fields) cr
X
Xbinary
X
X10101001000101111 ERROR drop b@ .
X10101001000101111 INDIRECT drop b@ . cr
X
X10101001000101111 ERROR f@ .
X10101001000101111 ERROR.CODE f@ .
X10101001000101111 INDEX f@ .
X10101001000101111 INDIRECT f@ .
X10101001000101111 OP.CODE f@ . cr
X
X10101001000101111 ERROR <f@ .
X10101001000101111 ERROR.CODE <f@ .
X10101001000101111 INDEX <f@ .
X10101001000101111 INDIRECT <f@ .
X10101001000101111 OP.CODE <f@ . cr
X
X
X.( 4: Change bit fields in some data) cr
X
X0 10101001000101111 ERROR drop b! ERROR drop b@ .
X1 10101001000101111 INDIRECT drop b! INDIRECT drop b@ . cr
X
X0 10101001000101111 ERROR f! ERROR f@ .
X101 10101001000101111 ERROR.CODE f! ERROR.CODE f@ .
X1111 10101001000101111 INDEX f! INDEX f@ .
X1 10101001000101111 INDIRECT f! INDIRECT f@ .
X10111111 10101001000101111 OP.CODE f! OP.CODE f@ . cr
X
Xdecimal
X
Xforth only
END_OF_tst/bitfields.tst
if test 1281 -ne `wc -c <tst/bitfields.tst`; then
echo shar: \"tst/bitfields.tst\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f tst/blocks.tst -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"tst/blocks.tst\"
else
echo shar: Extracting \"tst/blocks.tst\" \(876 characters\)
sed "s/^X//" >tst/blocks.tst <<'END_OF_tst/blocks.tst'
X.( Loading Blocks test...) cr
X
X#include blocks.f83
X
Xlocals blocks
X
X.( 1: Define a code block for "nip") cr
X
Xblock[ swap drop ]; constant nip
X
X1 2 nip call . cr
X
X
X.( 2: Define a code block in a colon definition and call it) cr
X
X: foo ( x -- int)
X block[ ( x -- int)
X 5 + 3 *
X ]; call
X;
X
X6 foo . cr
X
X
X.( 3: Make a colon definition return a code block depending on parameter) cr
X
X: fie ( flag -- block[ x -- int])
X if block[ 5 + ]; else block[ 8 + ]; then
X;
X
X5 true fie call . cr
X
X
X.( 4: Show that blocks can return blocks as values) cr
X
X5 false
Xblock[ ( flag -- block)
X if block[ 5 + ]; else block[ 8 + ]; then
X];
Xcall
Xcall . cr
X
X
X.( 5: Define a generalized factorial function block) cr
X
Xblock[ { x y z }
X x 0>
X if x 1- y z y call x *
X else z call then
X]; constant general-fac
X
X: fac ( n -- n! )
X general-fac block[ 1 ]; general-fac call
X;
X
X5 fac . cr
X
Xforth only
X
END_OF_tst/blocks.tst
if test 876 -ne `wc -c <tst/blocks.tst`; then
echo shar: \"tst/blocks.tst\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f tst/bubble-sort.tst -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"tst/bubble-sort.tst\"
else
echo shar: Extracting \"tst/bubble-sort.tst\" \(1236 characters\)
sed "s/^X//" >tst/bubble-sort.tst <<'END_OF_tst/bubble-sort.tst'
X.( Loading Bubble Sort benchmark...) cr
X
X\ A classical benchmark of an O(n**2) algorithm; Bubble 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
Xvariable seed
X
X: initiate-seed ( -- ) 74755 seed ! ;
X: random ( -- n ) seed @ 1309 * 13849 + 65535 and dup seed ! ;
X
X500 constant elements
X
Xalign create list elements cells allot
X
X: initiate-list ( -- )
X list elements cells + list do random i ! cell +loop
X;
X
X: dump-list ( -- )
X list elements cells + list do i @ . cell +loop cr
X;
X
X: verify-list ( -- )
X list elements 1- cells bounds do
X i 2@ > abort" bubble-sort: not sorted"
X cell +loop
X;
X
X: bubble ( -- )
X 1 elements 1 do
X list elements i - cells bounds do
X i 2@ > if i 2@ swap i 2! then
X cell +loop
X loop
X;
X
X: bubble-sort ( -- )
X initiate-seed
X initiate-list
X bubble
X verify-list
X;
X
X: bubble-with-flag
X 1 elements 1 do
X true list elements i - cells bounds do
X i 2@ > if i 2@ swap i 2! drop false then
X cell +loop
X if leave then
X loop
X;
X
X: bubble-sort-with-flag ( -- )
X initiate-seed
X initiate-list
X bubble-with-flag
X verify-list
X;
X
Xforth only
END_OF_tst/bubble-sort.tst
if test 1236 -ne `wc -c <tst/bubble-sort.tst`; then
echo shar: \"tst/bubble-sort.tst\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f tst/byte-sieve.tst -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"tst/byte-sieve.tst\"
else
echo shar: Extracting \"tst/byte-sieve.tst\" \(1055 characters\)
sed "s/^X//" >tst/byte-sieve.tst <<'END_OF_tst/byte-sieve.tst'
X.( Loading Byte Magazine Sieve benckmark...) cr
X
X\ This is the "standard" sieve benchmark as published in Byte Magazine.
X\ The algorithm is wrong in the sense that it gives an incorrect count
X\ of the number of primes. That doesn't affect it's usefulness as a
X\ benchmark.
X\
X\ This benchmark tends to be relatively insensitive to the efficiency
X\ of "nesting" (calling a colon definition), since it is implemented
X\ almost entirely with very low level words, which are code words in
X\ most Forth implementations. This is reasonably fair, however, since
X\ studies have shown that in many Forth programs, code words get
X\ executed on the order of 8 times more frequently than colon
X\ definitions.
X
Xdecimal
X8192 constant size
Xcreate flags size allot
X
X: do-prime ( -- )
X flags size 1 fill
X 0 size 0 do
X flags i + c@
X if i dup + 3 + dup i +
X begin
X dup size <
X while
X 0 over flags + c!
X over +
X repeat
X 2drop 1+
X then
X loop
X 1899 = not abort" prime: wrong result"
X;
X
X: byte-sieve ( -- )
X 10 0 do do-prime loop
X;
X
Xforth only
END_OF_tst/byte-sieve.tst
if test 1055 -ne `wc -c <tst/byte-sieve.tst`; then
echo shar: \"tst/byte-sieve.tst\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f tst/channels.tst -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"tst/channels.tst\"
else
echo shar: Extracting \"tst/channels.tst\" \(1044 characters\)
sed "s/^X//" >tst/channels.tst <<'END_OF_tst/channels.tst'
X.( Loading Channel test...) cr
X
X#include multi-tasking.f83
X
Xstructures multi-tasking
X
X
X.( 1: Channel and functions for wire binding to task functional units)
X
XONE-TO-ONE CHAN binding
X
X: bind ( x -- ) binding receive swap ! ;
X: wire ( x -- ) binding send ;
X: WIRE ( -- ) ONE-TO-ONE CHAN this wire ;
X
X
X.( 2: Use a task and three channels to multiply two numbers) cr
X
X16 16 task.type MULTIPLY
X ptr a
X ptr b
X ptr c
Xtask.body
X a bind b bind c bind
X begin
X a @ receive b @ receive * c @ send
X again
Xtask.end
X
XMULTIPLY m1 WIRE w1 WIRE w2 WIRE w3
X
X: * ( x y -- z) w1 send w2 send w3 receive ;
X
X100 90 * . cr
X
X
X.( 3: Run factorial as a task with two channels using the multiply task) cr
X
X16 16 task.type FACTORIAL
X ptr a
X ptr b
Xtask.body
X a bind b bind
X begin
X 1 a @ receive 1+ 1 do
X i *
X loop
X b @ send
X again
Xtask.end
X
XFACTORIAL f1 WIRE n WIRE n!
X
X: fac ( n -- n!)
X n send
X ." I'm waiting.."
X begin
X n! ?avail not
X while
X ." .."
X 1 delay
X repeat
X ." done" cr
X n! receive
X;
X
X5 fac . cr
X
Xforth only
X
X
END_OF_tst/channels.tst
if test 1044 -ne `wc -c <tst/channels.tst`; then
echo shar: \"tst/channels.tst\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f tst/colburn-sieve.tst -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"tst/colburn-sieve.tst\"
else
echo shar: Extracting \"tst/colburn-sieve.tst\" \(1025 characters\)
sed "s/^X//" >tst/colburn-sieve.tst <<'END_OF_tst/colburn-sieve.tst'
X.( Loading Colburn Sieve benchmark...) cr
X
X\ This is the "Colburn Sieve" as published in a letter to the editor
X\ of Dr. Dobbs' Journal. It is the same algorithm as the first, but
X\ is a better Forth implementation of the algorithm. It uses a
X\ DO .. LOOP in the inner loop instead of BEGIN .. WHILE .. REPEAT
X\ This version is a more fair comparison of Forth in relation to other
X\ languages. For comparisons between different Forth systems, both
X\ versions are widely used. It is necessary to state which version
X\ you are using in order for your benchmark to be useful.
X\
X\ The Colburn Sieve typically runs in about 60% of the time of the
X\ Byte sieve.
X
Xdecimal
X8192 constant size
Xcreate flags size allot
X
X: do-prime ( -- )
X flags size 1 fill
X 0 size 0 do
X flags i + c@
X if 3 i + i + dup i + size <
X if size flags +
X over i + flags + do
X 0 i c! dup
X +loop
X then
X drop 1+
X then
X loop
X 1899 = not abort" prime: wrong result"
X;
X
X: colburn-sieve ( -- )
X 10 0 do do-prime loop
X;
X
Xforth only
END_OF_tst/colburn-sieve.tst
if test 1025 -ne `wc -c <tst/colburn-sieve.tst`; then
echo shar: \"tst/colburn-sieve.tst\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f tst/debugger.tst -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"tst/debugger.tst\"
else
echo shar: Extracting \"tst/debugger.tst\" \(875 characters\)
sed "s/^X//" >tst/debugger.tst <<'END_OF_tst/debugger.tst'
X.( Loading Debugger test...) cr
X
X#include debugger.f83
X
Xdebugger
X
X
X.( 1: Define a debuggable tail-recursive function) cr
X
X: foo ( n -- )
X ?dup if ." foo " 1- tail-recurse else cr then
X;
X
X12 foo
Xtrace foo
X12 foo
X.profile
X
X
X.( 2: Redefine it as a recursive function) cr
X
X: fie ( n -- )
X ?dup if ." fie " 1- recurse else cr then
X;
X
X12 fie
Xtrace fie
X12 fie
X.profile
X
X
X.( 3: Run the break point function) cr
X
X( Only in interactive mode
X
Xbreak foo
X
X10 foo a .s cr
X10 foo c .s cr
X10 foo e r .s cr
X
X)
X
X
X.( 4: Fibonanci number function; recursive and tail recursive) cr
X
X: fib ( n -- m)
X dup 1 > if dup 1- recurse swap 2- recurse + then
X;
X
Xtrace fib
X10 fib . cr
X.profile
X
X: fib-tail ( a b c -- m)
X ?dup if 1- -rot over + swap rot tail-recurse else nip then
X;
X
X: fib-iter ( n -- m)
X 1 0 rot fib-tail
X;
X
Xtrace fib-tail
Xtrace fib-iter
X10 fib-iter . cr
X.profile
X
Xforth only
X
X
END_OF_tst/debugger.tst
if test 875 -ne `wc -c <tst/debugger.tst`; then
echo shar: \"tst/debugger.tst\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f tst/double.tst -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"tst/double.tst\"
else
echo shar: Extracting \"tst/double.tst\" \(305 characters\)
sed "s/^X//" >tst/double.tst <<'END_OF_tst/double.tst'
X.( Loading Double Parameter test...) cr
X
X#include double.f83
X
X1 2 3 4 .s cr
X2swap .s cr
X2over .s cr
X2drop .s cr
X2dup .s cr
X2drop .s cr
X5 6 .s cr
X2rot .s cr
X
XDOUBLE x .s cr
X
Xx .double cr
Xx 2@ .s cr
X2drop .s cr
Xx 2! .s cr
Xx .double cr
X2drop .s cr
Xx 2@ .s cr
X2drop .s cr
X
X10 42 double y
Xy .s cr
X
Xforth only
END_OF_tst/double.tst
if test 305 -ne `wc -c <tst/double.tst`; then
echo shar: \"tst/double.tst\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f tst/enumerates.tst -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"tst/enumerates.tst\"
else
echo shar: Extracting \"tst/enumerates.tst\" \(539 characters\)
sed "s/^X//" >tst/enumerates.tst <<'END_OF_tst/enumerates.tst'
X.( Loading Enumerates test...) cr
X
X#include enumerates.f83
X
Xenumerates
X
X.( 1: Define a set of small numbers as enumerates and check their values) cr
X
Xenum.type SMALL.NUMBERS
X enum ZERO
X enum ONE
X enum TWO
X enum THREE
X enum FOUR
X enum FIVE
Xenum.end
X
XZERO . ONE . TWO . THREE . FOUR . FIVE . cr
X
X
X.( 2: Define a set of operation code and give the values for each enumerate) cr
X
Xenum.type OP.CODES
X 10 >enum LOAD
X 15 >enum STORE
X 17 >enum ADD
X 21 >enum SUB
X 22 >enum MUL
Xenum.end
X
XLOAD . STORE . ADD . SUB . MUL . cr
X
Xforth only
END_OF_tst/enumerates.tst
if test 539 -ne `wc -c <tst/enumerates.tst`; then
echo shar: \"tst/enumerates.tst\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f tst/fibonacci.tst -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"tst/fibonacci.tst\"
else
echo shar: Extracting \"tst/fibonacci.tst\" \(909 characters\)
sed "s/^X//" >tst/fibonacci.tst <<'END_OF_tst/fibonacci.tst'
X.( Loading Fibonacci benchmark...) cr
X
X\ This is a standard benckmark used for interpretive languages such as
X\ Lisp. Compution of fibonacci for 20 in MacLisp interpreter on a
X\ DEC KA10 takes about 3.6 minutes. The Scheme-79 chip was reported
X\ by G.J. Sussman et al. in IEEE COMPUTER, July 1981, to perform
X\ the task in about a minute at 1595 ns clock period and 32K Lisp cells.
X\
X\ The recursive and tail recursive versions in forth. Demonstrates
X\ the power of forth (**4).
X
X: fib ( n -- m)
X dup 1 >
X if dup 1- recurse
X swap 2- recurse +
X then
X;
X
X: recursive-fib ( -- )
X 20 fib 6765 = not abort" recursive-fib: wrong result"
X;
X
X: fib-tail ( a b c -- m)
X ?dup
X if 1- -rot over + swap rot tail-recurse
X else nip then
X;
X
X: fib-iter ( n -- m) 1 0 rot fib-tail ;
X
X: tail-recursive-fib ( -- )
X 1000 0 do
X 20 fib-iter
X 6765 = not abort" tail-recursive-fib: wrong result"
X loop
X;
X
Xforth only
END_OF_tst/fibonacci.tst
if test 909 -ne `wc -c <tst/fibonacci.tst`; then
echo shar: \"tst/fibonacci.tst\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f tst/locals.tst -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"tst/locals.tst\"
else
echo shar: Extracting \"tst/locals.tst\" \(744 characters\)
sed "s/^X//" >tst/locals.tst <<'END_OF_tst/locals.tst'
X.( Loading Locals Test...) cr
X
Xlocals
X
X
X.( 1: Redefinition of the basic stack operations using argument binding) cr
X
X: swap { a b } b a ;
X: dup { a } a a ;
X: drop { a } ;
X: rot { a b c } b c a ;
X
X1 2 .s swap cr
X3 .s dup cr
X .s drop cr
X .s rot cr
X .s cr
Xdrop drop drop
X
X
X.( 2: Recursive factorial function with argument binding) cr
X
X: recursive { n }
X n 0>
X if n 1- recurse n *
X else 1 then
X;
X
X5 recursive . cr
X
X
X.( 3: Tail recursive factorial function) cr
X
X: tail-recursive { n a }
X n 0>
X if n 1- n a * tail-recurse
X else a then
X;
X
X5 1 tail-recursive . cr
X
X
X.( 4: Iterative factorial function with a local variable) cr
X
X: iterative { n | a }
X 1 -> a
X n 1+ 1 do
X i a * -> a
X loop
X a
X;
X
X5 iterative . cr
X
Xforth only
X
END_OF_tst/locals.tst
if test 744 -ne `wc -c <tst/locals.tst`; then
echo shar: \"tst/locals.tst\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f tst/macros.tst -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"tst/macros.tst\"
else
echo shar: Extracting \"tst/macros.tst\" \(696 characters\)
sed "s/^X//" >tst/macros.tst <<'END_OF_tst/macros.tst'
X.( Loading Macro test...) cr
X
X#include macros.f83
X
Xmacros
X
X.( 1: Define "nip" and mark it as a macro definition) cr
X
X: nip ( a b -- b) swap drop ; macro
X
X.macro nip cr
X1 2 nip . cr
X
X: x ( a b -- b) nip ;
X
X1 2 x . cr
X
X
X.( 2: Define "mip" as a double "nip" macro) cr
X
X: mip ( a b c -- c) nip nip ; macro
X
X.macro mip cr
X1 2 3 mip . cr
X
X
X.( 3: Conditional code may also be used as a macro) cr
X
X: ?magic-number ( x -- int) 0> if 42 else -42 then ; macro
X
X.macro ?magic-number cr
X1 ?magic-number . cr
X0 ?magic-number . cr
X
X
X.( 4: Macros in macros work the way they should) cr
X
X: add-magic-number ( x -- int) dup ?magic-number + ; macro
X
X.macro add-magic-number cr
X10 add-magic-number . cr
X
Xforth only
END_OF_tst/macros.tst
if test 696 -ne `wc -c <tst/macros.tst`; then
echo shar: \"tst/macros.tst\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f tst/matrix-mult.tst -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"tst/matrix-mult.tst\"
else
echo shar: Extracting \"tst/matrix-mult.tst\" \(1213 characters\)
sed "s/^X//" >tst/matrix-mult.tst <<'END_OF_tst/matrix-mult.tst'
X.( Loading Matrix Multiplication benchmark...) cr
X
X\ A classical benchmark of an O(n**3) algorithm; Matrix Multiplication
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
Xvariable seed
X
X: initiate-seed ( -- ) 74755 seed ! ;
X: random ( -- n ) seed @ 1309 * 13849 + 65535 and dup seed ! ;
X
X40 constant row-size
Xrow-size cells constant row-byte-size
X
Xrow-size row-size * constant mat-size
Xmat-size cells constant mat-byte-size
X
Xalign create ima mat-byte-size allot
Xalign create imb mat-byte-size allot
Xalign create imr mat-byte-size allot
X
X: initiate-matrix ( m[row-size][row-size] -- )
X mat-byte-size bounds do
X random dup 120 / 120 * - 60 - i !
X cell +loop
X;
X
X: innerproduct ( a[row][*] b[*][column] -- int)
X 0 row-size 0 do
X >r over @ over @ * r> + >r
X cell+ swap row-byte-size + swap
X r>
X loop
X >r 2drop r>
X;
X
X: matrix-mult ( -- )
X initiate-seed
X ima initiate-matrix
X imb initiate-matrix
X imr ima mat-byte-size bounds do
X imb row-byte-size bounds do
X j i innerproduct over ! cell+
X cell +loop
X row-size cells +loop
X drop
X;
X
Xforth only
END_OF_tst/matrix-mult.tst
if test 1213 -ne `wc -c <tst/matrix-mult.tst`; then
echo shar: \"tst/matrix-mult.tst\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f tst/permutations.tst -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"tst/permutations.tst\"
else
echo shar: Extracting \"tst/permutations.tst\" \(1047 characters\)
sed "s/^X//" >tst/permutations.tst <<'END_OF_tst/permutations.tst'
X.( Loading Permutation benchmark...) cr
X
X\ A heavily recursive permutation program written by Denny Brown
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
X: array ( size -- )
X create 1+ cells allot immediate
Xdoes> ( index array -- ptr)
X [compile] literal
X ?compile swap
X ?compile cells
X ?compile +
X;
X
X10 constant permrange
Xalign permrange array permarray
Xvariable pctr
X
X: initialize-array ( -- )
X 8 1 do i 1- i permarray ! loop
X;
X
X: permute ( n -- )
X 1 pctr +!
X dup 1 = not
X if dup 1- dup recurse
X begin
X dup 0>
X while
X over permarray over permarray exchange
X over 1- recurse
X over permarray over permarray exchange
X 1-
X repeat
X drop
X then
X drop
X;
X
X: permutations ( -- )
X 0 pctr !
X 6 1 do
X initialize-array
X 7 permute
X loop
X pctr @ 43300 = not abort" permutations: wrong result"
X;
X
Xforth only
X
END_OF_tst/permutations.tst
if test 1047 -ne `wc -c <tst/permutations.tst`; then
echo shar: \"tst/permutations.tst\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f tst/queues.tst -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"tst/queues.tst\"
else
echo shar: Extracting \"tst/queues.tst\" \(761 characters\)
sed "s/^X//" >tst/queues.tst <<'END_OF_tst/queues.tst'
X.( Loading Queues test...) cr
X
X#include queues.f83
X#include blocks.f83
X
Xblocks queues definitions
X
X: print-queue ( queue -- )
X block[ . ]; map-queue
X;
X
X.( 1: Create a queue and insert some elements) cr
X
XQUEUE foo
Xfoo print-queue
Xfoo ?empty-queue .
Xfoo size-queue . cr
X
XQUEUE fie
Xfie foo enqueue
Xfoo print-queue
Xfoo ?empty-queue .
Xfoo size-queue . cr
X
XQUEUE fum
Xfum foo enqueue
Xfoo print-queue
Xfoo ?empty-queue .
Xfoo size-queue . cr
X
X
X.( 2: Print information about all the queue elements) cr
X
Xfoo block[ .queue cr ]; map-queue
X
X
X.( 3: Remove some queue elements) cr
X
Xfie dequeue foo .queue cr
Xfum dequeue foo .queue cr
X
X
X.( 4: Try the member function) cr
X
Xfoo foo ?member-queue .
Xfie foo ?member-queue .
Xfie foo enqueue
Xfie foo ?member-queue . cr
X
Xforth only
X
END_OF_tst/queues.tst
if test 761 -ne `wc -c <tst/queues.tst`; then
echo shar: \"tst/queues.tst\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f tst/ranges.tst -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"tst/ranges.tst\"
else
echo shar: Extracting \"tst/ranges.tst\" \(1330 characters\)
sed "s/^X//" >tst/ranges.tst <<'END_OF_tst/ranges.tst'
X.( Loading Ranges test...) cr
X
X#include ranges.f83
X#include blocks.f83
X
Xblocks ranges
X
X
X.( 1: Create some typical ranges and print them) cr
X
X[1901..2001] range YEAR_NUMBER ( Ranges for time and date)
X[1..12] range MONTH_NUMBER
X[1..31] range DAY_NUMBER
X[1..24] range HOUR_NUMBER
X[1..60] range MINUTE_NUMBER
X[1..60] range SECOND_NUMBER
X
XMONTH_NUMBER . . cr
XYEAR_NUMBER . . cr
XDAY_NUMBER . . cr
X
X
X.( 2: Count number of odd numbers in the ranges) cr
X
X: count-odd-numbers ( from to -- n)
X 0 -rot
X block[ ( count index -- count+1)
X 1 and if 1+ then
X ];
X map-range
X;
X
XYEAR_NUMBER count-odd-numbers .
XMONTH_NUMBER count-odd-numbers .
XDAY_NUMBER count-odd-numbers . cr
X
X
X.( 3: Test membership function) cr
X
X3 YEAR_NUMBER ?member-range .
X3 MONTH_NUMBER ?member-range .
X3 DAY_NUMBER ?member-range . cr
X
X
X.( 4: Conditional iteration; print a sub-range) cr
X
X: 3dup ( x y z -- x y z x y z)
X >r 2dup r@ -rot r>
X;
X
X: .sub.range ( upper from to -- )
X 3dup ?member-range
X if block[ dup . over = ]; ?map-range
X else
X 2drop
X then
X drop
X;
X
X4 DAY_NUMBER .sub.range cr
X
X
X.( 5: Union and intersections of ranges) cr
X
XDAY_NUMBER YEAR_NUMBER ?intersection-range . cr
XDAY_NUMBER MONTH_NUMBER intersection-range block[ . ]; map-range cr
XDAY_NUMBER MONTH_NUMBER union-range block[ . ]; map-range cr
X
Xforth only
X
X
END_OF_tst/ranges.tst
if test 1330 -ne `wc -c <tst/ranges.tst`; then
echo shar: \"tst/ranges.tst\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f tst/rationals.tst -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"tst/rationals.tst\"
else
echo shar: Extracting \"tst/rationals.tst\" \(1362 characters\)
sed "s/^X//" >tst/rationals.tst <<'END_OF_tst/rationals.tst'
X.( Loading Rational number test...) cr
X
X#include rationals.f83
X
Xrationals
X
X
X.( 1: Management of undefined values and infinity) cr
X
X1/1 undefined r+ undefined ?r= .
X1/1 undefined r- undefined ?r= .
X1/1 undefined r* undefined ?r= .
X1/1 undefined r/ undefined ?r= .
Xcr
X1/1 infinity r+ infinity ?r= .
X1/1 infinity r- -infinity ?r= .
X1/1 infinity r* infinity ?r= .
X1/1 infinity r/ zero ?r= .
Xcr
X1/1 -infinity r+ -infinity ?r= .
X1/1 -infinity r- infinity ?r= .
X1/1 -infinity r* -infinity ?r= .
X1/1 -infinity r/ zero ?r= .
Xcr
Xinfinity infinity r+ infinity ?r= .
Xinfinity infinity r- undefined ?r= .
Xinfinity infinity r* infinity ?r= .
Xinfinity infinity r/ undefined ?r= .
Xcr
Xinfinity -infinity r+ undefined ?r= .
Xinfinity -infinity r- infinity ?r= .
Xinfinity -infinity r* -infinity ?r= .
Xinfinity -infinity r/ undefined ?r= .
Xcr
X
X
X.( 2: Literal and constant rational number) cr
X
X12/2387 rational y
X
Xy r. cr
Xy 1/r r. cr
Xy y r+ r. cr
Xy y r- r. cr
Xy y r* r. cr
Xy y r/ r. cr
Xy r>i . cr
X
X
X.( 3: Literal rational number in code) cr
X
X: x ( -- x y)
X -115/38
X;
X
Xx r. cr
Xx 1/r r. cr
Xx y r+ r. cr
Xx y r- r. cr
Xx y r* r. cr
Xx y r/ r. cr
Xx r>i . cr
X
X
X.( 4: Relational functions on rational numbers) cr
X
Xx x ?r= . cr
Xx y ?r= . cr
Xx y ?r> . cr
Xx y ?r< . cr
X
X
X.( 5: A rational variable) cr
X
XRATIONAL z
X
X-10/90 20/13 r+ z 2!
Xz 2@ r. cr
Xx z 2@ r/ r. cr
Xy z 2@ r* r. cr
X
Xforth only
END_OF_tst/rationals.tst
if test 1362 -ne `wc -c <tst/rationals.tst`; then
echo shar: \"tst/rationals.tst\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f tst/rendezvous.tst -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"tst/rendezvous.tst\"
else
echo shar: Extracting \"tst/rendezvous.tst\" \(1028 characters\)
sed "s/^X//" >tst/rendezvous.tst <<'END_OF_tst/rendezvous.tst'
X.( Loading Rendezvous test...) cr
X
X#include multi-tasking.f83
X
Xmulti-tasking
X
X.( 1: A simple server task that performs the service one-plus) cr
X
XRENDEZVOUS service ( n -- m)
X
X16 16 task.type SERVER
Xtask.body
X begin
X accept service ( arg -- res)
X 1+
X accept.end
X again
Xtask.end
X
XSERVER aServer
X
X
X.( 2: A multiple read buffer with services put and get) cr
X
XRENDEZVOUS put ( n -- nil)
XRENDEZVOUS get ( nil -- n)
X
X16 16 task.type BUFFER
X long item
Xtask.body
X accept put ( item -- nil)
X item ! nil
X accept.end
X begin
X ?awaiting put if
X accept put ( item -- nil)
X item ! nil
X accept.end
X then
X ?awaiting get if
X accept get ( nil -- item)
X drop item @
X accept.end
X then
X detach
X again
Xtask.end
X
XBUFFER aBuffer
X
X
X.( 3: A demon task which feed the two other tasks with calls) cr
X
X16 16 task.type DEMON
Xtask.body
X begin
X nil get service put drop
X again
Xtask.end
X
XDEMON aDemon
X
X
X.( 4: Initiate the buffer and run the scenario) cr
X
X0 put drop 10000 delay 0 get . cr
X
Xforth only
END_OF_tst/rendezvous.tst
if test 1028 -ne `wc -c <tst/rendezvous.tst`; then
echo shar: \"tst/rendezvous.tst\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f tst/semaphores.tst -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"tst/semaphores.tst\"
else
echo shar: Extracting \"tst/semaphores.tst\" \(776 characters\)
sed "s/^X//" >tst/semaphores.tst <<'END_OF_tst/semaphores.tst'
X.( Loading Multi-tasking test...) cr
X
X#include multi-tasking.f83
X
X.( *** start of multi-tasking demo ***) cr
X
Xmulti-tasking
X
X0 SEMAPHORE synch
X
X16 16 task.type TASK-1
Xtask.body
X ." ** t1 waiting **" cr
X synch wait
X ." ** t1 terminated **" cr
Xtask.end
X
X.( ** t1 scheduled **) cr
XTASK-1 t1
Xwho cr
Xt1 .task
X
X16 16 task.type TASK-2
Xtask.body
X 20 0 do
X 100 delay who cr
X loop
X ." ** t2 terminated **" cr
Xtask.end
X
X.( ** t2 scheduled **) cr
XTASK-2 t2
Xwho cr
Xt2 .task
X
X16 16 task.type TASK-3
Xtask.body
X 1000 delay
X ." ** t3 signaling ** " cr
X synch signal
X ." ** t3 waiting for t2 **" cr
X t2 join who cr
X ." ** t3 terminated **" cr
Xtask.end
X
X.( ** t3 scheduled **) cr
XTASK-3 t3
Xwho cr
Xt3 .task
X
X.( ** main waiting for t3 **) cr
Xwho cr
Xt3 join
Xwho cr
X
X
Xforth only
X
END_OF_tst/semaphores.tst
if test 776 -ne `wc -c <tst/semaphores.tst`; then
echo shar: \"tst/semaphores.tst\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f tst/sets.tst -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"tst/sets.tst\"
else
echo shar: Extracting \"tst/sets.tst\" \(1233 characters\)
sed "s/^X//" >tst/sets.tst <<'END_OF_tst/sets.tst'
X#include blocks.f83
X#include sets.f83
X
Xsets blocks
X
X.( 1: Set elements return pointers to the entry) cr
X
X: element ( -- )
X create last ,
Xdoes> ( element -- entry)
X @
X;
X
X
X.( 2: A print function for element sets) cr
X
X: print-set ( set -- )
X dup .set ." elements: "
X ." { "
X block[ .name space ]; map-set
X ." } "
X;
X
X.( 3: A simple destructive copying function for sets) cr
X
X: copy-set ( set1 set2 -- set2)
X dup empty-set union-set
X;
X
X
X.( 4: Color elements and some sets for calculations) cr
X
Xelement white
Xelement black
X
Xelement blue
Xelement red
Xelement yellow
X
Xelement green
Xelement brown
Xelement violet
X
X10 SET colors
X
X{ yellow red blue } constant primary
X{ green brown violet } constant secondary
X
X
X.( 5: The set of sets and a print print function) cr
X
X{ colors primary secondary } constant the-sets
X
X: print-the-sets ( -- )
X the-sets block[ execute print-set cr ]; map-set
X;
X
X
X.( 6: Testing the symbol set management) cr
X
Xprint-the-sets cr
X
Xyellow colors append-set colors print-set cr
Xsecondary colors copy-set print-set cr
Xbrown colors remove-set colors print-set cr
Xprimary colors union-set print-set cr
Xblue colors remove-set colors print-set cr
X{ brown blue yellow } colors intersection-set print-set cr
X
Xforth only
END_OF_tst/sets.tst
if test 1233 -ne `wc -c <tst/sets.tst`; then
echo shar: \"tst/sets.tst\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f tst/structures.tst -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"tst/structures.tst\"
else
echo shar: Extracting \"tst/structures.tst\" \(1289 characters\)
sed "s/^X//" >tst/structures.tst <<'END_OF_tst/structures.tst'
X.( Loading Structure Test...) cr
X
X#include structures.f83
X
Xstructures
X
X.( 1: Print size of primitive fields) cr
X
Xsizeof byte .
Xsizeof word .
Xsizeof ptr .
Xsizeof long .
Xsizeof enum .
Xcr
X
X
X.( 2: Allocate some data) cr
Xhere . new word . here . cr
X
X
X.( 3: Define a list structures) cr
X
Xstruct.type LIST
X ptr +next
Xstruct.init ( self -- )
X nil swap +next !
Xstruct.end
X
Xsizeof LIST . new LIST dup . +next @ . cr
X
X
X.( 4: Define a double linked list) cr
X
Xstruct.type QUEUE
X struct LIST +succ
X struct LIST +pred
Xstruct.init ( flag self -- )
X swap
X if dup over +succ !
X dup +pred !
X else
X dup +succ as LIST initiate
X +pred as LIST initiate
X then
Xstruct.end
X
Xsizeof QUEUE . cr
Xtrue new QUEUE dup . dup +succ +next @ . +pred +next @ . cr
Xfalse new QUEUE dup . dup +succ +next @ . +pred +next @ . cr
X
X
X.( 5: Define a block using double linked list and instance function) cr
X
Xstruct.type BLOCK
X struct QUEUE +queue
X long +size
Xstruct.init ( size flag self -- )
X tuck +queue as QUEUE initiate
X over allot +size !
Xstruct.does ( self -- ptr)
X sizeof BLOCK +
Xstruct.end
X
X: block ( ptr -- block) sizeof BLOCK - ;
X: size ( ptr -- size) block +size @ sizeof BLOCK + ;
X
Xsizeof BLOCK .
Xhere 1000 true BLOCK x here swap - .
Xx .
Xx block .
Xx block +size @ .
Xx size . cr
X
Xforth only
X
END_OF_tst/structures.tst
if test 1289 -ne `wc -c <tst/structures.tst`; then
echo shar: \"tst/structures.tst\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f tst/towers-of-hanoi.tst -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"tst/towers-of-hanoi.tst\"
else
echo shar: Extracting \"tst/towers-of-hanoi.tst\" \(972 characters\)
sed "s/^X//" >tst/towers-of-hanoi.tst <<'END_OF_tst/towers-of-hanoi.tst'
X.( Loading Towers of Hanoi benchmark...) cr
X
X\ The classical Towers of Hanoi benchmark
X\
X\ From W.P. Salman, O. Tisserand and B. Toulout, FORTH, Macmillan
X\ pp. 120-121
X
Xvariable moves
X
X: copy ( x y z -- x y z x y z)
X >r 2dup r@ -rot r>
X;
X
X: dispose ( x y z -- )
X 2drop drop
X;
X
X: edit ( d a n -- d a n)
X copy drop swap ." From: " . ." to: " . cr
X;
X
X: prepare-call ( d a n -- d a n d i n-1)
X copy -rot over + 6 swap - rot 1-
X;
X
X: prepare-return ( d a n -- d a n i a n-1)
X copy swap rot over + 6 swap - swap rot 1-
X;
X
X: verify-hanoi ( departure arrival number -- )
X dup
X if prepare-call recurse
X edit
X prepare-return recurse
X then
X dispose
X;
X
X: verify-towers-of-hanoi ( -- )
X 1 3 4 verify-hanoi
X;
X
X: hanoi ( departure arrival number -- )
X dup
X if prepare-call recurse
X 1 moves +!
X prepare-return recurse
X then
X dispose
X;
X
X: towers-of-hanoi ( -- )
X 0 moves !
X 1 3 14 hanoi
X moves @ 16383 = not abort" towers-of-hanoi: wrong result"
X;
X
Xforth only
END_OF_tst/towers-of-hanoi.tst
if test 972 -ne `wc -c <tst/towers-of-hanoi.tst`; then
echo shar: \"tst/towers-of-hanoi.tst\" unpacked with wrong size!
fi
# end of overwriting check
fi
echo shar: End of archive 1 \(of 6\).
cp /dev/null ark1isdone
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