mip@massormetrix.ida.liu.se (Mikael Patel) (12/19/89)
#! /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 7)."
# Contents: Makefile doc/bitfields.doc doc/blocks.doc
# doc/enumerates.doc doc/exceptions.doc doc/macros.doc
# doc/queues.doc doc/ranges.doc doc/string.doc src/bitfields.f83
# src/forth.f83 src/macros.f83 src/queues.f83 src/ranges.f83
# src/structures.f83 tst/tree-sort.tst
# Wrapped by mip@massormetrix on Mon Dec 18 18:40:09 1989
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f Makefile -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"Makefile\"
else
echo shar: Extracting \"Makefile\" \(2958 characters\)
sed "s/^X//" >Makefile <<'END_OF_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,
X# benchmarks, and distribution.
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# kit
X# Pack the available source, test and documentation files
X# SEE ALSO
X# make(1), cc(1), touch(1), dbx(1), grof(1), lint(1), time(1), makekit(1)
X# AUTHOR
X# Copyright (c) 1989, 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#
X
X# Source and object files
XSRC = kernel.c kernel.h io.c io.h error.c error.h memory.c memory.h forth.c
XOBJS = kernel.o io.o error.o memory.o
X
X# Machines and separate compilation directives
X# Vanilla Compiler might not understand void
X# LIBS =
X# CFLAGS = -Dvoid=int
X
X# Template for your machine dependencies and libraries
X# LIBS = -lyourlibrary
X# CFLAGS = -youroption -DYOURMACHINE
X
X
Xforth: $(OBJS) forth.o
X $(CC) $(CFLAGS) -o $@ $(OBJS) forth.o $(LIBS)
X
X
X# Object code dependencies
Xforth.o: kernel.h io.h error.h memory.h
X
Xkernel.o: kernel.h io.h error.h memory.h
X
Xmemory.o: kernel.h memory.h
X
Xerror.o: kernel.h io.h error.h memory.h
X
Xio.o: io.h error.h memory.h
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 src/*.f83 -s bye
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
X
X# Packs the available source and documentation for mailing
Xkit:
X makekit -s57k -ntile.kit. \
X COPYING README PORTING RELEASES tile.1 \
X Makefile $(SRC) forth.el forthtool .forthicon \
X src src/* doc doc/* tst tst/* \
X > tile.kit.00
X mv tile.kit.* shar
END_OF_Makefile
if test 2958 -ne `wc -c <Makefile`; then
echo shar: \"Makefile\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f doc/bitfields.doc -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"doc/bitfields.doc\"
else
echo shar: Extracting \"doc/bitfields.doc\" \(3878 characters\)
sed "s/^X//" >doc/bitfields.doc <<'END_OF_doc/bitfields.doc'
XBITFIELDS(2) BIT FIELD MANIPULATION FUNCTIONS BITFIELDS(2)
X
XNAME
X bitfields - manipulation of bit fields
X
XSYNOPSIS
X #include bitfields.f83
X
X bitfields ( -- )
X
X +pos ( bits -- pos) private
X +width ( bits -- width) private
X
X field ( width -- ) private
X
X bitfield.type ( -- )
X bit ( -- )
X bits ( width -- )
X nibble ( -- )
X byte ( -- )
X word ( -- )
X bitfield.end ( -- )
X
X .field ( field -- )
X
X mask ( width -- mask) private
X get ( x field -- y)
X put ( x y field -- z)
X
XDESCRIPTION
X Allows definition and manipulation of bit fields. The bit field
X is described in a syntax similar to a structure with fields
X from least significant bit towards most significant bit.
X
Xbitfields ( -- )
X Vocabulary for bit field definitions.
X
X+pos ( bits -- pos) private
X Access field for address of pos(ition) in a named bit field. The
X position is stored as a long number.
X
X+width ( bits -- width) private
X Access field name to address the width of a named bit field. The
X width is stored as a long number.
X
Xbitfield.type ( -- )
X Used as:
X bitfield.type <bitfield-type-name>
X <bitfield-layout>
X bitfield.end
X and then
X bitfield.type <instance-name>
X Starts the definition of a bit field layout. The bits within
X the bit field are numbered from 0 to 31 starting from right (lsb)
X to left (msb).
X
Xbits ( width -- )
X Used within a bit field type definitions to give an access name
X to a number of bits with in a long number. Used as:
X <width> bits <bitfield-name>
X within a bit field type definition.
X
Xfield ( width -- ) private
X Utility function to create additional constant bit field type
X names, other than "bit" etc.
X
Xbit ( -- ) private
X Used as:
X bit <bitfield-name>
X within a bit field type definition to give name to a bit at the
X current position. The bit positions are numbered from 0 to 31
X and right to left within a long number.
X
Xnibble ( -- )
X Used as:
X nibble <bitfield-name>
X within a bit field type definition to give name to a nibble,
X four bits.
X
Xbyte ( -- )
X Used as:
X byte <bitfield-name>
X within a bit field type definition to give name to a byte,
X eight bits.
X
Xword ( -- )
X Used as:
X word <bitfield-name>
X within a bit field type definition to give name to a word,
X sixteen bits.
X
Xbitfield.end ( -- )
X Ends the definition of a bit field type. Will give a warning
X message if the last field position exceeded 32 bits.
X
X.field ( field -- )
X Prints information about a field; position and width.
X
Xmask ( width -- mask) private
X Utility function to create a mask of a given width.
X
Xget ( x field -- y)
X Given a bit field name, "field", and a long value, "x", the bit
X field is accessed and return.
X
Xput ( x y field -- z)
X Given a new value, "x", of a field name, "field", the value "y" is
X is updated and returned. The new value is masked to fit the field.
X
XSEE ALSO
X forth(1)
X
XCOPYING
X Copyright (C) 1989 Mikael R.K. Patel
X Permission is granted to make and distribute verbatim copies
X of this manual provided the copyright notice and this permission
X notice are preserved on all copies.
X Permission is granted to copy and distribute modified versions
X of this manual under the conditions for verbatim copying,
X provided also that the section entitled "GNU General Public
X License" is included exactly as in the original, and provided
X that the entire resulting derived work is distributed under
X the terms of a permission notice identical to this one.
X Permission is granted to copy and distribute translations of
X this manual into another language, under the above conditions
X for modified versions, except that the section entitled "GNU
X General Public License" may be included in a translation approved
X by the author instead of in the original English.
X
XAUTHOR
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
END_OF_doc/bitfields.doc
if test 3878 -ne `wc -c <doc/bitfields.doc`; then
echo shar: \"doc/bitfields.doc\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f doc/blocks.doc -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"doc/blocks.doc\"
else
echo shar: Extracting \"doc/blocks.doc\" \(2304 characters\)
sed "s/^X//" >doc/blocks.doc <<'END_OF_doc/blocks.doc'
XBLOCKS(2) LITERAL CODE BLOCK FUNCTIONS BLOCKS(2)
X
XNAME
X blocks - definition and execution of code blocks
X
XSYNOPSIS
X #include blocks.f83
X
X blocks ( -- )
X
X +block ( addr1 -- addr2) private
X
X block[ ( -- ) immediate
X ]; ( -- block ) immediate
X
X call ( block -- )
X
XDESCRIPTION
X Allows definition and execution of code blocks. An alternative
X to passing functions as arguments.
X
X+block ( addr1 -- addr2) private
X Field access variable to calculate the offset for in-line block
X literals in colon definitions.
X
Xblock[ ( -- ) immediate
X Used in the following form:
X block[ <block-definition> ];
X Start the definition of a code block. Compiles a code block until
X "];" and returns the address to the code block. The code block
X may be executed using "call". Code block may contain definitions
X of other code blocks. A code block should not contain "does>" or
X "exception>" as these require a vocabulary entry.
X
X]; ( -- block) immediate
X Marks the end of a code block. Returns a pointer to the code block.
X
Xcall ( block -- )
X Executes a code block. Any parameters used by the code block are
X passed as usual on the parameter stack. Return values are handled
X in the same manner.
X
XSEE ALSO
X forth(1), compiler(1)
X
XCOPYING
X Copyright (C) 1989 Mikael R.K. Patel
X Permission is granted to make and distribute verbatim copies
X of this manual provided the copyright notice and this permission
X notice are preserved on all copies.
X Permission is granted to copy and distribute modified versions
X of this manual under the conditions for verbatim copying,
X provided also that the section entitled "GNU General Public
X License" is included exactly as in the original, and provided
X that the entire resulting derived work is distributed under
X the terms of a permission notice identical to this one.
X Permission is granted to copy and distribute translations of
X this manual into another language, under the above conditions
X for modified versions, except that the section entitled "GNU
X General Public License" may be included in a translation approved
X by the author instead of in the original English.
X
XAUTHOR
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
END_OF_doc/blocks.doc
if test 2304 -ne `wc -c <doc/blocks.doc`; then
echo shar: \"doc/blocks.doc\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f doc/enumerates.doc -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"doc/enumerates.doc\"
else
echo shar: Extracting \"doc/enumerates.doc\" \(2314 characters\)
sed "s/^X//" >doc/enumerates.doc <<'END_OF_doc/enumerates.doc'
XENUMERATES(2) ENUMERATES DEFINITION FUNCTIONS ENUMERATES(2)
X
XNAME
X enumerates - enumerate variable definitions
X
XSYNOPSIS
X #include enumerates.f83
X
X enumerates ( -- )
X
X enum.type ( -- )
X enum.null ( -- )
X enum ( -- )
X >enum ( value -- )
X enum.end ( -- )
X
XDESCRIPTION
X Allows definition of enumerate variable sets.
X
Xenumerates ( -- )
X Vocabulary for enumerate definitions.
X
Xenum.type ( -- )
X Used in the following structure:
X enum.type <enum-type-name>
X <enum-items>
X enum.end
X to start the definition of an enumerate variable and identifiers.
X The items start with the value zero. The type may later be used
X to define variables:
X <enum-type-name> <enum-variable-name>
X The variable corresponds to a normal, long, variable.
X
Xenum.null ( -- )
X Used within an "enum.type" definition to advance the item
X identification number without defining an item.
X
Xenum ( -- )
X Used within an "enum.type" definition to declare an enumerate.
X enum <enum-item-name>
X The value of the items are zero and upwards.
X
X>enum ( value -- )
X Used within an "enum.type" definition to declare an enumerate
X symbol with a given value.
X <enum-item-value> >enum <enum-item-name>
X
Xenum.end ( -- )
X Ends a "enum.type" definition.
X
XSEE ALSO
X forth(1)
X
XCOPYING
X Copyright (C) 1989 Mikael R.K. Patel
X Permission is granted to make and distribute verbatim copies
X of this manual provided the copyright notice and this permission
X notice are preserved on all copies.
X Permission is granted to copy and distribute modified versions
X of this manual under the conditions for verbatim copying,
X provided also that the section entitled "GNU General Public
X License" is included exactly as in the original, and provided
X that the entire resulting derived work is distributed under
X the terms of a permission notice identical to this one.
X Permission is granted to copy and distribute translations of
X this manual into another language, under the above conditions
X for modified versions, except that the section entitled "GNU
X General Public License" may be included in a translation approved
X by the author instead of in the original English.
X
XAUTHOR
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
END_OF_doc/enumerates.doc
if test 2314 -ne `wc -c <doc/enumerates.doc`; then
echo shar: \"doc/enumerates.doc\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f doc/exceptions.doc -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"doc/exceptions.doc\"
else
echo shar: Extracting \"doc/exceptions.doc\" \(3687 characters\)
sed "s/^X//" >doc/exceptions.doc <<'END_OF_doc/exceptions.doc'
XEXCEPTIONS(1) KERNEL EXCEPTIONS FUNCTIONS EXCEPTIONS(1)
X
XNAME
X exceptions - kernel exceptions definitions
X
XSYNOPSIS
X exceptions ( -- )
X
X exception ( --- )
X exception> ( [signal] or [exception] -- ) compilation immediate
X raise ( [signal] or [exception] -- )
X
X (exception;) ( -- ) compilation
X (exceptionunlink;) ( -- ) compilation
X (exception>) ( -- ) compilation
X
XDESCRIPTION
X Kernel support word set for exception definition and management.
X Exceptions may be signaled by the environment (such as arithmetic
X errors or memory segmentation error) or raised by functions in
X an application.
X
Xexceptions ( -- )
X Vocabulary containing the exception management definitions.
X Allows definitions of forth level capturing of errors. Uses
X a syntax similar Ada to make the beginning of an exception
X section within a colon definition.
X
Xexception ( --- )
X Used in the form:
X exception <exception-name>
X To define an exception symbol. An exception may be raised using:
X <exception-name> raise
X The defined exception returns a pointer to itself when used.
X
X(exception;) ( -- ) compilation
X Compiled by "exception>" to end a code definition block and
X unlink the current exception frame.
X
X(exceptionunlink;) ( -- ) compilation
X Compiled by "exception>" to end a code definition block with
X an argument frame and local variables. Unlinks the exception
X frame and the argument frame.
X
X(exception>) ( -- ) compilation
X Compiled by "exception>" to handle the run-time activity
X of building an exception frame and jumping to the beginning
X of the definition.
X
Xexception> ( [signal] or [exception] -- ) compilation immediate
X Used within a colon definition to mark the beginning of the
X exception part of the definition:
X : <name> .... exception> ( exception -- ) .... ;
X If an error occurs or an exception is raised during the
X execution of the definition part the control is past to the
X exception block and the signal number or the exception is
X past as a parameter. The status of the stacks are restore to
X the situation before the execution of the most recent definition
X with an exception block. To pass the exception upwards the
X function "raise" should be used.
X
Xraise ( [signal] or [exception] -- )
X Activates a exceptions handler with signal identification number
X or an exception symbol. If an exception frame exists the virtual
X machine is restored to the state and resumed. The default action
X taken if no exception block is available is abort with a message
X about the task, and the name of the signal or exception. Signals
X are generated from the run-time environment.
X
XSEE ALSO
X forth(1)
X
XCOPYING
X Copyright (C) 1989 Mikael R.K. Patel
X Permission is granted to make and distribute verbatim copies
X of this manual provided the copyright notice and this permission
X notice are preserved on all copies.
X Permission is granted to copy and distribute modified versions
X of this manual under the conditions for verbatim copying,
X provided also that the section entitled "GNU General Public
X License" is included exactly as in the original, and provided
X that the entire resulting derived work is distributed under
X the terms of a permission notice identical to this one.
X Permission is granted to copy and distribute translations of
X this manual into another language, under the above conditions
X for modified versions, except that the section entitled "GNU
X General Public License" may be included in a translation approved
X by the author instead of in the original English.
X
XAUTHOR
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
END_OF_doc/exceptions.doc
if test 3687 -ne `wc -c <doc/exceptions.doc`; then
echo shar: \"doc/exceptions.doc\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f doc/macros.doc -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"doc/macros.doc\"
else
echo shar: Extracting \"doc/macros.doc\" \(2600 characters\)
sed "s/^X//" >doc/macros.doc <<'END_OF_doc/macros.doc'
XMACROS(3) MACRO DEFINITION FUNCTIONS MACROS(3)
X
XNAME
X macros - macro definitions
X
XSYNOPSIS
X #include macros.f83
X
X macros ( -- )
X
X MACRO ( body size -- ) private
X +body ( macro -- body) private
X +size ( macro -- size) private
X
X [macro] ( macro -- ) private
X
X macro ( -- )
X
X .macro ( -- )
X
XDESCRIPTION
X Allows definition of macro colon definitions to reduce the
X overhead of call at run-time.
X
Xmacros ( -- )
X Vocabulary containing the macro definitions.
X
XMACRO ( body size -- ) private
X Structure definition used by "macro" to keep information about
X a macro code definition.
X
X+body ( macro -- body) private
X Access field to pointer to code section of macro code.
X Stored as a ptr.
X
X+size ( macro -- size) private
X Access field to byte size of macro code.
X Stored as a long.
X
X[macro] ( macro -- ) private
X Run-time manager of macro definitions. If compilation state
X the macro body is expanded into the current definition other-
X wise the macro body is called.
X
Xmacro ( -- )
X Used to mark a definition as a macro.
X : <macro-name> <macro-definition> ; macro
X Used in the same way as "immediate". The code section is not
X restricted to sequential code only, control structures are
X allowed as all branches are relative. Special care should be
X taken if the macro definition is recursive as the result is
X unpredictable.
X
X.macro ( -- )
X Used in the form:
X .macro <macro-name>
X to print internal information about the macro definition.
X Use mainly for debugging purposes.
X
XSEE ALSO
X forth(1), forth(2)
X
XCOPYING
X Copyright (C) 1989 Mikael R.K. Patel
X Permission is granted to make and distribute verbatim copies
X of this manual provided the copyright notice and this permission
X notice are preserved on all copies.
X Permission is granted to copy and distribute modified versions
X of this manual under the conditions for verbatim copying,
X provided also that the section entitled "GNU General Public
X License" is included exactly as in the original, and provided
X that the entire resulting derived work is distributed under
X the terms of a permission notice identical to this one.
X Permission is granted to copy and distribute translations of
X this manual into another language, under the above conditions
X for modified versions, except that the section entitled "GNU
X General Public License" may be included in a translation approved
X by the author instead of in the original English.
X
XAUTHOR
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
END_OF_doc/macros.doc
if test 2600 -ne `wc -c <doc/macros.doc`; then
echo shar: \"doc/macros.doc\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f doc/queues.doc -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"doc/queues.doc\"
else
echo shar: Extracting \"doc/queues.doc\" \(3834 characters\)
sed "s/^X//" >doc/queues.doc <<'END_OF_doc/queues.doc'
XQUEUES(2) QUEUES FUNCTIONS QUEUES(2)
X
XNAME
X queues - double linked list definitions
X
XSYNOPSIS
X #include queues.f83
X
X queues ( -- )
X
X QUEUE ( -- )
X +succ ( queue -- succ) private
X +pred ( queue -- pred) private
X
X succ ( queue -- succ)
X pred ( queue -- pred)
X
X ?empty ( queue -- boolean)
X into ( item queue -- )
X out ( item -- )
X
X empty ( queue -- )
X length ( queue -- length)
X ?member ( item queue -- flag)
X
X map ( queue block[item -- ] -- )
X ?map ( queue block[item -- flag] -- )
X
X print ( queue -- )
X .queue ( queue -- )
X
XDESCRIPTION
X Kernel support word set for double linked circular lists.
X
Xqueues ( -- )
X Vocabulary containing double linked circular list definitions.
X
XQUEUE ( -- )
X Structure definition of double linked list. Used as follows to:
X new QUEUE
X Creates a new queue item. An unnamed instance for a queue header.
X QUEUE <queue-name>
X Creates a named queue item.
X
X+succ ( queue -- succ) private
X Modifiers queue pointer to access successor pointer in queue
X structure. A ptr field name.
X
X+pred ( queue -- pred) private
X Modifiers queue pointer to access predecessor pointer in queue
X structure. A ptr field name.
X
Xsucc ( queue -- succ)
X Returns pointer to successor queue item.
X
Xpred ( queue -- pred)
X Returns pointer to predecessor queue item.
X
X?empty ( queue -- boolean)
X Checks if the queue is empty. Successor pointer points to itself.
X
Xinto ( item queue -- )
X Inserts item into queue as new predecessor element to queue item. If
X the queue parameter is a queue header the item is inserted last
X into the queue.
X
Xout ( item -- )
X Removes an item for any queue. Observe this function does not
X require knowledge about which queue the item is in.
X
Xmap ( queue block[item -- ] -- )
X Used as following in either execution or compilation mode:
X <queue> <block> map
X Performs the parameterized block on each item in the queue.
X
X?map ( queue block[item -- flag] -- )
X Used as following in either execution or compilation mode:
X <queue> <conditional-block> ?map
X Performs the parameterized block on each item in the queue
X until the block returns true.
X
Xprint ( queue -- )
X Prints the address of each item in a queue.
X
Xlength ( queue -- length)
X Returns the length of a queue. The queue head is counted. Returns a
X integer larger than zero.
X
X?member ( item queue -- flag)
X Search for the item in the given queue. If found returns true else
X false. The item may not be nil as this will give an incorrect
X result.
X
X.queue ( queue -- )
X Prints information about a queue.
X
XSEE ALSO
X forth(1), structures(2), blocks(2)
X
XWARNING
X Code written using this word set is not directly portable to
X other forth environments.
X
XBUG
X Pointers are not check. Illegal pointer value will result in
X a possible error situation.
X
XCOPYING
X Copyright (C) 1989 Mikael R.K. Patel
X Permission is granted to make and distribute verbatim copies
X of this manual provided the copyright notice and this permission
X notice are preserved on all copies.
X Permission is granted to copy and distribute modified versions
X of this manual under the conditions for verbatim copying,
X provided also that the section entitled "GNU General Public
X License" is included exactly as in the original, and provided
X that the entire resulting derived work is distributed under
X the terms of a permission notice identical to this one.
X Permission is granted to copy and distribute translations of
X this manual into another language, under the above conditions
X for modified versions, except that the section entitled "GNU
X General Public License" may be included in a translation approved
X by the author instead of in the original English.
X
XAUTHOR
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
END_OF_doc/queues.doc
if test 3834 -ne `wc -c <doc/queues.doc`; then
echo shar: \"doc/queues.doc\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f doc/ranges.doc -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"doc/ranges.doc\"
else
echo shar: Extracting \"doc/ranges.doc\" \(3597 characters\)
sed "s/^X//" >doc/ranges.doc <<'END_OF_doc/ranges.doc'
XRANGES(3) NUMBER RANGES FUNCTIONS RANGES(3)
X
XNAME
X ranges - number intervals definitions and functions
X
XSYNOPSIS
X #include ranges.f83
X
X ranges ( -- )
X
X RANGE ( from to -- )
X +from ( range -- from) private
X +to ( range -- to) private
X
X ?empty ( range -- flag)
X ?member ( value range -- flag)
X ?intersection ( x y -- flag)
X
X length ( range -- length)
X
X union ( x y -- from to)
X intersection ( x y -- from to)
X
X map ( range block[index -- ] -- )
X ?map ( range block[index -- flag] -- )
X
X print ( range -- )
X .range ( range -- )
X
XDESCRIPTION
X Number interval functions. Allows definition and manipulation of
X ranges of numbers.
X
Xranges ( -- )
X Range definitions vocabulary.
X
XRANGE ( from to -- )
X Used in the following form to create a range:
X <from> <to> RANGE <ranges-name>
X The range is a structure type thus structure operations
X are allowed (e.g. sizeof).
X
X+from ( range -- from) private
X Access field of "from" value of a range structure. Stored as a long.
X
X+to ( range -- to) private
X Access field of "to" value of a range structure. Stored as a long.
X
X?empty ( range -- flag)
X Returns true if the "from" and "to" values are equal, i.e., the
X range is empty else false.
X
X?member ( value range -- flag)
X Returns true if the value is within the range else false.
X
X?intersection ( x y -- flag)
X Returns true if there exists an intersection range between
X the ranges "x" and "y" else false.
X
Xlength ( range -- length)
X Returns the length of the range.
X
Xunion ( x y -- from to)
X Given two ranges "x" and "y" returns the "from" and "to" values
X of the union of the ranges.
X
Xintersection ( x y -- from to)
X Given two ranges "x" and "y" returns the "from" and "to" values
X of the intersection of the ranges. If an intersection does not
X exist the value zero is returned for "from" and "to".
X
Xmap ( range block[index -- ] -- )
X Used in the following form:
X <range> <block> map
X Map function on a range. The block is called for each value of
X the range starting with "from" and ending with "to". The block
X receives the index as a parameter.
X
X?map ( range block[index -- flag] -- )
X Used in the following form:
X <range> <conditional-block> ?map
X Conditional map function on a range. The block is called for
X each value of the range starting with "from" and ending with "to"
X while the block returns true. The block receives the index as a
X parameter.
X
Xprint ( range -- )
X Print all range values.
X
X.range ( range -- )
X Prints information about the given range.
X
XSEE ALSO
X forth(1), structures(2), blocks(2)
X
XCOPYING
X Copyright (C) 1989 Mikael R.K. Patel
X Permission is granted to make and distribute verbatim copies
X of this manual provided the copyright notice and this permission
X notice are preserved on all copies.
X Permission is granted to copy and distribute modified versions
X of this manual under the conditions for verbatim copying,
X provided also that the section entitled "GNU General Public
X License" is included exactly as in the original, and provided
X that the entire resulting derived work is distributed under
X the terms of a permission notice identical to this one.
X Permission is granted to copy and distribute translations of
X this manual into another language, under the above conditions
X for modified versions, except that the section entitled "GNU
X General Public License" may be included in a translation approved
X by the author instead of in the original English.
X
XAUTHOR
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
END_OF_doc/ranges.doc
if test 3597 -ne `wc -c <doc/ranges.doc`; then
echo shar: \"doc/ranges.doc\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f doc/string.doc -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"doc/string.doc\"
else
echo shar: Extracting \"doc/string.doc\" \(2653 characters\)
sed "s/^X//" >doc/string.doc <<'END_OF_doc/string.doc'
XSTRING(1) KERNEL STRING FUNCTIONS STRING(1)
X
XNAME
X string - kernel string functions
X
XSYNOPSIS
X string ( -- )
X
X (") ( -- string) compilation
X " ( -- string) immediate
X
X length ( string -- length)
X copy ( string1 -- string2)
X = ( string1 string2 -- flag)
X + ( string1 string2 -- string1)
X print ( string -- )
X
XDESCRIPTION
X Kernel support for manipulation of null terminated strings.
X
Xstring ( -- )
X Vocabulary containing the null-ended string definitions.
X
X(") ( -- string) compilation
X Compiled run-time action for string literal. Pushes a pointer
X to the inline string onto the parameter stack.
X
X" ( -- string) immediate
X String literal compiler. Used in the following form:
X " any string"
X The string is not bounded by any size (except memory).
X
Xlength ( string -- length)
X Returns the length of the string not counting the null
X character ending the string.
X
Xcopy ( string1 -- string2)
X Returns a instance copy of the parameter string. The copy is
X equivalent the the parameter but is allocated to another memory area.
X
X= ( string1 string2 -- flag)
X Compares the two strings and returns true if they are equal
X else false.
X
X+ ( string1 string2 -- string1)
X Appends "string2" to "string1" and returns the pointer to
X "string1". "string1" is assumed to have space for "string2".
X
Xprint ( string -- )
X Prints a string on the current output device.
X
XSEE ALSO
X forth(1)
X
XWARNING
X Code written using this word set is not directly portable to
X other forth environments.
X
XBUG
X Pointers are not check. Illegal pointer value will result in
X a possible error situation.
X
XCOPYING
X Copyright (C) 1989 Mikael R.K. Patel
X Permission is granted to make and distribute verbatim copies
X of this manual provided the copyright notice and this permission
X notice are preserved on all copies.
X Permission is granted to copy and distribute modified versions
X of this manual under the conditions for verbatim copying,
X provided also that the section entitled "GNU General Public
X License" is included exactly as in the original, and provided
X that the entire resulting derived work is distributed under
X the terms of a permission notice identical to this one.
X Permission is granted to copy and distribute translations of
X this manual into another language, under the above conditions
X for modified versions, except that the section entitled "GNU
X General Public License" may be included in a translation approved
X by the author instead of in the original English.
X
XAUTHOR
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
END_OF_doc/string.doc
if test 2653 -ne `wc -c <doc/string.doc`; then
echo shar: \"doc/string.doc\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f src/bitfields.f83 -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"src/bitfields.f83\"
else
echo shar: Extracting \"src/bitfields.f83\" \(2885 characters\)
sed "s/^X//" >src/bitfields.f83 <<'END_OF_src/bitfields.f83'
X\
X\ BIT FIELD MANAGEMENT
X\
X\ Copyright (c) 1989 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: 24 November 1989
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.
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
Xvocabulary bitfields ( Bit field vocabulary)
X
Xbitfields definitions
X
X0 field +pos ( bits -- pos) private
X4 field +width ( bits -- width) private
X
X: bitfield.type ( -- pos0)
X create 0 does> drop variable ; ( Create a bitfield type)
X
X: bits ( pos1 width -- pos2)
X create over , dup , + ; ( Create a named bitfield and adjust)
X
X: field ( width -- )
X create , does> @ bits ; private ( Generate names for bitfields)
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: warning too many fields" ;
X
X: .field ( field -- )
X ." bitfield#" dup . ( Print field address)
X ." pos: " dup +pos @ . ( Print position of field)
X ." width: " +width @ . ; ( Print width of field)
X
X#ifdef f@ ( Check if the kernel supports field access as a primitive)
X
X: get ( x field -- y)
X dup +pos @ swap +width @ f@ ; ( Access field structure and data)
X
X: put ( x y field -- z)
X dup +pos @ swap +width @ f! ; ( Access field structure and modify)
X
X#else ( without field access primitives)
X
X: mask ( width -- mask)
X -1 swap << not ; private ( Create a mask for access)
X
X: get ( x field -- y)
X dup >r +pos @ >> ( Get position and adjust for access)
X r> +width @ mask and ; ( Mask of right part)
X
X: put ( x y field -- z)
X dup >r +width @ mask swap over ( Create a mask for access)
X r@ +pos @ << not and ( Remove field)
X swap rot and ( Mask out part of source)
X r> +pos @ << or ; ( Adjust position and include)
X
X#then
X
Xforth only
X
X
X
END_OF_src/bitfields.f83
if test 2885 -ne `wc -c <src/bitfields.f83`; then
echo shar: \"src/bitfields.f83\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f src/forth.f83 -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"src/forth.f83\"
else
echo shar: Extracting \"src/forth.f83\" \(3957 characters\)
sed "s/^X//" >src/forth.f83 <<'END_OF_src/forth.f83'
X\
X\ FORTH LEVEL SYSTEM DEFINITIONS
X\
X\ Copyright (c) 1989 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 November 1989
X\
X\ Dependencies:
X\ (forth) forth, string, enumerates, bitfields, structures
X\
X\ Description:
X\ High level extensions to the forth kernel. Implementation
X\ dependent sections such as entry and vocabulary structures.
X\
X\ Copying:
X\ This program is free software; you can redistribute it and\or modify
X\ it under the terms of the GNU General Public License as published by
X\ the Free Software Foundation; either version 1, or (at your option)
X\ any later version.
X\
X\ This program is distributed in the hope that it will be useful,
X\ but WITHOUT ANY WARRANTY; without even the implied warranty of
X\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
X\ GNU General Public License for more details.
X\
X\ You should have received a copy of the GNU General Public License
X\ along with this program; see the file COPYING. If not, write to
X\ the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
X
X.( Loading Forth definitions...) cr
X
X( Memory word size and integer range)
X
X32 constant BITS/WORD
X4 constant BYTES/WORD
X
X1 BITS/WORD 1- << constant MIN_INT
XMIN_INT 1- constant MAX_INT
X
X( Entry and vocabulary structures)
X
X#include enumerates.f83
X#include bitfields.f83
X#include structures.f83
X
Xbitfields structures enumerates string forth definitions
X
Xstruct.type ENTRY ( -- )
X ptr +link ( Pointer to previous entry)
X ptr +name ( Pointer to null-ended string)
X long +mode ( Mode bit field)
X long +code ( Code type or pointer to code)
X long +parameter ( Parameter field or pointer to dito)
Xstruct.end
X
Xbitfield.type MODES ( -- )
X bit IMMEDIATE ( Execution always)
X bit EXECUTION ( Execution only)
X bit COMPILITION ( Compilation only)
X bit PRIVATE ( Private only)
X4 bits RESERVED ( Bit fields reserved for future use)
Xbitfield.end ( Bit 8-31 are free for applications)
X
Xenum.type CODES ( -- )
X enum CODE ( Primitive code)
X enum COLON ( Colon definition)
X enum VARIABLE ( Variable)
X enum CONSTANT ( Constant)
X enum VOCABULARY ( Vocabulary)
X enum CREATE ( Created symbol)
X enum USER ( User variable local to task)
X enum LOCAL ( Local frame variable)
X enum FORWARD ( Forward reference)
X enum FIELD ( Field access variable)
X enum EXCEPTION ( Exception variable)
Xenum.end ( Otherwise forth level manager)
X
X: .entry ( entry -- )
X ." entry#" dup . ( Print entry address)
X ." link: " dup +link @ . ( Print link)
X ." name: " dup +name @ print ( Print name)
X ." mode: " dup +mode @ . ( Print mode)
X ." code: " dup +code @ . ( Print code)
X ." parameter: " +parameter @ . ; ( Print parameter field)
X
X: .context ( -- )
X ." context: " context ( Access context vocabulary set)
X begin ( Iterate over all vocabularies)
X dup @ ?dup ( Access vocabulary)
X while
X .name space ( And print vocabulary name)
X sizeof ptr + ( Index the next vocabulary in the set)
X repeat
X drop cr ;
X
X: .current ( -- )
X ." current: " current @ .name cr ; ( Print name of current vocabulary)
X
X: .vocabulary ( -- )
X ." vocabulary: " context ( Access search vocabularies)
X begin
X dup @ ?dup ( Check for last vocabulary)
X while
X +parameter @ ( Access list of entries)
X begin
X ?dup ( For all entries)
X while
X dup +code @ VOCABULARY = ( Check if the entry is a vocabulary)
X if dup .name space then ( Print its name and continue)
X +link @ ( to the next entry)
X repeat
X sizeof ptr + ( Move to the next vocabulary)
X repeat
X drop cr ; ( Drop search list pointer)
X
Xforth only
X
X
END_OF_src/forth.f83
if test 3957 -ne `wc -c <src/forth.f83`; then
echo shar: \"src/forth.f83\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f src/macros.f83 -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"src/macros.f83\"
else
echo shar: Extracting \"src/macros.f83\" \(2422 characters\)
sed "s/^X//" >src/macros.f83 <<'END_OF_src/macros.f83'
X\
X\ MACRO DEFINITIONS
X\
X\ Copyright (c) 1989 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: 29 November 1989
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 forth.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 swap over +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 ; 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: .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
Xforth only
X
END_OF_src/macros.f83
if test 2422 -ne `wc -c <src/macros.f83`; then
echo shar: \"src/macros.f83\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f src/queues.f83 -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"src/queues.f83\"
else
echo shar: Extracting \"src/queues.f83\" \(3814 characters\)
sed "s/^X//" >src/queues.f83 <<'END_OF_src/queues.f83'
X\
X\ DOUBLE LINKED LISTS
X\
X\ Copyright (c) 1989 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: 29 November 1989
X\
X\ Dependencies:
X\ (forth) structures, blocks
X\
X\ Description:
X\ Allows definition and basic manipulation of queue data structures.
X\
X\ Copying:
X\ This program is free software; you can redistribute it and\or modify
X\ it under the terms of the GNU General Public License as published by
X\ the Free Software Foundation; either version 1, or (at your option)
X\ any later version.
X\
X\ This program is distributed in the hope that it will be useful,
X\ but WITHOUT ANY WARRANTY; without even the implied warranty of
X\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
X\ GNU General Public License for more details.
X\
X\ You should have received a copy of the GNU General Public License
X\ along with this program; see the file COPYING. If not, write to
X\ the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
X
X.( Loading Queue definitions... ) cr
X
X#include structures.f83
X#include blocks.f83
X
Xblocks structures queues definitions
X
Xstruct.type QUEUE ( -- )
X ptr +succ private ( Pointer to successor)
X ptr +pred private ( Pointer to predessor)
Xstruct.init ( queue -- )
X dup over +succ ! ( Initiate as an empty queue)
X dup +pred !
Xstruct.end
X
X: succ ( queue -- succ)
X +succ @ ; ( Access successor item)
X
X: pred ( queue -- pred)
X +pred @ ; ( Access predecessor item)
X
X#ifundef ?empty ( Check if the kernel supports queues)
X
X: ?empty ( queue -- boolean)
X dup +succ @ = ; ( Pointer to itself)
X
X: into ( item queue -- )
X over over +pred @ swap +pred ! ( item.pred = queue.pred)
X over over swap +succ ! ( item.succ = queue)
X over over +pred @ +succ ! ( queue.pred.succ = item)
X +pred ! ; ( queue.pred = item)
X
X: out ( item -- )
X dup +succ @ over +pred ! ( item.pred = item.succ)
X dup +pred @ swap +succ ! ; ( item.succ = item.pred)
X
X#then
X
X: empty ( queue -- )
X dup over +succ ! ( Initiate as an empty queue)
X dup +pred ! ;
X
X: map ( queue block[item -- ] -- )
X over >r ( Save pointer to queue header)
X begin
X over +succ @ >r ( Save pointer to next item)
X dup >r ( Save block on return stack)
X call ( Call the block with the item)
X r> r> swap over ( Restore the parameters)
X r@ = ( Check if end of queue)
X until
X r> drop drop drop ; ( Drop all temporary parameters)
X
X: ?map ( queue block[item -- flag] -- )
X over >r ( Save pointer to queue header)
X begin
X over +succ @ >r ( Save pointer to next item)
X dup >r ( Save block on return stack)
X call ( Call the block with the item)
X if r> drop r> drop r> drop ( Drop all saved parameters )
X exit ( and exit the mapping function)
X then
X r> r> swap over ( Restore the parameters)
X r@ = ( Check if end of queue)
X until
X r> drop drop drop ; ( Drop all temporary parameters)
X
X: print ( queue -- )
X block[ . ]; map ; ( Print address of each queue item)
X
X: length ( queue -- length )
X 0 swap block[ drop 1+ ]; map ; ( Map increment for each queue item)
X
X: ?member ( item queue -- flag)
X block[ ( item0 item -- [item0 false] or [false true])
X over = ( Check if this item is the searched)
X if drop false true ( Drop the item and return false)
X else false then ( Try the next item)
X ]; ?map boolean not ; ( Map the block over the items)
X
X: .queue ( queue -- )
X ." queue#" dup . ( Print address of queue)
X ." succ: " dup +succ @ . ( Print successor)
X ." pred: " +pred @ . ; ( Print predessor)
X
Xforth only
END_OF_src/queues.f83
if test 3814 -ne `wc -c <src/queues.f83`; then
echo shar: \"src/queues.f83\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f src/ranges.f83 -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"src/ranges.f83\"
else
echo shar: Extracting \"src/ranges.f83\" \(3380 characters\)
sed "s/^X//" >src/ranges.f83 <<'END_OF_src/ranges.f83'
X\
X\ RANGE DEFINITIONS
X\
X\ Copyright (c) 1989 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: 17 December 1989
X\
X\ Dependencies:
X\ (forth) structures, blocks
X\
X\ Description:
X\ Allows definition of intervals and basic functions from these.
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 structures.f83
X#include blocks.f83
X
Xvocabulary ranges
X
Xblocks structures ranges definitions
X
Xstruct.type RANGE ( from to -- )
X long +from private ( From value of range)
X long +to private ( To value of range)
Xstruct.init ( from to range -- )
X swap over +to ! +from ! ( Initiate range; to and from values)
Xstruct.end
X
X: ?empty ( range -- flag)
X dup +from @ swap +to @ = ; ( Check the to- and from-value)
X
X: ?member ( value range -- boolean)
X dup +from @ swap +to @ ?within ; ( Check if the value is within range)
X
X: ?intersection ( x y -- flag)
X over +to @ over +from @ < >r ( Check the relationship between)
X +to @ swap +from @ < r> or not ; ( the to- and from-values)
X
X: length ( range -- length)
X dup ?empty ( Check if empty)
X if drop 0 ( Then return zero)
X else
X dup +to @ swap +from @ - 1+ ( Else calculate size of range)
X then ;
X
X: union ( x y -- from to)
X over +to @ over +to @ max >r ( Take max of the to-values)
X +from @ swap +from @ min r> ; ( And min of the from-values)
X
X: intersection ( x y -- from to)
X over over ?intersection ( Check if there exists an intersection)
X if over +to @ over +to @ min >r ( Then take min of the to-values)
X +from @ swap +from @ max r> ( And max of the from-values)
X else
X drop drop 0 0 ( Else return an empty range)
X then ;
X
X: map ( range block[index -- ] -- )
X swap dup +to @ 1+ swap +from @ ( Access range intervals; to and from)
X do ( Loop and call the block)
X i swap dup >r call r> ( on each value in the interval)
X loop
X drop ; ( Drop function)
X
X: ?map ( range block[index -- flag] -- )
X swap dup +to @ 1+ swap +from @ ( Access range intervals; to and from)
X do ( Loop and call the block)
X i swap dup >r call r> swap ( on each value in the interval)
X if leave then ( Leave the iteration if return is true)
X loop
X drop ; ( Drop function)
X
X: print ( range -- )
X block[ . ]; map ; ( Print each index in range)
X
X: .range ( range -- )
X ." range#" dup . ( Print address of range structure )
X ." from: " dup +from @ . ( Print range intervals )
X ." to: " +to @ . ;
X
Xforth only
X
END_OF_src/ranges.f83
if test 3380 -ne `wc -c <src/ranges.f83`; then
echo shar: \"src/ranges.f83\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f src/structures.f83 -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"src/structures.f83\"
else
echo shar: Extracting \"src/structures.f83\" \(3485 characters\)
sed "s/^X//" >src/structures.f83 <<'END_OF_src/structures.f83'
X\
X\ STRUCTURE DEFINITIONS
X\
X\ Copyright (c) 1989 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 November 1989
X\
X\ Dependencies:
X\ (forth) none
X\
X\ Description:
X\ Allows aggregates of data to be described as structures.
X\
X\ Copying:
X\ This program is free software; you can redistribute it and\or modify
X\ it under the terms of the GNU General Public License as published by
X\ the Free Software Foundation; either version 1, or (at your option)
X\ any later version.
X\
X\ This program is distributed in the hope that it will be useful,
X\ but WITHOUT ANY WARRANTY; without even the implied warranty of
X\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
X\ GNU General Public License for more details.
X\
X\ You should have received a copy of the GNU General Public License
X\ along with this program; see the file COPYING. If not, write to
X\ the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
X
X.( Loading Structure definitions...) cr
X
Xvocabulary structures
X
Xstructures definitions
X
X0 field +size ( struct -- size) private
X4 field +initiate ( struct -- initiate) private
X
X: as ( -- struct)
X ' >body ( Quote next symbol and access body)
X [compile] literal ; immediate ( If compiling generate a literal)
X
X: this ( -- ptr)
X last >body ; ( Access the body of the last symbol)
X
X: initiate ( ptr struct -- )
X +initiate @ ?dup ( Access initiate. code pointer)
X if >r else drop then ; ( If available perform initialization)
X
X: make ( struct -- ptr)
X here dup >r ( Save pointer to instance)
X over +size @ allot ( Access size and allocate memory)
X swap initiate r> ; ( Perform initialization)
X
X: new ( -- ptr)
X [compile] as ( Take the next symbol, "as")
X ?compile make ; immediate ( And "make" an instance)
X
X: sizeof ( -- size)
X ' >body +size @ ( Access size of structure)
X [compile] literal ; immediate ( And make literal if compiling)
X
X: assign ( a b -- )
X [compile] sizeof ( Access size and assign instance)
X ?compile cmove ; immediate
X
X: struct.type ( -- struct offset0)
X create here 0 0 , 0 , ( Allocate initial struct information)
X does> create make drop ; ( Create a new instance)
X
X: bytes ( offset1 n -- offset2)
X over field + ; ( Create an access field of "n" bytes)
X
X: align ( offset1 -- offset2)
X dup 1 and + ; ( Align field offset to even address)
X
X: field ( bytes -- )
X create , nil , ( Create a predefined field type)
X does> @ bytes ; private ( At run-time create field names)
X
X: struct ( -- )
X [compile] sizeof bytes ; ( Create a structure sized field name)
X
X( Initial set of field names)
X1 field byte ( -- )
X2 field word ( -- )
X4 field long ( -- )
X4 field ptr ( -- )
X4 field enum ( -- )
X
X: struct.init ( struct offset3 -- )
X align over +size ! ( Assign size of structure type)
X here swap +initiate ! ] ; ( And pointer to initialization code)
X
X: struct.does ( -- )
X [compile] does> ( Do what does-does)
X; immediate compilation
X
X: struct.end ( [] or [struct offset3] -- )
X compiling ( Check compilation status)
X if [compile] ; ( If compiling then end definition)
X else swap +size ! then ; immediate ( Else assign size of structure type)
X
Xforth only
X
END_OF_src/structures.f83
if test 3485 -ne `wc -c <src/structures.f83`; then
echo shar: \"src/structures.f83\" 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\" \(2759 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
X4 constant cell
X
X: cells ( n -- m) cell * ;
X: align ( -- ) here cell 1- and allot ;
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
X here 0 , 0
X does> ( structure -- size)
X @ ;
X
X: struct: ( offset1 size --- offset2)
X create
X over , +
X does> ( structure field -- field-addr)
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: insert-node ( n t -- )
X over over .val @ >
X if dup .left @ nil =
X if over over .left create-node
X else over over .left @ recurse then
X else over over .val @ <
X if dup .right @ nil =
X if over over .right create-node
X else over over .right @ recurse then
X then
X then
X drop drop ;
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: 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: 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 forth only
X
X
END_OF_tst/tree-sort.tst
if test 2759 -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 7\).
cp /dev/null ark2isdone
MISSING=""
for I in 1 2 3 4 5 6 7 ; do
if test ! -f ark${I}isdone ; then
MISSING="${MISSING} ${I}"
fi
done
if test "${MISSING}" = "" ; then
echo You have unpacked all 7 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