lwt1@aplvax.UUCP (06/08/84)
Here is part 1 of the source for FORTH for the PDP-11.
Delete everything thru the "-- cut here --" line, and extract with 'sh':
sh part1 part2 ... part7
where 'part?' are whatever you've named the files. Note the copyright
notice at the end of README. Please let us know how things go. While
we can't support this software, we'll be posting bug fixes/upgrades to
net.sources as time permits.
VAX-FORTH should be 'forth'-coming {yuk-yuk} within a couple of weeks.
Have fun!
-Lloyd W. Taylor
... seismo!umcp-cs!aplvax!lwt1
---I will have had been there before, soon---
---------------------------------- cut here ----------------------------------
echo x - README
cat >README <<'+E+O+F'
.TL
Unix-FORTH for the PDP-11
.AU
John R. Hayes
.AI
Applied Physics Lab
Johns Hopkins University
.ND
.PP
.bp
.PP
.UL Introduction.
FORTH running under unix is now available. Typing 'forth'
from the terminal will invoke a FORTH process for you. This memo describes
the unix specific features of this version of FORTH and how to boot the system.
The last section of
this document deals entirely with unix-FORTH I/O programming.
.PP
Unix-FORTH is a subset of FORTH-83. The only place that unix-FORTH
and FORTH-83 diverge is in the implementation of I/O. It seems natural
that a unix FORTH should take advantage of unix's elegant I/O structure
even at the cost of standardization. Therefore, unix-FORTH is a process
that reads commands from its standard input and sends results to its standard
output. If the standard input is the user's terminal, an interactive FORTH
session results. Or a file of batch commands can be attached to the
standard input and executed non-interactively.
.PP
A programmer used to typical FORTH systems will immediately note the
absence of FORTH screens. FORTH screens are inadequate for managing
anything but the smallest programs and arbitrarily constrain software
modules to be sixteen lines long. Unix-FORTH uses the unix file system and
programs are created with any text editor. Therefore, the entire unix
toolbox is available for operation on FORTH source files. Unix-FORTH
provides a set of I/O words that are very similar to their unix system-call
counterparts. The user can have up to fifteen (system dependent) files
open simultaneously.
This, along with unix-FORTH's I/O implementation, allow the use of nested
loads.
.PP
A number of other enhancements are available to the user of unix-FORTH.
Any program resident in the unix file system can be executed from within
FORTH. For example, to list the files in your current directory on the line
printer, you would type:
.DS L
" ls | lpr" SYSTEM
.DE
A new subshell can be spawned
without disturbing your current FORTH environment by typing SHELL. Typing
a ^C will cause FORTH to execute its warm start code. This allows you
to terminate a program run amok without killing FORTH. ^D (eof) will
terminate the FORTH process.
.PP
.UL Bootstrapping.
Booting FORTH consists of two steps. First, assemble the bootstrap system
with the command:
.DS L
as -o bootforth prim.as os.as
.DE
This will generate a FORTH subset system adequate for metacompiling the actual
system. One potential problem with this step is the use of the PDP-11 extended
instruction set operations DIV and MUL. If your machine lacks these
instructions, you will have to code them yourself. Bootforth is an executable
object file of a small FORTH system. You might want to test it before going
on.
.PP
The second step consists of using bootforth to metacompile the actual system.
Type:
.DS L
bootforth <auto | tee map
.DE
auto is a file containing forth commands to control the metacompilation.
map will contain a memory map of the system useful for debugging. The new
system will be called newforth. A good test of the new system is to see if
it can metacompile itself.
.PP
Three more possible portability problems exist. The first is in the a.out
format used. Our version of unix uses:
.DS L
struct exec { /* a.out header */
int a_magic; /* magic number */
unsigned a_text; /* size of text segment */
unsigned a_data; /* size of initialized data */
unsigned a_bss; /* size of unitialized data */
unsigned a_syms; /* size of symbol table */
unsigned a_entry; /* entry point */
unsigned a_unused; /* not used */
unsigned a_flag; /* relocation info stripped */
};
#define A_MAGIC1 0407 /* normal */
#define A_MAGIC2 0410 /* read-only text */
#define A_MAGIC3 0411 /* separated I&D */
#define A_MAGIC4 0412 /* mapped read-only text */
.DE
This information is embedded in META1. The second problem is in the number
of open files per process allowed by the operating system. The FILEPOS table
is SYS:ASM must have as many entries as open files allowed by your version
of Unix. There are currently fifteen entries in this table. The final problem
could be in the implementation of system calls. Our Venix system (similar to
Unix version 7) implements system calls as TRAP instructions and returns an
error flag in the C bit of the condition codes. If your system behaves
differently, the comments should help you to modify the code appropriately.
.PP
.UL I/O.
The following paragraphs review low-level unix I/O programming. Some
previous knowledge is assumed, so you may want to read the low-level I/O
section in "Unix Programming". Refer to the glossary for an exact description
of how any word behaves.
.PP
Most I/O words use a file descriptor as a parameter instead of the name of
the file. A file descriptor is a small non-negative integer that indexs a
unix internal file table. File descriptors are not the same as the file
pointers used in the C standard I/O library. The FORTH word READ is typical
in its use of a file descriptor. The input parameters to READ are the file
descriptor of the file to be read, the address of a receiving buffer, and
the number of bytes to read. READ returns the actual number of bytes read.
If this is less than the requested number, EOF was encountered or an error
occurred. The action of WRITE is similar. All files are accessed sequentially
unless an explicit SEEK command is issued. The parameters to SEEK are a file
descriptor and a double word file position.
.PP
The OPEN word is used to associate a file name with a file descriptor. The
parameters to OPEN are the address of a file name text string and a file
mode. The string must be null terminated instead of a standard FORTH
counted string. Unix-FORTH provides some useful words for handling null
terminated strings. These are described below. The file mode can be
0=read-only, 1=write-only, and 2=read-write. OPEN either returns a file
descriptor that will be used for accessing the file or returns a -1 indicating
an error of some sort. Since there are a finite number of file descriptors
per process, the programmer should CLOSE unneeded files to free
file descriptors. The parameter to CLOSE is a file descriptor.
.PP
To create a new file, the CREAT word is available. The parameters are the
address of a file name text string and a protection mode bit mask. The file
is created and opened for writing. If the file already exists, its length is
truncated to zero. CREAT returns either a file descriptor or a -1 indicating
an error.
.PP
When the FORTH process is started, three files with file descriptors 0, 1,
and 2 have already been opened. These correspond to the standard input,
standard output, and standard error. FORTH expects commands from the standard
input and types results to the standard output. The standard error file is
not used by FORTH. Two CONSTANTS, STDIN and STDOUT with values 0 and 1
respectively are pre-defined in unix-FORTH.
.PP
Unix-FORTH has two words, FEXPECT and FQUERY for line oriented input.
FEXPECT's parameters are a file descriptor, the address of a receive buffer,
and the number of characters to read. FEXPECT reads the requested number of
characters unless a newline or an EOF is encountered and returns the number
of characters actually read. FEXPECT also converts tabs to blanks.
FQUERY is like FEXPECT expect that FQUERY reads up to 120 characters into
TIB, the FORTH text input buffer.
.PP
All FORTH system output goes through the FORTH-83 standard word TYPE. To
allow FORTH to control redirection of its output, TYPE sends its output
to each file in a table of four file descriptors. Two words, OUTPUT and
SILENT, are used to edit the table. Both words use a single file descriptor
as a parameter. OUTPUT will add the file descriptor to the table if the
table is not already full. SILENT will remove all instances of its file
descriptor from the table. As an experiment, try typing:
.DS L
STDOUT OUTPUT
.DE
.PP
The word FLOAD is used to load FORTH source code. It's single parameter
is the address of a null terminated string describing the path name of
the desired FORTH file. There are two words in unix-FORTH for converting
strings in the input stream into null terminated strings. The word " reads
the input stream until a second " is found, moves the string to PAD placing
a null at the end, and returns the address of PAD. The word "" is a
compiling version of " to be used inside colon definitions. The address
of the null terminated string isn't put on the stack until run-time.
Both " and "" are defined in terms of the word STRING. STRING converts
a counted string to a null terminated string without modifying the counted
string.
.PP
Unix-FORTH maintains a 512 byte block of memory used for buffering the most
recently used read file. Writing to a file is unbuffered by unix-FORTH.
Due to the read buffering the unix-FORTH file position and the unix maintained
file position can become inconsistent. This is never a problem with read-only
or write-only files. However, this can cause loss of data in read-write
files unless the following simple rule is followed with read-write files.
Always use a SEEK call when switching from reading to writing or from writing
to reading.
.bp
.DS L
Copyright 1984 by The Johns Hopkins University/Applied Physics Lab.
Free non-commercial distribution is *encouraged*, provided that:
1. This copyright notice is included in any distribution, and
2. You let us know that you're using it.
Please notify:
Lloyd W. Taylor
JHU/Applied Physics Lab
Johns Hopkins Road
Laurel, MD 20707
(301) 953-5000
Usenet: ... seismo!umcp-cs!aplvax!lwt1
Unix-FORTH was developed under NASA contract NAS5-27000 for the
Hopkins Ultraviolet Telescope, a March 1986 Space Shuttle mission. (we
hope to take a peek at Halley's comet!)
Written entirely by Wizard-In-Residence John R. Hayes.
* Unix is a trademark of Bell Labs.
.DE
+E+O+F
echo x - forth.1h
cat >forth.1h <<'+E+O+F'
.TH FORTH 1H
.SH NAME
forth
\- invoke a forth process.
.SH SYNOPSIS
forth
.SH DESCRIPTION
Forth invokes a FORTH-language process. The process reads commands from the
standard input and sends results to the standard output. If the standard
input is a terminal, an interactive forth session results. This is a subset
of FORTH-83 diverging only in the I/O.
This utility was developed independently from any UNIX or VENIX source code.
.SH "SEE ALSO"
Unix-FORTH for the TEGSE, TCE-T84-34
.SH AUTHORS
J. Hayes
+E+O+F
echo x - format.c
cat >format.c <<'+E+O+F'
/*
* Use:
* format [-l num] [-t file] [file file ... ]
*
* This program formats records of arbitrary size and pretty-prints
* them. Records are delimited by '\'. A title is printed on each
* page and the records are separated by a line of dashes. Records
* are prevented from spanning page boundaries. The -l flag is used
* to specify the number of lines per page of your output device.
* The default is 63. The -t flag is used to specify a file that
* contains a title that is to be printed on the top of each page.
*/
#include <stdio.h>
#define MAXLINES 15
#define LINELENGTH 120
char title[10*LINELENGTH]=""; /* default: not title */
int titlelen=0;
int linesppage=63; /* default: 63 lines per page */
main(argc,argv)
int argc;
char *argv[];
{
char *s;
FILE *fp;
while (--argc>0 && **++argv=='-')
switch (*(*argv+1)){
case 't':
argc--; argv++;
if ((fp=fopen(*argv,"r"))!=NULL){
s=title;
while (fgets(s,LINELENGTH,fp)!=NULL){
s+=strlen(s);
titlelen++;
}
fclose(fp);
}
else fprintf(stderr,
"format: can't open %s\n",*argv);
break;
case 'l':
argc--; argv++;
if (sscanf(*argv,"%d",&linesppage)==0)
fprintf(stderr,
"format: %s isn't a number\n",*argv);
break;
default:
fprintf(stderr,
"format: bad flag %c\n",*(*argv+1));
break;
}
if (argc>0)
while (argc-- > 0){
if ((fp=fopen(*argv,"r"))!=NULL){
format(fp);
fclose(fp);
}
else
fprintf(stderr,
"format: can't open %s\n",*argv);
argv++;
}
else
format(stdin);
}
format(input)
FILE *input;
{
char buf[MAXLINES*LINELENGTH];
char *bufp=buf;
int nextline=0;
while(fgets(bufp,LINELENGTH,input)!=NULL){
if(*bufp!='\\'){
nextline++;
bufp+=strlen(bufp);
}
else {
*bufp='\0';
printrec(buf,nextline);
bufp=buf;
nextline=0;
}
}
}
printrec(lines,nlines)
char *lines;
int nlines;
{
static int linect=1000; /* absurd number forces
title on first page */
int i;
if (nlines+1 > linesppage-linect){
printf("\f%s",title);
linect=titlelen;
}
for (i=1; i<80; i++) putchar('-');
printf("\n%s",lines);
linect+=nlines+1;
}
+E+O+Flwt1@aplvax.UUCP (06/08/84)
Here is part 2 of the source for FORTH for the PDP-11.
Delete everything thru the "-- cut here --" line, and extract with 'sh':
sh part1 part2 ... part7
where 'part?' are whatever you've named the files. Note the copyright
notice at the end of README. Please let us know how things go. While
we can't support this software, we'll be posting bug fixes/upgrades to
net.sources as time permits.
VAX-FORTH should be 'forth'-coming {yuk-yuk} within a couple of weeks.
Have fun!
-Lloyd W. Taylor
... seismo!umcp-cs!aplvax!lwt1
---I will have had been there before, soon---
---------------------------------- cut here ----------------------------------
echo x - glossary
cat >glossary <<'+E+O+F'
! n addr -
n is stored at addr.
\
!SP n -
Parameter stack pointer is set to n.
\
" - addr[string]
Generates a null-terminated string. Used in the form:
" string"
Copies the input stream to PAD until a second " is found, places a null at
the end of the string, and returns the address of the string.
\
"" - addr[string]
Compiling word. Generates a null-terminated string at run time. Used as:
"" string"
Adds a counted string copied from the input stream to the dictionary. At
run-time, converts the string to a null-terminated string and returns address
of string.
\
# d1l d1h d2l d2h
The remainder of d1 divided by the value of BASE is converted to an
ASCII character and appended to the pictured output string growing toward
lower memory addresses. d2 is the quotient and is maintained for further
processing. Typically used between <# and #>.
\
#> dl dh addr +n
Pictured numeric output conversion is ended dropping d. addr is the
address of the resulting output string and +n is the length of the string.
\
#S dl dh 0 0
d is converted appending each resultant character onto the pictured
numeric output string until the quotient is zero. A single zero is added
to the output string if d is zero. Typically used between <# and #>.
\
' - cfa
Used in the form:
' <name>
cfa is the compilation address of <name>. A zero is returned if <name>
could not be found in the dictionary.
\
(FIND) addr[name] addr[dict] 0 <or> nfa
Searches the vocabulary whose latest dictionary entry nfa is pointed to
by addr[dict] for the counted string pointed to by addr[name]. Returns
the nfa of the word if found, otherwise a zero is returned. If addr[dict]
is zero, indicating an empty vocabulary, a zero is returned.
\
(LITERAL) - word
Pushes the word pointed to by the IAR onto the parameter stack and adds two
to the IAR.
\
* w1 w2 w3
w3 is the least-significant 16 bits of the arithmetic product of w1 times
w2.
\
*/ n1 n2 n3 quot
n1 is first multiplied by n2 producing an intermediate 32-bit result. quot
is the floor of the quotient of the intermediate 32-bit result divided by
the divisor n3. The product of n1 times n2 is maintained as an intermediate
32-bit result for greater precision than the otherwise equivalent sequence:
n1 n2 * n3 / . An error condition results if the divisor is zero or if the
quotient falls outside the range {-32768..32767}.
\
*/MOD n2 n3 n3 rem quot
n1 is first multiplied by n2 producing an intermediate 32-bit result. quot
is the floor of the quotient of the intermediate 32-bit result divided by the
divisor n3. A 32-bit intermediate product is used as for */ . rem has the
same sign as n3 or is zero. An error condition results if the divisor is
zero or if the quotient falls outside of the range {-32768..32767}.
\
+ w1 w2 w3
w3 is the arithmetic sum of w1 and w2.
\
+! w1 addr -
w1 is added to the contents of addr.
\
+- n1 n2 n3
Apply the sign of n2 to n1 to obtain n3. n3 := sign(n2) * n1.
\
+LOOP n -
n is added to the loop index. If the new index was incremented across
the boundary between limit-1 and limit then the loop is terminated and
loop control parameters are discarded. When the loop is not terminated,
execution continues just after the corresponding DO.
\
, n -
ALLOT one word of space at the end of the dictionary and store n in this
space.
\
,WORD char -
Compile text from the input stream delimited by char into the dictionary as
a counted string. The minimum even number of bytes that will hold the text
is ALLOTted.
\
- w1 w2 w3
w3 is the result of subrtracting w2 from w1.
\
-1 - -1
CONSTANT that returns -1.
\
-IMM nfa cfa n
Given a name field address, returns the corresponding code field address
and a flag n which is -1 if the word is non-immediate and 1 if the word
is immediate.
\
-ROT w1 w2 w3 w3 w1 w2
The top three stack entries are rotated, moving the top entry to the
bottom. -ROT is the converse of ROT.
\
-TRAILING addr +n1 addr +n2
The character count +n1 of a text string beginning at addr is adjusted to
exclude trailing spaces. If +n1 is zero, then +n2 is zero. If the entire
string consists of spaces, then +n2 is zero.
\
. n -
The absolute value of n is displayed in a free field format with leading
minus sign if n is negative.
\
." - -
Compiling word used in the form:
." cccc"
Later execution will display the character cccc up to but not including the
delimiting " (close-quote). The blank following ." is not part of cccc.
\
.( - -
Immediate word used in the form:
.( cccc)
The characters cccc up to but not including the delimiting ) (closing paren-
thesis) are displayed. The blank following .( is not part of cccc.
\
.R n size -
Attempts to display n right-justified in a field of size characters.
\
/ n1 n2 n3
n3 is the floor of the quotient of n1 divided by the divisor n2. An
error condition results if the divisor is zero or if the quotient falls out-
side of the range {-32768..32767}.
\
/MOD n1 n2 rem quot
rem is the remainder and quot the floor of the quotient of n1 divided by
the divisor n2. rem has the same sign as n2 or is zero. An error condition
results if the divisor is zero or if the quotient falls outside of the range
{-32768..32767}.
\
0 - 0
CONSTANT returns zero.
\
0< n flag
flag is true if n is less than zero (negative).
\
0= n flag
flag is true if n is zero.
\
0> n flag
flag is true if n is greater than zero.
\
1 - 1
CONSTANT returns 1.
\
1+ w1 w2
w2 is w1 + 1 (modulo 65536).
\
1- w1 w2
w2 is w1 - 1 (modulo 65536).
\
2 - 2
CONSTANT returns 2.
\
2! dl dh addr -
Store high word dh at addr and store low word dl at addr+2.
\
2* w1 w2
w2 is the result of shifting w1 left one bit. A zero is shifted into the
vacated bit position.
\
2+ w1 w2
w2 is w1 + 2 (modulo 65536).
\
2- w1 w2
w2 is w1 - 2 (modulo 65536).
\
2/ n1 n2
n2 is the result of arithmetically shifting n1 right one bit. The sign is
included in the shift and remains unchanged.
\
2@ addr dl dh
dh is contents of addr, dl is contents of addr+2.
\
2DROP w1 w2 -
w1 and w2 are dropped from the stack.
\
2DUP w1 w2 w1 w2 w1 w2
w1 and w2 are duplicated on the stack.
\
2VARIABLE - -
A defining word used in the form:
2VARIABLE <name>
A dictionary entry for <name> is created and four bytes are ALLOTted in its
parameter field. When <name> is later executed, the address of its parameter
field is placed on the stack.
\
: - -
A defining word used in the form:
: <name> ... ;
Create a definition for <name> in the compilation vocabulary and sets compil-
ation state. The search order is changed so that the first vocabulary in the
search order is replaced by the compilation vocabulary. The compilation
vocabulary is unchanged. The text from the input stream is subsequently
compiled. The newly created definition for <name> cannot be found in the
dictionary until the corresponding ; or equivalent operation is performed.
\
; - -
Compiling word stops compilation of a colon definition, allow the <name> to
be found in the dictionary; sets interpret state; and compiles (;), a word
functionally equivalent to EXIT.
\
< n1 n2 flag
flag is true if n1 is less than n2.
\
<# - -
Initialize pictured numeric output conversion. The words:
# #> #S <# HOLD SIGN
can be used to specify the conversion of a double number into an ASCII text
string stored in right-to-left order.
\
<< - -
Immediate word to signal the beginning of a case inside the SELlect case
control structure. See SEL for an example of how to use the case words.
\
<> n1 n2 flag
flag is true if n1 is not equal to n2.
\
<MARK - addr
Used at the destination of a backward branch. addr is typically only used
by <RESOLVE to compile a branch address.
\
<RESOLVE addr -
Used at the source of a backward branch after either BRANCH or ?BRANCH.
Compiles a branch address using addr as the destination address.
\
= n1 n2 flag
flag is true if n1 equals n2.
\
==> - -
Immediate word separates a case structure equality test from the corresponding
case action. See SEL for an example of how to use the case words.
\
=> - -
Immediate word separates a case structure test from the corresponding case
action. See SEL for an example of how to use the case words.
\
> n1 n2 flag
flag is true if n1 is greater than n2.
\
>> - -
Immediate word ends a case inside a case SEL control structure. See SEL for
an example of how to use the case words.
\
>>RESOLVE addr -
Resolves a list of multiple forward references. addr points to the first
element of a linked list. Each link is stored in the address field of an
unresolved BRANCH or ?BRANCH instruction. >>RESOLVE threads down the
list pointing the BRANCHes to HERE. A null list is indicated by addr equal
to zero.
\
>IN - addr
VARIABLE that conatains the present character offset within the input stream.
\
>MARK - addr
Used at the source of a forward branch. Typically used after either BRANCH
or ?BRANCH. Compiles space in ther dictionary for a branch address which will
later by resolved by >RESOLVE.
\
>R n -
Transfers n to the return stack.
\
>RESOLVE addr -
Used at the destination of a forward branch. Places a branch address to HERE
in the space left by >MARK.
\
? addr -
The contents of addr are displayed in free field format with a leading minus
sign if negative.
\
?BRANCH flag -
When used in the form: COMPILE ?BRANCH a conditional branch operation is
compiled. See BRANCH for further details. When executed, if flag is false
the branch is performed as with BRANCH. When flag is true execution continues
at the compilation address immediately following the branch address.
\
?DUP n n n <or> 0
n is duplicated if it is non-zero.
\
?STACK - flag
flag is true if stack has underflowed.
\
@ addr n
n is the value at addr.
\
@SP - addr
addr is the address of the top stack item before @SP was executed.
\
ABORT - -
Clears the data stack and performs the function of QUIT.
\
ABORT" flag -
Immediate word used in the form:
flag ABORT" cccc"
When later executed, if flag is true, the characters cccc, delimited by "
(close-quote), are displayed and ABORT is executed. If flag is false, the
flag is dropped and execution continues. The blank following ABORT" is
not part of cccc. This word violates the principles of structured program-
ming and its use should be avoided.
\
ABS n u
u is the absolute value of n. If n is -32768 then u is the same value.
\
AGAIN - -
Compiling word used in the form:
BEGIN ... AGAIN
compiles an infinite loop.
\
ALIGN addr1 addr2
Force word alignment of addr1.
\
ALLOT w -
Allocates w bytes in the dictionary. WARNING: never ALLOT an odd number of
bytes.
\
AND n1 n2 n3
n3 is the bit-by-bit logical 'and' of n1 and n2.
\
BASE - addr
VARIABLE containing the current numeric conversion radix.
\
BEGIN - -
Immediate word marks the start of a word sequence for repetitive execution.
\
BRANCH - -
When used in the form: COMPILE BRANCH a conditional branch operation is
compiled. A branch address must be compiled immediately following this
compilation address. The branch address is typically generated by follow-
ing BRANCH with <RESOLVE, >MARK, or >>RESOLVE.
\
C! n addr -
The least significant 8 bits of n are stored into the byte at addr.
\
C@ addr byte
The byte stored at addr is fetched.
\
CALL - -
Compile PDP-11 opcode for JSR iar,*$--- . This word is typically used in
creating the code field of a dictionary definition. See the defintions for
:, VARIABLE, and CONSTANT in the source code for an example its use.
\
CFIELD nfa cfa
Converts a name field address to the corresponding code field address.
\
CHUCKBUF - -
Flush rest of input buffer by moving >IN to the EOL mark.
\
CLOSE fd -
Close the Unix file with given file descriptor.
\
CMOVE addr1 addr2 u -
Move u bytes beginning at address addr1 to addr2. The byte at addr1 is moved
first, proceeding toward high memory. If u is zero, nothing is moved.
\
CMOVE> addr1 addr2 u -
Move the u bytes at address addr1 to addr2. The move begins by moving the
byte at (addr1 + u - 1) to (addr2 + u - 1) and proceeds to successively
lower addresses. If u is zero nothing is moved.
\
COMPILE - -
Typically used in the form:
: <name> ... COMPILE <namex> ... ;
When name is executed, COMPILE compiles the execution address of <namex> into
the dictionary. Execution continues after <namex>.
\
CONSTANT n -
A defining word used in the form:
n CONSTANT <name>
Creates a dictionary entry for <name> so that when <name> is later executed,
n will be left on the stack.
\
CONTXT - addr
addr is the address of a variable that points to the dictionary search
vocabulary. This word is called CONTEXT in FORTH-83.
\
CONVERT dl1 dh1 addr1 dl2 dh2 addr2
d2 is the result of converting the characters within the text beginning at
addr1 + 1 into digits, using the value of BASE, and accumulating each into
d1 after multiplying d1 by the value of BASE. Conversion continues until
an unconvertible character is encountered. addr2 is the address of the first
unconvertivle character.
\
COUNT addr addr+1 n
Assumes a counted string is stored at addr. Returns n, the byte stored
at addr, and increments addr.
\
CR - -
EMITs a linefeed character.
\
CREAT addr[string] pmode fd <or> -1
Try to create a file whose name is pointed to be addr with protection bits
pmode. The file is opened for writing and the file descriptor is returned.
If the file already exists, its length is truncated to zero. A -1 is returned
in the event of an error.
\
CREATE - -
A defining word used in the form:
CREATE <name>
Creates a dictionary entry for <name>. After <name> is created, the next
available dictionary location is the first byte of <name>'s parameter field.
When <name> is subsequently executed, the address of <name>'s parameter field
is left on the stack. CREATE does not allocate space is <name>'s parameter
field.
\
CURRENT - addr
addr is the address of a variable pointing to the vocabulary in which new
word definitions are appended.
\
D+ d1l d1h d2l d2h dl3 dh3
d3 is is the arithmetic sum of d1 and d2.
\
D+- d1l d1h n d2l d2h
d2 is obtained by applying the sign of n to d1. d2 := sign(n) * d1.
\
D. dl dh -
Print the double precision number d in free field format with a leading
minus sign if necessary.
\
D.LZ dl dh size -
Print the double precision number d right-justified in a field of size
characters with leading zeros appended.
\
D.R dl dh size -
Print the double precision number d right-justified in a field of size
characters.
\
D< d1l d1h d2l d2h flag
flag is true if d1 is less than d2.
\
DABS d1l d1h d2l d2h
d2 is the absolute value of the double precision number d1. If d1 is equal
to -2,147,483,647 then d2 has the same value.
\
DECIMAL - -
Set the input-output conversion base to ten.
\
DEFINITIONS - -
The compilation vocabulary is changed to be the same as the search vocabulary.
\
DEPTH - n
N is the number of 16-bit values contained on the parameter stack before
DEPTH was executed.
\
DIGIT char n true <or> false
If char represents a valid digit in the current BASE, it is converted to
the value n and true is returned. Otherwise false is returned.
\
DNEGATE d1l d1h d2l d2h
d2 is the two's complement of of d1.
\
DO n1 n2 -
Compiling word used in the form:
DO ... LOOP or DO ... +LOOP
Begins a loop which terminates based on control parameters. The loop index
begins at n2 and terminates based on the limit n1. See LOOP and +LOOP
for details on how the loop is terminated. The loop is always executed at
least once.
\
DOES> - addr
Defines the run-time action of a word created by the high-level defining
word CREATE. Used in the form:
: <namex> ... <create> ... DOES> ... ;
and then
<namex> <name>
where <create> is CREATE or any user defined word which executes CREATE.
Marks the termination of the defining part of the defining word <namex>
and then begins the definition of the run-time action for words that will
later be defined by <namex>. When <name> is later executed, the address
of <name>'s parameter field is placed on the stack and then the sequence
of words between DOES> and ; are executed.
\
DP - addr
VARIABLE that has the address of the first free byte at the end of the
dictionary.
\
DROP n -
n is DROPped from the stack.
\
DUMP addr n -
DUMPs n bytes of memory in pretty format starting at addr.
\
DUP n n n
n is DUPlicated on the stack.
\
ELSE - -
Immediate word used in the form:
flag IF ... ELSE ... THEN
At run-time ELSE branches to just after the THEN.
\
EMIT n -
The least significant 8 bits of n are sent to the standard output.
\
ENDINTERP - -
Reset parameter stack pointer and throw away rest of input line.
\
ENDSEL - -
Immediate word ends a case control structure. See SEL for an example
of how to use the case words.
\
EOL - char
CONSTANT defined as newline character (linefeed).
\
EXECUTE cfa -
The word definition indicated by cfa is executed.
\
EXIT - -
When executed inside a colon defintion, returns control to the definition
that passed control to it. Cannot be used inside a DO ... LOOP.
\
FALSE - false
Places false flag (0) on the stack.
\
FEXPECT fd addr count actcount
Reads up to count bytes from the file denoted by file descriptor fd into
the buffer at addr. Tabs are converted to blanks and encountering a line-
feed or and EOF will terminate the read. The actual number of bytes read
actcount is returned.
\
FLOAD addr[string] -
Attempts to open the file indicated by the null-terminated string 'string'
for reading. If successful, the text in the file is interpreted until an
EOF is encountered. If the file can't be opened, a message is printed.
\
FQUERY fd actcount
FEXPECTs 120 characters from the file denoted by the file descriptor fd.
The text is placed in TIB, the text input buffer. The actual number of bytes
read is returned.
\
FILL addr u byte -
u bytes of memory beginning at addr are set to byte. No action is taken if
u is zero.
\
FIND addr1 addr2 n
addr1 is the address of a counted name string. Tries to find the name in the
search vocabulary or in the compilation vocabulary. If the word is not found,
addr2 is the string address addr1, and n is zero. If the word is found, addr2
is the compilation address and n is set to one of two non-zero values. If
the word found has the immediate attribute, n is set to one. If the word is
non-immediate, n is set to minus one.
\
FORGET - -
Used in the form:
FORGET <name>
If <name> is found is the compilation vocabulary, delete <name> from the dic-
tionary and all words added to the dictionary after <name> regardless of their
vocabulary. An error message is printed if <name> is not found.
\
FORTH - -
The name of the primary vocabulary. Execution sets the search vocabulary to
FORTH.
\
HEADER - -
Create dictionary header in compilation vocabulary for next word in input
stream. The header contains only the name field and link field.
\
HERE - addr
The address of the next available dictionary location.
\
HEX - -
Set the input-output conversion base to hex.
\
HLD - addr
VARIABLE holds the address of the last character added to the current
pictured numeric output conversion.
\
HOLD char -
char is inserted into a pictured numeric output string. Typically used
between <# and #>.
\
I - n
n is a copy of the loop index. May only be used in the form:
DO ... I ... LOOP or DO ... I ... +LOOP
\
IF - -
Immediate word used in the form:
flag IF ... ELSE ... THEN or flag IF ... THEN
If flag is true, the words following IF are executed and the words following
ELSE until just after THEN are skipped. The ELSE part is optional. If flag
is false, words from IF through ELSE, or from IF through THEN (when no ELSE
is used), are skipped.
\
INTERPRET - -
Interpret the text in the input buffer until an EOL is encountered.
\
J - n
n is a copy of the index of the next outer loop. May only be used within
a nested DO-LOOP.
\
LATEST - nfa
Returns name field address of word most recently added to the compilation
vocabulary.
\
LEAVE - -
Transfers execution to just beyond the next LOOP or +LOOP. The loop is
terminated and loop control parameters are discarded. May only be used in
the form:
DO ... LEAVE ... LOOP or DO ... LEAVE ... +LOOP
Leave may appear within other control structures which are nested within
the DO-LOOP structure. More than one LEAVE may appear within a DO-LOOP.
\
LITERAL n -
Immediate word typically used in the form:
[ n ] LITERAL
compiles n as a literal. At run-time, n will be put on the stack.
\
LOOP - -
Increments the DO-LOOP index by one. If the new index was incremented
across the boundary between limit-1 and limit, the loop is terminated and
loop control parameters are discarded. When the loop is not terminated,
execution continues to just after the corresponding DO.
\
M* n1 n2 dl dh
The signed numbers n1 and n2 and are multiplied to obtain the signed double
precision number d.
\
M/ dl dh divisor rem quot
Signed mixed mode floored division. d is 32 bits.
\
M/MMOD dl dh divisor rem quotl quoth
unsigned mixed mode division. Dividend and quotient are 32 bits.
\
MAX n1 n2 n3
n3 is the greater of n1 and n2 according to the operation of >.
\
MIN n1 n2 n3
n3 is the lesser of n1 and n2 according to the operation of <.
\
MOD n1 n2 n3
n3 is the remainder after dividing n1 by the divisor n2. n3 has the same
sign as n2 or is zero. An error condition results if the divisor is zero
or if the quotient falls outside of the range {-32768..32767}.
\
NEGATE n1 n2
n2 is the two's complement of n1.
\
NFIELD cfa nfa
Convert a code field address to its corresponding name field address.
\
NOT n1 n2
n2 is the one's complement of n1.
\
NUMBER addr n true <or> false
addr points to a counted string. NUMBER attempts to convert this string
to a number using the current BASE. The converted number n and a true flag
are returned if successful. Otherwise a false is returned. For the con-
version to be successful, there must be a blank at the end of the string.
This is taken care of by WORD.
\
OCTAL - -
Set the input-output conversion base to octal.
\
OPEN addr[string] mode fd <or> -1
Try to open a file whose name is pointed to by addr with mode attributes.
Returns a file descriptor fd if successful, a -1 otherwise. string is
a null terminated text string. File modes are 0=read-only, 1=write-only,
and 2=read-write.
\
OR n1 n2 n3
n3 is the bit-by-bit inclusive-or of n1 and n2.
\
OUTPUT fd -
Add file descriptor to output table used by TYPE if there is room in the table.
If there is no room, the command is ignored.
\
OVER n1 n2 n1 n2 n1
Duplicates n1 on stack.
\
PAD - addr
The lower address of a scratch area used to hold data for intermediate pro-
cessing. The address or contents of PAD may change and the data lost if the
address of the next available dictionary location is changed.
\
PICK n1 n2
n2 is a copy of the n1'th stack item not counting n1 itself. 0 PICK is
equivalent to DUP, 1 PICK is equivalent to OVER, etc.
\
QUIT - -
Sets interpret state, accepts new input from the current input device, and
begins text interpretation. This word diverges from the FORTH-83 word QUIT
in that it does not reset the return stack. This may be changed in the
future.
\
R> - n
n is removed from the return stack and transferred to the parameter stack.
\
R@ - n
n is a copy of the top of the return stack.
\
READ fd addr count actcount
READs up to count bytes from the file denoted by file descriptor fd to
the buffer at addr. actcount is the number of bytes actually read.
If this is not equal to count, the end of file was encountered or an error
occurred.
\
REPEAT - -
Immediate word used in the form:
BEGIN ... flag WHILE ... REPEAT
At run-time, REPEAT continues execution just after the corresponding
BEGIN.
\
ROLL n -
The n'th stack value, not counting n itself is first removed and then trans-
ferred to the top of the stack, moving the remaining values into the vacated
position. 2 ROLL is equivalent to ROT. 0 ROLL is a null operation.
\
ROT n1 n2 n3 n2 n3 n1
The top three stack entries are rotated, bringing the deepest to the top.
\
ROTATE n1 nbits n2
ROTATE n1 nbits. If nbits is greater than zero, n1 is ROTATEd left. If
nbits is less than zero, n1 is ROTATEd right. If nbits is zero, nothing
happens.
\
S->D n dl dh
Sign extend n into a double precision number.
\
SEEK fd offsetl offseth -
Perform random-access seek on file denoted by file descriptor fd. offset
is a double precision number specifying a new file position offset from the
start of the file.
\
SEL - -
Immediate case structure word used in the form:
<selector> SEL
<< 1 ==> ... >>
<< 2 ==> ... >>
<< 5 ==> ... >>
<< OTHERWISE ==> ... >>
ENDSEL
The constants 1, 2, and 5 are just shown as an example. Any word that leaves
one item on the stack can be used in the select field. The action code
symbolized by ..., can be any thing including another case structure. The
<selector> is no longer on the stack when the action code begins execution.
The OTHERWISE clause is optional. If none of the words in the select fields
match the <selector>, the <selector> is dropped by ENDSEL.
\
SHELL - -
Spawn a new sub-shell under the forth process. Typing a ^D will cause control
to return to forth.
\
SIGN n -
If n is negative, an ASCII "-" is appended to the pictured numeric output
string. Typically used between <# and #>.
\
SILENT fd -
Remove all instances of fd from the table used by TYPE.
\
SMUDGE - -
Toggle smudge bit in name field of word most recently added to the compilation
vocabulary.
\
SP0 - addr
addr is address of 'top of stack' for an empty stack. Used for resetting
stack pointer.
\
SPACE - -
EMIT an ASCII space.
\
SPACES n -
EMIT n ASCII spaces. Nothing is EMITted if n is negative or zero.
\
STATE - addr
VARIABLE has current interpret-compile state. 0=interpret, 1=compile.
\
STDIN - 0
CONSTANT returns file descriptor of standard input.
\
STDOUT - 1
CONSTANT returns file descriptor of standard output.
\
STRING addr[counted string] addr[unix string]
Converts a counted string to a unix-style null-terminated string. A copy of
the counted string is moved to PAD so that the conversion does not alter
the original string.
\
SWAP n1 n2 n2 n1
The top two stack entries are exchanged.
\
SYSTEM addr[string] -
Spawns a sub-shell to execute the unix command string pointed to by addr.
The string must be null-terminated. Typically used in the form:
" cccc" SYSTEM or inside a colon definition as:
"" cccc" SYSTEM
\
TERMINATE - -
Terminate the forth process. Returns 'good' status value.
\
THEN - -
Immediate word used in the form:
flag IF ... ELSE ... THEN or flag IF ... THEN
THEN is the point where execution continues after ELSE, or IF when no ELSE
is present.
\
TIB - addr
addr is the address of the text input buffer.
\
TOGGLE addr bits -
The contents of addr are exclusive-or'ed with bits and the results stored
at addr.
\
TRUE - true
Places a true flag (-1) on the stack.
\
TYPE addr count -
count bytes of memory beginning at addr are sent to the standard output.
\
U. u -
u is displayed as an unsigned number in a free-field format.
\
U.LZ u size -
u is displayed as an unsigned number right-justified in a field of size
characters with leading zeros.
\
U.R u size -
u is displayed as an unsigned number right-justified in a field of size
characters.
\
U< u1 u2 flag
flag is true if the unsigned number u1 is less than the unsigned number u2.
\
U> u1 u2 flag
flag is true if the unsigned number u1 is greater than the unsigned number n2.
\
U? addr -
Display the contents of addr as an unsigned number in free-field format.
\
UM* n1 n2 ul uh
u is the 32-bit product of the unsigned multiplication of n1 and n2.
\
UM*M u1l u1h mul u2l u2h
u2 is the 32-bit product of the unsigned multiplication of u1 and mul.
\
UM/ ul uh div rem quot
rem and quot are remainder and quotient of unsigned division of 31-bit u
by the unsigned divisor 'div'.
\
UM/MOD ul uh div rem quot
'rem' and 'quot' are remainder and quotient of unsigned division of 32-bit 'u'
by the unsigned divisor 'div'.
\
UNTIL - -
Immediate word used in the form:
BEGIN ... flag UNTIL
Marks the end of a BEGIN-UNTIL loop which will terminate based on flag. If
flag is true, the loop is terminated. If flag is false, execution continues
just after the corresponding BEGIN.
\
VARIABLE - -
A defining word used in the form:
VARIABLE <name>
A dictionary entry for <name> is created and two bytes are ALLOTted in its
parameter field. This parameter field is to be used for the contents of the
VARIABLE. The application is responsible for initializing the contents of
the VARIABLE. When <name> is later executed, the address of its parameter
field is placed on the stack.
\
VOCABULARY - -
A defining word used in the form:
VOCABULARY <name>
A dictionary entry for <name> is created. Subsequent execution of <name>
sets the search vocabulary to <name>. When <name> becomes the compilation
vocabulary, new definitions will be appended to <name>'s list.
\
WHILE - -
Immediate word used in the form:
BEGIN ... flag WHILE ... REPEAT
Selects conditional execution based on flag. When flag is true, execution
continues just after the WHILE. When flag is false, execution continues
just after the REPEAT, exiting the control structure.
\
WORD char addr
Generates a counted string by non-destructively accepting characters from
the input stream until the delimiting character char is found or the
input stream is exhausted. Leading delimiters are ignored. The entire
character string is stored in memory beginning at addr as a sequence of
bytes. The string is followed by a blank which is not included in the count.
The first byte of the string is the number of characters {0..255}. If the
string is longer than 255 characters, the count is unspecified. If the input
stream is already exhausted as WORD is called, then a zero length character
string will result.
\
WRITE addr count fd actcount
count bytes of memory starting at addr are sent to the file denoted by
file descritor fd. The actual number of bytes written actcount is re-
turned. If this number does not equal count, an error of some sort has
occurred.
\
WRN - addr
VARIABLE that holds the state the warning message enable/disable. If WRN
is true, the user will be notified if he tries to add a word to the
dictionary whose name conflicts with a word already in the dictionary.
\
XOR n1 n2 n3
n3 is the bit-by-bit exclusive-or of n1 and n2.
\
ZEROES n -
EMIT n ASCII zeroes. Nothing is EMITted if n is zero or negative.
\
[ - -
Immediate word that sets the interpretation state to interpret.
\
['] - addr
Immediate word used in the form:
['] <name>
Compiles the compilation address of <name> as a literal. At run-time
the cfa of <name> is put on the stack. If <name> is not found in the
dictionary, a literal zero is compiled.
\
[COMPILE] - -
Immediate word used in the form:
[COMPILE] <name>
Forces compilation of the following word <name>. This allow compilation of
an immediate word when it would otherwise have been executed.
\
] - -
Sets interpretation state to compile. The text from the input stream is
subsequently compiled.
\
+E+O+Flwt1@aplvax.UUCP (06/08/84)
Here is part 3 of the source for FORTH for the PDP-11.
Delete everything thru the "-- cut here --" line, and extract with 'sh':
sh part1 part2 ... part7
where 'part?' are whatever you've named the files. Note the copyright
notice at the end of README. Please let us know how things go. While
we can't support this software, we'll be posting bug fixes/upgrades to
net.sources as time permits.
VAX-FORTH should be 'forth'-coming {yuk-yuk} within a couple of weeks.
Have fun!
-Lloyd W. Taylor
... seismo!umcp-cs!aplvax!lwt1
---I will have had been there before, soon---
---------------------------------- cut here ----------------------------------
echo x - prim.as
cat >prim.as <<'+E+O+F'
/ Copyright 1984 by The Johns Hopkins University/Applied Physics Lab.
/ Free non-commercial distribution is *encouraged*, provided that:
/
/ 1. This copyright notice is included in any distribution, and
/ 2. You let us know that you're using it.
/
/ Please notify:
/
/ Lloyd W. Taylor
/ JHU/Applied Physics Lab
/ Johns Hopkins Road
/ Laurel, MD 20707
/ (301) 953-5000
/
/ Usenet: ... seismo!umcp-cs!aplvax!lwt1
/
/
/ Unix-FORTH was developed under NASA contract NAS5-27000 for the
/ Hopkins Ultraviolet Telescope, a March 1986 Space Shuttle mission. (we
/ hope to take a peek at Halley's comet!)
/
/ Written entirely by Wizard-In-Residence John R. Hayes.
/
/ * Unix is a trademark of Bell Labs.
/
/
/ FORTH PDP-11 inner interpreter and code primitives
/
iar =r4
psp =r5
nl =012 / newline
tab =011 / tab
EOF =-1 / end of file
BLKSIZE=512. / disk block size
/ start-up code
mov $pstack,psp / TEST
mov $dict,DP
mov $16.,BASE / base is hex
mov $quit-6,INITVOCAB
mov $quit+4,iar / point to high level QUIT code
jmp *(iar)+
/ parameter stack
.=.+256. / 256 byte stack TEST
pstack:
/ text input buffer
inbuf: .=.+120. / 120 characters
/ (:) Code for next is thing at bottom of dictionary
.byte 3; <(:)>
.byte 0,0 / end of dictionary
next: jmp *(iar)+
/ The code for call is compiled in-line for colon definitions.
/
/ call: jsr iar,*$next
/
/ (;)
.byte 3; <(;)>
next-6
return: mov (sp)+,iar
jmp *(iar)+
/
/ This is tricky code. All words defined by VARIABLE, CONSTANT, or
/ <BUILDS .. DOES> words will have similar code fields. Therefore the
/ code for (VARIABLE), (CONSTANT), and (DOES>) is shown below.
/ Code compiled by VARIABLE will be:
/ jsr iar,*$var
/ (VARIABLE)
.byte 12; <(VA>
return-6
var: mov iar,-(psp)
mov (sp)+,iar
jmp *(iar)+
/ (CONSTANT)
.byte 12; <(CO>
var-6
con: mov (iar),-(psp)
mov (sp)+,iar
jmp *(iar)+
/ (DOES>)
.byte 7; <(DO>
con-6
pdoes: mov (iar)+,r0
mov iar,-(psp)
mov r0,iar
jmp *(iar)+
/ branching primitives
/ (LITERAL)
.byte 11; <(LI>
pdoes-6
lit: mov (iar)+,-(psp)
jmp *(iar)+
/ BRANCH
.byte 6; <BRA>
lit-6
branch: mov (iar),iar
jmp *(iar)+
/ ?BRANCH
.byte 7; <?BR>
branch-6
zbranch:
mov (psp)+,r0
beq branch
add $2,iar
jmp *(iar)+
/ EXECUTE
.byte 7; <EXE>
zbranch-6
execute:
jmp *(psp)+
/ FORTH-83 do loops
/ (DO)
.byte 4; <(DO>
execute-6
pdo: mov (psp)+,r1
mov (psp)+,r0
add $100000,r0 / limit' := limit + 8000
mov r0,-(sp)
sub r0,r1 / imit' := init - limit'
mov r1,-(sp)
jmp *(iar)+
/ (LOOP)
.byte 6; <(LO>
pdo-6
ploop: inc (sp)
bvs exitloop
mov (iar),iar / loop back
jmp *(iar)+
exitloop:
add $4,sp / pop return stack
add $2,iar / skip loop address
jmp *(iar)+
/ (+LOOP)
.byte 7; <(+L>
ploop-6
pploop: add (psp)+,(sp)
bvs exitloop
mov (iar),iar / loop back
jmp *(iar)+
/ I
.byte 1; <I >
pploop-6
i: mov (sp),r0
add 2(sp),r0 / i := i' + limit'
mov r0,-(psp)
jmp *(iar)+
/ J
.byte 1; <J >
i-6
j: mov 4(sp),r0
add 6(sp),r0
mov r0,-(psp)
jmp *(iar)+
/ (LEAVE)
.byte 7; <(LE>
j-6
pleave: add $4,sp / pop return stack
mov (iar),iar / branch past loop
jmp *(iar)+
/ basic unix system interface routines
/ buffer for holding indirect system calls
sysbuf: .byte 0,0 / trap instruction
.byte 0,0 / argument 1
.byte 0,0 / argument 2
.byte 0,0 / argument 3
/ I/O buffer and control variables
block: .=.+BLKSIZE; .even
size: .byte 0,0 / size in bytes
index: .byte 0,0 / current offset into block
fd: .byte -1,-1 / file descriptor of file this block belongs to
/ file position table: each slot has a 32 bit file offset. file descriptor
/ is index into table. There are 15 slots.
filepos:
.byte 0,0,0,0
.byte 0,0,0,0
.byte 0,0,0,0
.byte 0,0,0,0
.byte 0,0,0,0
.byte 0,0,0,0
.byte 0,0,0,0
.byte 0,0,0,0
.byte 0,0,0,0
.byte 0,0,0,0
.byte 0,0,0,0
.byte 0,0,0,0
.byte 0,0,0,0
.byte 0,0,0,0
.byte 0,0,0,0
/ subroutine getc: handles all input and does buffering
/ input: file descriptor in r0
/ output: character or EOF in r0
/ side effects: r0 and r1
getc: cmp r0,fd / is this file in buffer?
beq 0f / if so, do not need to seek
mov r0,fd / save new fd in buffer descriptor
mov size,index / indicate that buffer is empty
mov $104423,sysbuf / move lseek trap instruction to sysbuf
asl r0; asl r0 / multiply by 4 to index into table
mov filepos(r0),sysbuf+2 / high offset word
mov filepos+2(r0),sysbuf+4 / low offset word
clr sysbuf+6 / offset from beginning of file
mov fd,r0 / file descriptor in r0
sys 0;sysbuf / seek sytem call
mov fd,r0 / restore fd since call destroyed r0,r1
0: mov r2,-(sp) / save r2
mov *$index,r2 / r2 is index
cmp r2,*$size
blt 1f / if there is still data in buffer, use it
sys 3;block;BLKSIZE / read up to BLKSIZE bytes
bcs 2f / branch if error
mov r0,*$size / save size of block
beq 2f / branch if eof
clr r2 / reset index
1: movb block(r2),r0 / get next character
bic $17400,r0 / mask off high byte
inc r2
mov r2,*$index / update index
mov fd,r2 / reuse r2 to hold file descriptor
asl r2; asl r2 / multiply by 4 to index into table
add $1,filepos+2(r2) / add one to current file position
adc filepos(r2)
br 3f
2: mov $EOF,r0 / return EOF on error condition
3: mov (sp)+,r2 / restore r2
rts pc
/ OPEN ( addr[string] mode --- fd )
.byte 4; <OPE>
pleave-6
open: mov $104405,sysbuf / move trap 5 instruction to indir area
mov (psp)+,sysbuf+4 / mode
mov (psp),sysbuf+2 / addr[filename]
sys 0;sysbuf
bcc 1f
mov $-1,(psp) / error, negative file descriptor returned
br 2f
1: mov r0,(psp) / return file descriptor
asl r0; asl r0 / multiply by 4 to index into table
clr filepos(r0) / initialize file position to zero
clr filepos+2(r0)
2: jmp *(iar)+
/ CREAT ( addr[string] pmode --- fd/-1 )
.byte 5; <CRE>
open-6
creat: mov $104410,sysbuf / move trap 8 instruction to indir area
mov (psp)+,sysbuf+4 / move mode
mov (psp),sysbuf+2 / move address of file name
sys 0;sysbuf / creat system call
bcc 1f
mov $-1,(psp) / error, negative file descriptor returned
br 2f
1: mov r0,(psp) / return file descriptor
asl r0; asl r0 / multiply by 4 to index into position table
clr filepos(r0) / initialize file position to zero
clr filepos+2(r0)
2: jmp *(iar)+
/ CLOSE ( fd --- )
.byte 5; <CLO>
creat-6
close: mov $104406,sysbuf / move trap 6 instruction to indir area
mov (psp)+,r0 / file descriptor
sys 0;sysbuf
jmp *(iar)+
/ KEY ( fd --- char/EOF )
.byte 3; <KEY>
close-6
key: mov (psp),r0 / file descriptor
jsr pc,getc / get next character
mov r0,(psp) / return character
jmp *(iar)+
/ FEXPECT ( fd addr count --- actcount)
.byte 7; <FEX>
key-6
fexpect:
mov 2(psp),r2 / buffer address
mov (psp)+,r3 / count
beq 3f / do nothing if count is zero
1: mov 2(psp),r0 / file descriptor
jsr pc,getc / get next character
cmp r0,$EOF
beq 3f / leave loop on EOF
cmpb r0,$tab
bne 2f
movb $040,r0 / change tabs to blanks
2: movb r0,(r2)+ / save character
cmpb r0,$nl
beq 3f / leave loop on newline
sob r3,1b / decrement count and continue if non-zero
3: sub (psp)+,r2 / compute actual number of characters read
mov r2,(psp) / return actual number
jmp *(iar)+
/ READ ( fd addr count --- actcount ) ( like expect )
/ ( that tabs are not stripped and newlines are )
/ ( not significant. )
.byte 4; <REA>
fexpect-6
read: mov 2(psp),r2 / buffer address
mov (psp)+,r3 / count
beq 3f / do nothing if count is zero
1: mov 2(psp),r0 / file descriptor
jsr pc,getc / get next character
cmp r0,$EOF
beq 3f / leave loop on EOF
movb r0,(r2)+ / save character
sob r3,1b / decrement count and continue if non-zero
3: sub (psp)+,r2 / compute actual number of characters read
mov r2,(psp) / return actual number
jmp *(iar)+
/ WRITE ( addr count fd --- actcount )
.byte 5; <WRI>
read-6
write: mov $104404,sysbuf / move trap 4 instruction to indir area
mov (psp)+,r0 / file descriptor
mov (psp)+,sysbuf+4 / count
mov (psp),sysbuf+2 / address
sys 0; sysbuf / indirect system call
bcc 1f
mov $-1,r0 / error flag
1: mov r0,(psp) / return actual count )
jmp *(iar)+
/ SEEK ( fd offsetl offseth --- )
.byte 4; <SEE>
write-6
seek: mov 4(psp),r0 / file descriptor
cmp r0,fd / if seek on currently buffered file
bne 1f
mov $-1,fd / flag buffer as invalid
1: asl r0; asl r0 / multiply by 4 to index into file pos. table
mov (psp),filepos(r0) / high offset into file position table
mov 2(psp),filepos+2(r0) / low offset into file position table
mov $104423,sysbuf / move seek trap instruction to sysbuf
mov (psp)+,sysbuf+2 / move high offset
mov (psp)+,sysbuf+4 / move low offset
clr sysbuf+6 / offset from beginning of file
mov (psp)+,r0 / file descriptor in r0
sys 0;sysbuf / seek
jmp *(iar)+
/ TERMINATE
.byte 11; <TER>
seek-6
terminate:
clr r0 / return good status
sys 1
jmp *(iar)+ / this should not be executed TEST
/ high level utilities written in assembly language for speed
/ (FIND) ( addr[name] addr[vocab] --- 0 <or> nfa )
.byte 6; <(FI>
terminate-6
pfind: mov (psp)+,r0
beq 3f / empty vocabulary?
mov (psp),r3
mov (r3)+,r2 / name ls
mov (r3),r3 / name ms
1: mov (r0),r1
bic $200,r1 / clear immediate bit
cmp r1,r2 / compare ls
bne 2f
cmp 2(r0),r3 / compare ms
beq 3f
2: mov 4(r0),r0 / next link
bne 1b / zero link?
3: mov r0,(psp)
jmp *(iar)+
/ WORD ( del --- addr )
.byte 4; <WOR>
pfind-6
word: mov (psp),r0 / delimiter
mov *$IN,r1 / >IN
add $inbuf,r1
mov *$DP,r2 / HERE
mov r2,(psp) / return HERE
1: cmpb r0,(r1)+ / skip delimiters
beq 1b
dec r1 / back up one
mov r1,r3
2: cmpb r0,(r3) / delimiter?
beq 3f
cmpb $nl,(r3) / newline?
beq 3f
inc r3 / skip until end of word
br 2b
3: sub r1,r3 / r3 has length
movb r3,(r2)+ / save count
beq 5f / skip if eol
4: movb (r1)+,(r2)+ / move characters to here
sob r3,4b
5: cmpb $nl,(r1) / if not newline
beq 6f
inc r1 / skip delimiter
6: sub $inbuf,r1
mov r1,*$IN / update >IN scanner
movb $040,(r2) / put blank at end of word
jmp *(iar)+
/ FORTH nucleus primitives
/ !
.byte 1; <! >
word-6
store: mov (psp)+,r0
mov (psp)+,(r0)
jmp *(iar)+
/ !SP
.byte 3; <!SP>
store-6
storesp:
mov (psp),psp
jmp *(iar)+
/ +
.byte 1; <+ >
storesp-6
plus: add (psp)+,(psp)
jmp *(iar)+
/ +!
.byte 2; <+! >
plus-6
plusstore:
mov (psp)+,r0
add (psp)+,(r0)
jmp *(iar)+
/ -
.byte 1; <- >
plusstore-6
minus: sub (psp)+,(psp)
jmp *(iar)+
/ -1
.byte 2; <-1 >
minus-6
minusone:
mov $-1,-(psp)
jmp *(iar)+
/ 0
.byte 1; <0 >
minusone-6
zero: clr -(psp)
jmp *(iar)+
/ 0<
.byte 2; <0< >
zero-6
zeroless:
clr r0
tst (psp)
bpl 1f
mov $-1,r0
1: mov r0,(psp)
jmp *(iar)+
/ 0=
.byte 2; <0= >
zeroless-6
zeroeq: clr r0
tst (psp)
bne 1f
mov $-1,r0
1: mov r0,(psp)
jmp *(iar)+
/ 1
.byte 1; <1 >
zeroeq-6
one: mov $1,-(psp)
jmp *(iar)+
/ 1+
.byte 2; <1+ >
one-6
oneplus:
inc (psp)
jmp *(iar)+
/ 1-
.byte 2; <1- >
oneplus-6
oneminus:
dec (psp)
jmp *(iar)+
/ 2
.byte 1; <2 >
oneminus-6
two: mov $2,-(psp)
jmp *(iar)+
/ 2+
.byte 2; <2+ >
two-6
twoplus:
add $2,(psp)
jmp *(iar)+
/ 2-
.byte 2; <2- >
twoplus-6
twominus:
sub $2,(psp)
jmp *(iar)+
/ 2*
.byte 2; <2* >
twominus-6
twostar:
asl (psp)
jmp *(iar)+
/ 2/
.byte 2; <2/ >
twostar-6
twoslash:
asr (psp)
jmp *(iar)+
/ <
.byte 1; << >
twoslash-6
less: clr r0
cmp (psp)+,(psp)
ble 1f
mov $-1,r0
1: mov r0,(psp)
jmp *(iar)+
/ =
.byte 1; <= >
less-6
equal: clr r0
cmp (psp)+,(psp)
bne 1f
mov $-1,r0
1: mov r0,(psp)
jmp *(iar)+
/ >
.byte 1; <\> >
equal-6
greater:
clr r0
cmp (psp)+,(psp)
bge 1f
mov $-1,r0
1: mov r0,(psp)
jmp *(iar)+
/ >R
.byte 2; <\>R >
greater-6
tor: mov (psp)+,-(sp)
jmp *(iar)+
/ @
.byte 1; <@ >
tor-6
at: mov *(psp),(psp)
jmp *(iar)+
/ @SP
.byte 3; <@SP>
at-6
atsp: mov psp,r1
mov r1,-(psp)
jmp *(iar)+
/ AND
.byte 3; <AND>
atsp-6
and: mov (psp)+,r0
com r0 / there is no direct and in PDP-11 assembly lang.
bic r0,(psp)
jmp *(iar)+
/ C!
.byte 2; <C! >
and-6
cstore: mov (psp)+,r0
mov (psp)+,r1
movb r1,(r0)
jmp *(iar)+
/ C@
.byte 2; <C@ >
cstore-6
cat: movb *(psp),r0
bic $177400,r0
mov r0,(psp)
jmp *(iar)+
/ CMOVE ( src dest ucount --- )
.byte 5; <CMO>
cat-6
cmove: mov (psp)+,r2
beq 2f
mov (psp)+,r0 / destination
mov (psp)+,r1 / source
1: movb (r1)+,(r0)+
sob r2,1b
br 3f
2: add $4,psp / pop two stack args
3: jmp *(iar)+
/ D+
.byte 2; <D+ >
cmove-6
dplus: mov (psp)+,r0
add (psp)+,2(psp)
adc (psp)
add r0,(psp)
jmp *(iar)+
/ DNEGATE
.byte 7; <DNE>
dplus-6
dnegate:
com (psp)
com 2(psp)
add $1,2(psp)
adc (psp)
jmp *(iar)+
/ DROP
.byte 4; <DRO>
dnegate-6
drop: add $2,psp
jmp *(iar)+
/ DUP
.byte 3; <DUP>
drop-6
dup: mov (psp),-(psp)
jmp *(iar)+
/ M*
.byte 2; <M* >
dup-6
mstar: mov (psp),r0
mul 2(psp),r0
mov r1,2(psp) / low result
mov r0,(psp) / high result
jmp *(iar)+
/ M/
.byte 2; <M/ >
mstar-6
mslash: mov (psp)+,r2 / r2 has divisor
mov (psp),r0 / r0 has high dividend
mov 2(psp),r1 / r1 has low dividend
mov r2,r3
xor r0,r3 / r3 has sign
div r2,r0 / divide by r2
tst r3
bpl 1f / skip if sign is not negative
tst r1
beq 1f / skip if remainder is zero
dec r0 / subtract one from quotient
add r2,r1 / add divisor to remainder
1: mov r1,2(psp) / remainder
mov r0,(psp) / quotient
jmp *(iar)+
/ NEGATE
.byte 6; <NEG>
mslash-6
negate: neg (psp)
jmp *(iar)+
/ NOT
.byte 3; <NOT>
negate-6
not: com (psp)
jmp *(iar)+
/ OR
.byte 2; <OR >
not-6
or: bis (psp)+,(psp)
jmp *(iar)+
/ OVER
.byte 4; <OVE>
or-6
over: mov 2(psp),-(psp)
jmp *(iar)+
/ R>
.byte 2; <R\> >
over-6
fromr: mov (sp)+,-(psp)
jmp *(iar)+
/ R@
.byte 2; <R@ >
fromr-6
rat: mov (sp),-(psp)
jmp *(iar)+
/ ROT
.byte 3; <ROT>
rat-6
rot: mov 4(psp),r0
mov 2(psp),4(psp)
mov (psp),2(psp)
mov r0,(psp)
jmp *(iar)+
/ ROTATE ( word nbits --- word' )
.byte 6; <ROT>
rot-6
rotate: mov (psp)+,r1 / loop counter
bic $0177760,r1 / mask off all but lower four bits
beq 3f
mov (psp),r0
1: tst r0 / test sign bit; clear carry
bpl 2f
sec / set carry
2: rol r0 / rotate
sob r1,1b
mov r0,(psp)
3: jmp *(iar)+
/ SWAP
.byte 4; <SWA>
rotate-6
swap: mov 2(psp),r0
mov (psp),2(psp)
mov r0,(psp)
jmp *(iar)+
/ UM*
.byte 3; <UM*>
swap-6
umstar: clr r0
mov $20,r1 / r1 := 16
mov (psp),r2
mov 2(psp),r3 / multiplier
ror r3 / get ls bit
1: bcc 2f
add r2,r0 / accumulate
2: ror r0 / shift carry into r0
ror r3 / shift into r3; get ls bit
sob r1,1b
mov r3,2(psp) / save ls word
mov r0,(psp) / save ms word
jmp *(iar)+
/ UM/ ( dl dh divisor --- rem quot )
/ dividend is 31 bits
.byte 3; <UM/>
umstar-6
umslash:
mov $20,r0 / 16 bits
mov (psp)+,r1 / divisor
mov (psp),r2 / ms word
mov 2(psp),r3 / ls word
1: asl r3
rol r2
cmp r1,r2
bhi 2f
sub r1,r2
inc r3
2: sob r0,1b
mov r2,2(psp) / remainder
mov r3,(psp) / quotient
jmp *(iar)+
/ U<
.byte 2; <U< >
umslash-6
uless: clr r0
cmp (psp)+,(psp)
blos 1f
mov $-1,r0
1: mov r0,(psp)
jmp *(iar)+
/ U>
.byte 2; <U\> >
uless-6
ugreater:
clr r0
cmp (psp)+,(psp)
bhis 1f
mov $-1,r0
1: mov r0,(psp)
jmp *(iar)+
/ XOR
.byte 3; <XOR>
ugreater-6
exor: mov (psp)+,r0
xor r0,(psp)
jmp *(iar)+
+E+O+Flwt1@aplvax.UUCP (06/08/84)
Here is part 4 of the source for FORTH for the PDP-11.
Delete everything thru the "-- cut here --" line, and extract with 'sh':
sh part1 part2 ... part7
where 'part?' are whatever you've named the files. Note the copyright
notice at the end of README. Please let us know how things go. While
we can't support this software, we'll be posting bug fixes/upgrades to
net.sources as time permits.
VAX-FORTH should be 'forth'-coming {yuk-yuk} within a couple of weeks.
Have fun!
-Lloyd W. Taylor
... seismo!umcp-cs!aplvax!lwt1
---I will have had been there before, soon---
---------------------------------- cut here ----------------------------------
echo x - os.as
cat >os.as <<'+E+O+F'
/
/ FORTH operating system in assembler format
/
/ System variables and constants
/
/ The upper case labels are so that assembly language routines can refer
/ to the values of these variables
/ TIB
.byte 3; <TIB>
exor-6
tib: jsr iar,*$con
inbuf
/ SP0
.byte 3; <SP0>
tib-6
sp0: jsr iar,*$con
pstack
/ DP0
.byte 3; <DP0>
sp0-6
dp0: jsr iar,*$con
dict
/ WRN
.byte 3; <WRN>
dp0-6
wrn: jsr iar,*$var
.byte -1,-1
/ DP
.byte 2; <DP >
wrn-6
dp: jsr iar,*$var
DP: .byte 0,0
/ >IN
.byte 3; <\>IN>
dp-6
in: jsr iar,*$var
IN: .byte 0,0
/ STATE
.byte 5; <STA>
in-6
state: jsr iar,*$var
.byte 0,0
/ BASE
.byte 4; <BAS>
state-6
base: jsr iar,*$var
BASE: .byte 0,0
/ INITVOCAB ( intial vocabulary - will be FORTH )
.byte 11; <INI>
base-6
initvocab:
jsr iar,*$var
INITVOCAB: .byte 0,0
/ CONTXT ( context vocabulary )
.byte 6; <CON>
initvocab-6
context:
jsr iar,*$var
INITVOCAB
/ CURRENT ( current vocabulary )
.byte 7; <CUR>
context-6
current:
jsr iar,*$var
INITVOCAB
/ CLUE
.byte 4; <CLU>
current-6
clue: jsr iar,*$var
.byte 0,0
/ STDIN
.byte 5; <STD>
clue-6
stdin: jsr iar,*$con
.byte 0,0
/ STDOUT
.byte 6; <STD>
stdin-6
stdout: jsr iar,*$con
.byte 1,0
/ EOL
.byte 3; <EOL>
stdout-6
eol: jsr iar,*$con
.byte 12,0
/ TRUE
.byte 4; <TRU>
eol-6
true: jsr iar,*$con
.byte -1,-1
/ FALSE
.byte 5; <FAL>
true-6
false: jsr iar,*$con
.byte 0,0
/ Code extensions
/ ?DUP
.byte 4; <?DU>
false-6
qdup: jsr iar,*$next
dup; zbranch; 1f; dup; 1: return
/ -ROT
.byte 4; <-RO>
qdup-6
mrot: jsr iar,*$next
rot; rot; return
/ *
.byte 1; <* >
mrot-6
star: jsr iar,*$next
umstar; drop; return
/ 2DUP
.byte 4; <2DU>
star-6
twodup: jsr iar,*$next
over; over; return
/ S->D
.byte 4; <S-\>>
twodup-6
stod: jsr iar,*$next
dup; zeroless; return
/ +-
.byte 2; <+- >
stod-6
plusminus:
jsr iar,*$next
zeroless; zbranch; 1f; negate; 1: return
/ D+-
.byte 3; <D+->
plusminus-6
dplusminus:
jsr iar,*$next
zeroless; zbranch; 1f; dnegate; 1: return
/ ABS
.byte 3; <ABS>
dplusminus-6
abs: jsr iar,*$next
dup; plusminus; return
/ DABS
.byte 4; <DAB>
abs-6
dabs: jsr iar,*$next
dup; dplusminus; return
/ 2DROP
.byte 5; <2DR>
dabs-6
twodrop:
jsr iar,*$next
drop; drop; return
/ UM*M ( ul uh mul --- ul' uh' )
.byte 4; <UM*>
twodrop-6
umstarm:
jsr iar,*$next
swap; over; umstar; drop; tor; umstar; zero; fromr; dplus; return
/ M/MMOD
.byte 6; <M/M>
umstarm-6
mslashmmod:
jsr iar,*$next
tor; zero; rat; umslash; fromr; swap; tor; umslash; fromr; return
/ FILL
.byte 4; <FIL>
mslashmmod-6
fill: jsr iar,*$next
mrot; qdup; zbranch; 2f
over; plus; swap; pdo; 1: dup; i; cstore; ploop; 1b; branch; 3f
2: drop
3: drop; return
/ TOGGLE
.byte 6; <TOG>
fill-6
toggle: jsr iar,*$next
over; at; exor; swap; store; return
/ <>
.byte 2; <<\> >
toggle-6
nequal: jsr iar,*$next
equal; not; return
/ MAX
.byte 3; <MAX>
nequal-6
max: jsr iar,*$next
twodup; less; zbranch; 1f; swap; 1: drop; return
/ HEX
.byte 3; <HEX>
max-6
hex: jsr iar,*$next
lit; .byte 16.,0; base; store; return
/ DECIMAL
.byte 7; <DEC>
hex-6
decimal:
jsr iar,*$next
lit; .byte 10.,0; base; store; return
/ OCTAL
.byte 5; <OCT>
decimal-6
octal: jsr iar,*$next
lit; .byte 8.,0; base; store; return
/ 2! ( n1 n2 addr --- )
.byte 2; <2! >
octal-6
twostore:
jsr iar,*$next
swap; over; store; twoplus; store; return
/ Compiling words
/ HERE
.byte 4; <HER>
twostore-6
here: jsr iar,*$next
dp; at; return
/ PAD
.byte 3; <PAD>
here-6
pad: jsr iar,*$next
here; lit; .byte 80.,0; plus; return
/ LATEST
.byte 6; <LAT>
pad-6
latest: jsr iar,*$next
current; at; at; return
/ ALLOT
.byte 5; <ALL>
latest-6
allot: jsr iar,*$next
dp; plusstore; return
/ ,
.byte 1; <, >
allot-6
comma: jsr iar,*$next
here; store; two; allot; return
/ IMMEDIATE
.byte 11; <IMM>
comma-6
immediate:
jsr iar,*$next
latest; lit; .byte 200,0; toggle; return
/ SMUDGE
.byte 6; <SMU>
immediate-6
smudge: jsr iar,*$next
latest; lit; .byte 100,0; toggle; return
/ COMPILE
.byte 7; <COM>
smudge-6
compile:
jsr iar,*$next
fromr; dup; at; comma; two; plus; tor; return
/ IF
.byte 202; <IF > / immediate word
compile-6
if: jsr iar,*$next
compile; zbranch; here; two; allot; return
/ THEN
.byte 204; <THE>
if-6
then: jsr iar,*$next
here; swap; store; return
/ ELSE
.byte 204; <ELS>
then-6
else: jsr iar,*$next
compile; branch; here; two; allot; here; rot; store; return
/ BEGIN
.byte 205; <BEG>
else-6
begin: jsr iar,*$next
here; return
/ UNTIL
.byte 205; <UNT>
begin-6
until: jsr iar,*$next
compile; zbranch; comma; return
/ AGAIN
.byte 205; <AGA>
until-6
again: jsr iar,*$next
compile; branch; comma; return
/ WHILE
.byte 205; <WHI>
again-6
while: jsr iar,*$next
compile; zbranch; here; two; allot; return
/ REPEAT
.byte 206; <REP>
while-6
repeat: jsr iar,*$next
compile; branch; swap; comma; here; swap; store; return
/ DO
.byte 202; <DO >
repeat-6
do: jsr iar,*$next
compile; pdo; clue; at; zero; clue; store; here; return
/ LOOP
.byte 204; <LOO>
do-6
loop: jsr iar,*$next
compile; ploop; comma; clue; at; qdup; zbranch; 1f
here; swap; store
1: clue; store; return
/ +LOOP
.byte 205; <+LO>
loop-6
plusloop:
jsr iar,*$next
compile; pploop; comma; clue; at; qdup; zbranch; 1f
here; swap; store
1: clue; store; return
/ LEAVE
.byte 205; <LEA>
plusloop-6
leave: jsr iar,*$next
compile; pleave; here; clue; store; two; allot; return
/ [
.byte 201; <[ >
leave-6
lbracket:
jsr iar,*$next
zero; state; store; return
/ ]
.byte 1; <] >
lbracket-6
rbracket:
jsr iar,*$next
one; state; store; return
/ (
.byte 201; <( >
rbracket-6
paren: jsr iar,*$next
lit; .byte 051,0; word; drop; return
/ I/O words
/ TYPE ( addr count --- )
.byte 4; <TYP>
paren-6
type: jsr iar,*$next
stdout; write; drop; return
/ EMIT ( chr --- )
.byte 4; <EMI>
type-6
emit: jsr iar,*$next
atsp; one; type; drop; return
/ CR
.byte 2; <CR >
emit-6
cr: jsr iar,*$next
eol; emit; return
/ FQUERY ( fd --- actcount )
.byte 6; <FQU>
cr-6
fquery: jsr iar,*$next
zero; in; store;
tib; lit; .byte 120.,0; fexpect; return
/ COUNT
.byte 5; <COU>
fquery-6
count: jsr iar,*$next
dup; oneplus; swap; cat; return
/ ALIGN
.byte 5; <ALI>
count-6
align: jsr iar,*$next
oneplus; twoslash; twostar; return
/ (.")
.byte 4; <(.">
align-6
pdotquote:
jsr iar,*$next
fromr; count; twodup; type; plus; align; tor; return
/ ,WORD
.byte 5; <,WO>
pdotquote-6
commaword:
jsr iar,*$next
word; cat; oneplus; align; allot; return
/ ."
.byte 202; <." >
commaword-6
dotquote:
jsr iar,*$next
compile; pdotquote; lit; .byte 42,0; commaword; return
/ SPACE
.byte 5; <SPA>
dotquote-6
space: jsr iar,*$next
lit; .byte 40,0; emit; return
/ SPACES
.byte 6; <SPA>
space-6
spaces: jsr iar,*$next
qdup; zbranch; 2f
zero; pdo; 1: space; ploop; 1b
2: return
/ STRING ( adr[counted_string] --- adr[string] )
.byte 6; <STR>
spaces-6
string: jsr iar,*$next
count; dup; tor; pad; swap; cmove; zero; pad; fromr; plus;
cstore; pad; return
/ " ( --- adr[string] )
.byte 1; <" >
string-6
quote: jsr iar,*$next
lit; .byte 042,0; word; string; return
/ ("") ( --- adr[string] )
.byte 4; <("">
quote-6
pdquote:
jsr iar,*$next
fromr; dup; count; plus; align; tor; string; return
/ ""
.byte 202; <"" >
pdquote-6
dquote: jsr iar,*$next
compile; pdquote; lit; .byte 042,0; commaword; return;
/ Defining words
/ CFIELD
.byte 6; <CFI>
dquote-6
cfield: jsr iar,*$next
lit; .byte 6,0; plus; return
/ NFIELD
.byte 6; <NFI>
cfield-6
nfield: jsr iar,*$next
lit; .byte 6,0; minus; return
/ -IMM ( nfa --- cfa n )
.byte 4; <-IM>
nfield-6
notimm: jsr iar,*$next
dup; cfield; minusone; rot; cat; lit; .byte 0200,0; and
zbranch; 1f; negate; 1: return
/ FIND ( addr[name] --- addr2 n )
.byte 4; <FIN>
notimm-6
find: jsr iar,*$next
dup; context; at; at; pfind
qdup; zbranch; 1f; swap; drop; notimm; branch; 3f
1: dup; latest; pfind
qdup; zbranch; 2f; swap; drop; notimm; branch; 3f
2: zero
3: return
/ '
.byte 1; <' >
find-6
tic: jsr iar,*$next
here; lit; .byte 4,0; lit; .byte 40,0; fill
lit; .byte 40,0; word
find; zeroeq; zbranch; 1f; drop; zero; 1: return
/ HEADER
.byte 6; <HEA>
tic-6
header: jsr iar,*$next
tic; zbranch; 1f
wrn; at; zbranch; 1f
here; count; type
pdotquote; .byte 15; < isn't unique>; .even; cr
1: here; lit; .byte 4,0; allot; latest; comma; current; at; store;
return
/ CALL
.byte 4; <CAL>
header-6
call: jsr iar,*$next
lit; .byte 037,9; comma; return
/ :
.byte 1; <: >
call-6
colon: jsr iar,*$next
current; at; context; store;
header; call; compile; next; rbracket; smudge; return
/ ;
.byte 201; <; >
colon-6
semicolon:
jsr iar,*$next
compile; return; smudge; zero; state; store; return
/ VARIABLE
.byte 10; <VAR>
semicolon-6
variable:
jsr iar,*$next
header; call; compile; var; zero; comma; return
/ CONSTANT
.byte 10; <CON>
variable-6
constant:
jsr iar,*$next
header; call; compile; con; comma; return
/ 2VARIABLE
.byte 11; <2VA>
constant-6
twovar: jsr iar,*$next
variable; zero; comma; return
/ DOES>
.byte 5; <DOE>
twovar-6
does: jsr iar,*$next
fromr; latest; cfield; lit; .byte 4,0; plus; store; return
/ CREATE
.byte 6; <CRE>
does-6
create: jsr iar,*$next
header; call; compile; pdoes; zero; comma; does; return
/ VOCABULARY
.byte 12; <VOC>
create-6
vocabulary:
jsr iar,*$next
create; here; twoplus; comma; latest; comma
does; at; context; store; return
/ DEFINITIONS
.byte 13; <DEF>
vocabulary-6
definitions:
jsr iar,*$next
context; at; current; store; return
/ FORTH FORTH vocabulary
.byte 205; <FOR>
definitions-6
forth: jsr iar,*$next
initvocab; context; store; return
/ numeric output words
/ HLD
.byte 3; <HLD>
forth-6
hld: jsr iar,*$var
.byte 0,0
/ HOLD
.byte 4; <HOL>
hld-6
hold: jsr iar,*$next
minusone; hld; plusstore; hld; at; cstore; return
/ <#
.byte 2; <<# >
hold-6
lnum: jsr iar,*$next
pad; hld; store; return
/ #>
.byte 2; <#\> >
lnum-6
gnum: jsr iar,*$next
twodrop; hld; at; pad; over; minus; return
/ SIGN
.byte 4; <SIG>
gnum-6
sign: jsr iar,*$next
zeroless; zbranch; 1f; lit; .byte 055,0; hold; 1: return
/ #
.byte 1; <# >
sign-6
num: jsr iar,*$next
base; at; mslashmmod; rot; lit; .byte 11,0; over; less
zbranch; 1f; lit; .byte 7,0; plus; 1:
lit; .byte 060,0; plus; hold; return
/ #S
.byte 2; <#S >
num-6
nums: jsr iar,*$next
1: num; twodup; or; zeroeq; zbranch; 1b; return
/ D.R
.byte 3; <D.R>
nums-6
ddotr: jsr iar,*$next
tor; swap; over; dabs; lnum; nums; rot; sign; gnum;
fromr; over; minus; zero; max; spaces; type; return
/ ZEROES
.byte 6; <ZER>
ddotr-6
zeroes: jsr iar,*$next
zero; max; qdup; zbranch; 2f; zero; pdo; 1:
lit; .byte 060,0; emit; ploop; 1b
2: return
/ D.LZ
.byte 4; <D.L>
zeroes-6
ddotlz: jsr iar,*$next
tor; swap; over; dabs; lnum; nums; rot; sign; gnum
fromr; over; minus; zeroes; type; return
/ D.
.byte 2; <D. >
ddotlz-6
ddot: jsr iar,*$next
zero; ddotr; space; return
/ .R
.byte 2; <.R >
ddot-6
dotr: jsr iar,*$next
tor; stod; fromr; ddotr; return
/ .
.byte 1; <. >
dotr-6
dot: jsr iar,*$next
stod; ddot; return
/ U.R
.byte 3; <U.R>
dot-6
udotr: jsr iar,*$next
zero; swap; ddotr; return
/ U.LZ
.byte 4; <U.L>
udotr-6
udotlz: jsr iar,*$next
zero; swap; ddotlz; return
/ utilities
/ [COMPILE]
.byte 211; <[CO>
udotlz-6
bcompile:
jsr iar,*$next
tic; comma; return
/ DUMP ( addr bytes --- )
.byte 4; <DUM>
bcompile-6
dump: jsr iar,*$next
cr; over; plus; swap; pdo; 1:
i; lit; .byte 4,0; udotlz; pdotquote; .byte 1; <:>; .even
space
i; lit; .byte 8,0; plus; i; pdo; 2:
i; cat; two; udotlz; space; ploop; 2b
i; lit; .byte 8,0; plus; i; pdo; 3:
i; cat; dup; lit; .byte 040,0; less;
over; lit; .byte 177,0; equal; or
zbranch; 4f; drop; lit; .byte 056,0; 4:
emit; ploop; 3b
cr; lit; .byte 8,0; pploop; 1b
return
/ operating system support words
/ DIGIT ( char --- n true <or> false )
.byte 5; <DIG>
dump-6
digit: jsr iar,*$next
lit; .byte 60,0; minus
dup; lit; .byte 11,0; greater; over; lit; .byte 21,0; less; and
zbranch; 1f
drop; false; branch; 4f
1: dup; lit; .byte 11,0; ugreater; zbranch; 2f
lit; .byte 7,0; minus
2: dup; base; at; oneminus; ugreater; zbranch; 3f
drop; false; branch; 4f
3: true
4: return
/ CONVERT ( dl dh addr1 --- dl' dh' addr2 )
.byte 7; <CON>
digit-6
convert:
jsr iar,*$next
tor; 1:
fromr; oneplus; dup; tor; cat; digit;
zbranch; 2f; tor; base; at; umstarm; fromr; zero; dplus
branch; 1b
2: fromr; return
/ NUMBER ( ADDR --- N TRUE <OR> FALSE )
.byte 6; <NUM>
convert-6
number: jsr iar,*$next
dup; oneplus; cat; lit; .byte 055,0; equal; dup; tor; minus
zero; zero; rot; convert
cat; lit; .byte 040,0; equal; zbranch; 1f
drop; fromr; plusminus; true; branch; 2f
1: twodrop; fromr; drop; false
2: return
/ ?STACK ( --- T/F ) ( returns true if stack underflow )
.byte 6; <?ST>
number-6
qstack: jsr iar,*$next
atsp; sp0; greater; return
/ CHUCKBUF ( chuck rest of input buffer )
.byte 10; <CHU>
qstack-6
chuckbuf:
jsr iar,*$next
tib; in; at; plus
1: dup; cat; eol; nequal; zbranch; 2f; oneplus
branch; 1b
2: tib; minus; in; store; return
/ ENDINTERP ( --- ) ( flush reset of input buffer )
.byte 11; <END>
chuckbuf-6
endinterp:
jsr iar,*$next
sp0; storesp; / reset stack pointer
chuckbuf; return
/ INTERPRET
.byte 11; <INT>
endinterp-6
interpret:
jsr iar,*$next
1: here; lit; .byte 4,0; lit; .byte 040,0; fill
lit; .byte 040,0; word; cat; zbranch; 9f
here; find; qdup; zbranch; 4f
state; at; plus
zbranch; 2f; execute; branch; 3f; 2: comma; 3:
branch; 7f
4: number; zbranch; 6f
state; at; zbranch; 5f; compile; lit; comma; 5:
branch; 7f
6: here; count; type; pdotquote; .byte 2; < ?>; .even; cr
endinterp
7: qstack; zbranch; 8f; pdotquote; .byte 14; < Stack empty>; .even; cr
endinterp; 8:
branch; 1b;
9: return
/ FLOAD ( adr[string] --- )
.byte 5; <FLO>
interpret-6
fload: jsr iar,*$next
zero; open; dup; zeroless; zbranch; 0f
drop; pdotquote; .byte 13; < can't open>; .even; cr; branch; 3f
0: tor
1: rat; fquery; zbranch; 2f; interpret; branch; 1b
2: fromr; close; chuckbuf
3: return
/ QUIT
.byte 4; <QUI>
fload-6
quit: jsr iar,*$next
zero; state; store; sp0; storesp
cr; pdotquote; .byte 23.; <unix-FORTH, version 1.0>; .even
1: cr; stdin; fquery; zbranch; 3f
interpret
state; at; zeroeq; zbranch; 2f; pdotquote; .byte 3; < OK>;
.even
2: branch; 1b
3: cr; terminate; return
/ the reset of the dictionary
dict: .=.+20000. / TEST
+E+O+Flwt1@aplvax.UUCP (06/08/84)
Here is part 5 of the source for FORTH for the PDP-11.
Delete everything thru the "-- cut here --" line, and extract with 'sh':
sh part1 part2 ... part7
where 'part?' are whatever you've named the files. Note the copyright
notice at the end of README. Please let us know how things go. While
we can't support this software, we'll be posting bug fixes/upgrades to
net.sources as time permits.
VAX-FORTH should be 'forth'-coming {yuk-yuk} within a couple of weeks.
Have fun!
-Lloyd W. Taylor
... seismo!umcp-cs!aplvax!lwt1
---I will have had been there before, soon---
---------------------------------- cut here ----------------------------------
echo x - METAASM
cat >METAASM <<'+E+O+F'
( FORTH PDP-11 ASSEMBLER ) OCTAL
VARIABLE *OPCODE ( VARIABLE POINTS TO LATEST OPCODE )
: CODE ( CREATES A CODE DEFINITION )
HEADER HOST-->META ;
: OPBUILD ( OPERANDFIELD --- ) ( ADDS OPERAND FIELD )
( CONSISTING OF ADDRESSING MODE AND REGISTER)
( TO LATEST OPCODE. )
*OPCODE FORTH @ DUP HOST @ ( OPERAND OPADDR OPCODE )
6 ROTATE ROT OR SWAP ! ;
: BYTE ( --- ) ( CONVERTS MOST RECENT OPCODE TO )
( BYTE ADDRESSING. MUST BE USED AT END OF )
( ASSEMBLY LANGUAGE LINE. )
*OPCODE FORTH @
HOST DUP @ 100000 OR SWAP ! ;
: MNEMONIC ( OPCODE --- ) ( DEFINING WORD DEFINES )
( MNEMONIC. WORDS DEFINED WITH MNEMONIC )
( COMMA THEIR OPCODES INTO THE DICTION- )
( ARY WHEN EXECUTED. )
CREATE FORTH , HOST ( SAVE OPCODE )
DOES> HERE *OPCODE FORTH ! @ HOST , ;
( SAVE OPCODE ADDRESS; COMMA OPCODE INTO DIC )
( ADDRESSING MODES )
: REG ( REG# --- ) ( REGISTER ADDRESSING )
OPBUILD ;
: ) ( REG# --- ) ( REGISTER DEFERRED )
10 OR OPBUILD ;
: )+ ( REG# --- ) ( AUTO-INCREMENT )
20 OR OPBUILD ;
: *)+ ( REG# --- ) ( AUTO-INCREMENT DEFERRED )
30 OR OPBUILD ;
: -( ( REG# --- ) ( AUTO-DECREMENT )
40 OR OPBUILD ;
: *-( ( REG# --- ) ( AUTO-DECREMENT DEFERRED )
50 OR OPBUILD ;
: X( ( OFFSET REG# --- ) ( INDEXED ADDRESSING )
60 OR OPBUILD , ;
: *X( ( OFFSET REG# --- ) ( INDEX DEFERRED )
70 OR OPBUILD , ;
: $ ( IMMEDIATE --- ) ( IMMEDIATE )
27 OPBUILD , ;
: *$ ( ADDR --- ) ( ABSOLUTE )
37 OPBUILD , ;
: REL ( ADDR --- ) ( RELATIVE )
67 OPBUILD
*OPCODE FORTH @ HOST - 4 - , ;
: *REL ( ADDR --- ) ( RELATIVE DEFERRED )
77 OPBUILD
*OPCODE FORTH @ HOST - 4 - , ;
: REG-ONLY ( REG# --- ) ( FOR REGISTER ONLY INSTRUC- )
( TIONS SUCH AS MUL OR DIV. )
*OPCODE FORTH @ DUP HOST @ ( REG# OPADDR OPCODE )
3 ROTATE ROT OR SWAP ! ;
( LOCAL LABELS: EIGHT LOCAL LABELS ARE ALLOWED NUMBERED FROM 0 TO 7 )
( ONLY ONE FORWARD BRANCH PER LABEL IS ALLOWED. ANY NUMBER OF BACK- )
( WARD BRANCHES IS ALLOWED. )
VARIABLE LTABLE FORTH 0 , 10 1- 4 * ALLOT HOST
LTABLE 10 4 * 0 FILL ( LABEL TABLE )
: FWD ( LABEL# --- ) ( LEAVE ADDRESS IN TABLE. )
HERE SWAP 2* 2* LTABLE + 2+ FORTH ! HOST ;
: BACK ( LABEL# --- ) ( ADD OFFSET TO PREVIOUSLY )
( COMPILED WORD. )
2* 2* LTABLE + FORTH @ HOST HERE - 2/ 377 AND HERE 2- DUP @ ROT OR SWAP ! ;
: L: ( LABEL# --- ) ( RESOLVE FORWARD BRANCHES, )
( PURGE TABLE, AND ADD CURRENT ADDRESS. )
2* 2* LTABLE + DUP 2+ FORTH @ ?DUP IF ( IF LABEL NEEDS RESOLUTION )
HOST HERE OVER - 2/ 377 AND SWAP 2- DUP @ ROT OR SWAP ! THEN
0 OVER 2+ FORTH ! ( OLD LABEL ADDRESS IS DEFUNCT )
HOST HERE SWAP FORTH ! HOST ; ( CURRENT ADDRESS )
( MNEMONICS )
050 MNEMONIC CLR 051 MNEMONIC COM 052 MNEMONIC INC
053 MNEMONIC DEC 054 MNEMONIC NEG 057 MNEMONIC TST
060 MNEMONIC ROR 061 MNEMONIC ROL 062 MNEMONIC ASR
063 MNEMONIC ASL 003 MNEMONIC SWB 055 MNEMONIC ADC
056 MNEMONIC SBC 067 MNEMONIC SXT 01 MNEMONIC MOV
02 MNEMONIC CMP 06 MNEMONIC ADD 16 MNEMONIC SUB
03 MNEMONIC BIT 04 MNEMONIC BIC 05 MNEMONIC BIS
074 MNEMONIC EXOR 070 MNEMONIC MUL 071 MNEMONIC DIV
001 MNEMONIC JMP 004 MNEMONIC JSR 020 MNEMONIC RTS
261 MNEMONIC SEC
002 MNEMONIC RTI
000400 MNEMONIC BR 001000 MNEMONIC BNE 001400 MNEMONIC BEQ
100000 MNEMONIC BPL 100400 MNEMONIC BMI 102000 MNEMONIC BVC
102400 MNEMONIC BVS 103000 MNEMONIC BCC 103400 MNEMONIC BCS
002000 MNEMONIC BGE 002400 MNEMONIC BLT 003000 MNEMONIC BGT
003400 MNEMONIC BLE 101000 MNEMONIC BHI 101400 MNEMONIC BLOS
103000 MNEMONIC BHIS 103400 MNEMONIC BLO
( SOB: SUBTRACT ONE AND BRANCH INSTRUCTION )
: SOB ( LABEL# REG# --- )
6 ROTATE 77000 OR
HERE 2+ ROT 2* 2* LTABLE + FORTH @ HOST - 2/ OR , ;
: TRAP ( TRAP# --- )
104400 + , ;
( MACROS )
4 CONSTANT IAR 5 CONSTANT PSP 6 CONSTANT SP
7 CONSTANT PC
: NEXT ( --- ) ( COMPILES CODE FOR NEXT )
JMP IAR *)+ ;
+E+O+F
echo x - META1
cat >META1 <<'+E+O+F'
( METACOMPILER, PART 1 -- ALLOWS METACOMPILATION OF PRIMITIVES ) HEX
: METACOMPILER ; ( MARK BEGINNING OF METACOMPILER FOR 'FORGET')
( METACOMPILER DATABASE )
VARIABLE OBJLINK ( OBJECT SYSTEM VOCABULARY POINTER )
2VARIABLE WDS ( OBJECT SYSTEM HEADER LENGTH IN BYTES )
VARIABLE W0 ( BASE OF OBJECT DICTIONARY SPACE )
VARIABLE 'H ( OBJECT SYSTEM DICTIONARY POINTER )
VARIABLE 'R ( OBJECT SYSTEM RAM POINTER )
VARIABLE RAMOBJECT ( TRUE=RAM OBJECT, FALSE=PROM OBJECT )
VARIABLE METASTATE ( TRUE=METACOMPILE, FALSE=EXECUTE )
0 METASTATE !
VARIABLE METAMP ( METACOMPILER MAPPING ENABLE/DISABLE )
: METAMAP TRUE METAMP ! ;
: NOMETAMAP FALSE METAMP ! ;
VARIABLE WRNMETA ( METACOMPILER WARNING ENABLE/DISABLE )
: METAWARN TRUE WRNMETA ! ;
: NOMETAWARN FALSE WRNMETA ! ;
VOCABULARY META IMMEDIATE
VOCABULARY HOST IMMEDIATE HOST DEFINITIONS
: VOCSSAVE ( --- V1 V2 ) ( SAVE VOCABS ON STACK )
CONTXT @ CURRENT @ ;
: VOCSRESTORE ( V1 V2 --- ) ( UNDO 'VOCSSAVE' )
CURRENT ! CONTXT ! ;
: PREVIOUS ( --- N ) ( PRODUCES THE CONTENTS OF THE FIRST WORD OF )
( THE PARAMETER FIELD OF THE MOST RECENT DEFINTION IN )
( VOCABULARY META. IF THIS WAS AN 'EMPLACE' DEFINTION, THE )
( VALUE RETURNED WILL BE THE TARGET SYSTEM OPCODE OF THE )
( EMPLACE WORD. THIS IS USEFUL FOR IMMEDIATING. )
VOCSSAVE
[COMPILE] META DEFINITIONS
LATEST CFIELD 6 + @ -ROT
VOCSRESTORE ;
: FIND ( ADDR[NAME] --- ADDR2 N ) ( DICTIONARY SEARCH )
( RESTRICTED TO VOCABULARY 'META' )
VOCSSAVE >R >R ( SAVE CONTEXT, CURRENT ON RET STACK )
[COMPILE] META DEFINITIONS ( SELECT META VOCABULARY )
FIND ( SEARCH DICTIONARY )
R> R> VOCSRESTORE ; ( RESTORE CURRENT AND CONTEXT )
: HOST-->META ( --- ) ( UNLINK LATEST ENTRY IN VOCABULARY 'HOST' AND )
( RELINK IT INTO VOCABULARY 'META'. )
VOCSSAVE ( SAVE CONTEXT AND CURRENT ON STACK )
[COMPILE] HOST DEFINITIONS ( SET CONTEXT AND CURRENT TO 'HOST' )
LATEST DUP 4 + @ CURRENT @ ! ( MOVE BACK 'HOST' VOCAB POINTER )
[COMPILE] META DEFINITIONS ( SET CONTEXT AND CURRENT TO 'META' )
LATEST @ 4D84 = ( SET LINK OF FIRST ENTRY IN 'META' )
IF 0 ELSE LATEST ( [I.E., THE ONE AFTER 'META' ITSELF])
THEN OVER 4 + ! ( TO 0, ELSE LINK NORMALLY )
CURRENT @ ! ( MOVE UP 'META' VOCAB POINTER )
VOCSRESTORE ; ( RESTORE OLD CURRENT AND CONTEXT )
: METASMUDGE ( --- ) ( SMUDGE THE MOST RECENT META DEFINITION )
VOCSSAVE
[COMPILE] META DEFINITIONS SMUDGE
VOCSRESTORE ;
: HERE 'H @ ; ( --- N ) ( RETURN VALUE OF OBJECT DICTIONARY POINTER )
: RAMHERE ( --- N ) ( RETURN VALUE OF OBJECT RAM POINTER )
RAMOBJECT @ IF HERE ELSE 'R @ THEN ;
: ALLOT ( N --- ) ( ALLOT 'N' WORDS OF OBJECT DICTIONARY SPACE )
'H +! ;
: RAMALLOT ( N --- ) ( ALLOT 'N' WORDS OF OBJECT RAM SPACE )
RAMOBJECT @
IF ALLOT
ELSE 'R +!
THEN ;
: RAM ( N --- ) ( SET RAMOBJECT FLAG TRUE [RAM], INITIALIZE )
( 'H, W0 AND 'R TO N, AND ZERO ENTIRE OBJECT DICTIONARY. )
( 'H, W0 AND 'R TO N, OBJLINK TO 0, AND ZERO ENTIRE )
( OBJECT DICTIONARY. )
TRUE RAMOBJECT !
DUP 'H ! DUP W0 ! 'R ! 0 OBJLINK ! ;
: PROM ( N --- ) ( SET RAMOBJECT FLAG FALSE [PROM], INITIALIZE )
( 'H AND W0 TO N, OBJLINK TO 0, OBJECT DICTIONARY TO 0'S. )
FALSE RAMOBJECT !
DUP 'H ! W0 ! 0 OBJLINK ! ;
: NOHEAD 0 WDS ! ; ( --- ) ( MAKE NEXT OBJECT DEFINITION HEADLESS )
: HEADS 6 6 WDS 2! ; ( --- ) ( FOLLOWING OBJECT DEFINITIONS HAVE HEADS )
: NOHEADS 0 0 WDS 2! ; ( --- ) ( FOLLOWING OBJECT DEFINITIONS HEADLESS )
( CODE FOR HANDLING META-COMPILATION RANDOM ACCESS FILES ) DECIMAL
VARIABLE BUFFER 510 FORTH ALLOT HOST
BUFFER 512 0 FILL
VARIABLE DIRTY ( TRUE IF BUFFER IS INCONSISTENT )
FALSE DIRTY ! ( WITH DISK FILE. )
VARIABLE IMAGE ( HOLDS TARGET ADDRESS THAT COR- )
-1 IMAGE ! ( RESPONDS TO BUFFER. )
VARIABLE FILED ( FILE DESCRIPTOR OF META OBJECT FILE)
: ?FLUSH ( --- ) ( FLUSH BUFFER IF DIRTY )
( FLAG SET. )
DIRTY @ IF
FILED @ IMAGE @ 0 SEEK ( SEEK POSITION IN FILE FOR BUFFER )
BUFFER 512 FILED @ WRITE DROP ( WRITE BACK TO DISK )
FALSE DIRTY ! ( BUFFER IS CONSISTENT WITH DISK )
THEN ;
: GET ( ADDR --- ) ( TRIES TO READ 512 )
( BYTES FROM DISK AT ADDR AND PUTS )
( INTO BUFFER. )
BUFFER 512 0 FILL ( ZERO BUFFER )
DUP IMAGE ! ( RECORD ADDRESS )
FILED @ SWAP 0 SEEK ( POSITION FILE READ POINTER )
FILED @ BUFFER 512 READ DROP ; ( TRY TO READ 512 BYTES )
HEX
: T->R ( ADDR --- ADDR' ) ( TRANSLATES )
( TARGET ADDRESS IN ADDRESS IN )
( BUFFER. DOES BUFFER FLUSHING )
( AND READING IF NECESSARY. )
10 + ( SKIP A.OUT HEADER )
DUP 1FF AND SWAP FE00 AND ( OFFSET 512*BLOCK# )
DUP IMAGE @ = IF ( IF ALREADY IN RAM )
DROP ( DO NOTHING )
ELSE
?FLUSH GET ( ELSE GET NEEDED BLOCK )
THEN BUFFER + ;
: C@ ( ADDR --- BYTE )
T->R C@ ;
: C! ( BYTE ADDR --- )
T->R C! TRUE DIRTY ! ;
: @ ( ADDR --- WORD )
DUP 1+ C@ 8 ROTATE ( FETCH HIGH BYTE FIRST )
SWAP C@ OR ; ( THEN FETCH LOW BYTE )
: ! ( WORD ADDR --- )
>R DUP FF AND R@ C! ( STORE LOW BYTE )
FF00 AND 8 ROTATE R> 1+ C! ; ( STORE HIGH BYTE )
: , ( WORD --- )
HERE ! 2 ALLOT ;
: .O ( N --- ) ( PRINT N IN OCTAL WITHOUT CHANGEING BASE. )
BASE FORTH @ OCTAL SWAP . BASE ! HOST ;
: EMPLACE ( --- ) ( LOGS AND CREATES A WORD WHOSE PARAMETER FIELD )
( CONTAINS THE TARGET ADDRESS OF THE NEXT CODE FIELD IN THE )
( TARGET SPACE. WHEN THE WORD IS EXECUTED, THIS VALUE )
( [PRESUMABLY THE OPCODE OF THE 'EMPLACED' WORD] IS )
( COMPILED INTO THE OBJECT DICTIONARY. )
HERE FORTH WDS @ + ( HEADER? )
FORTH METAMP @
IF
DUP .O HERE COUNT TYPE CR ( PRINT CFA[OCTAL] AND NAME )
THEN
CREATE , DOES> @ HOST , ;
: HEADER ( --- ) ( CREATES AN OBJECT DICTIONARY ENTRY AND A )
( CORRESPONDING 'EMPLACE' ENTRY IN THE HOST VOCABULARY. )
WRNMETA FORTH @ HOST ( CHECK METAWARNING FLAG )
IF >IN FORTH @ ( SAVE INPUT POINTER )
HERE 4 20 FILL 20 WORD HOST FIND ( SEARCH META FOR NEW WORD )
IF FORTH HERE COUNT TYPE ( PRINT WARNING IF WORD FOUND)
SPACE ." isn't unique [Meta]" CR
THEN DROP
>IN ! HOST ( RESTORE INPUT POINTER )
THEN
EMPLACE ( CREATE 'EMPLACE' ENTRY )
WDS FORTH @ HOST ( TEST FOR OBJ HDR CREATION )
IF HERE FORTH LATEST @ HOST , ( OBJECT HEADER, 1ST WORD )
FORTH LATEST 2+ @ HOST , ( OBJECT HEADER, 2ND WORD )
OBJLINK FORTH @ HOST , ( OBJECT LINK FIELD )
OBJLINK FORTH ! HOST ( UPDATE PTR TO OBJECT VOCAB )
THEN WDS 2+ FORTH @ WDS ! HOST ; ( RESET TEMP HEADER LENGTH )
: LABEL
HERE METAMP FORTH @ IF
DUP .O ( PRINT ADDRESS OF LABEL )
>IN @ ( PEEK AHEAD INTO INPUT STREAM )
20 WORD COUNT TYPE ." Label" CR
>IN !
THEN
CONSTANT HOST ;
: ' ( --- CFA <OR> 0 ) ( RETURNS CFA OF TARGET WORD THAT FOLLOWS)
FORTH HERE 4 20 FILL
HOST 20 WORD FIND
IF 6 + FORTH @ HOST
ELSE DROP 0
THEN ;
: DUMPOBJ ( ADDR N --- ) ( DUMPS N WORDS OF OBJECT SPACE FROM ADDR )
CR OVER + SWAP
DO
I 4 U.LZ ." :" SPACE
I 8 + I DO
I C@ 2 U.LZ SPACE
LOOP
I 8 + I DO
I C@ DUP 20 < OVER 7F = OR
IF DROP 2E THEN
EMIT
LOOP
CR
8 +LOOP ;
( CODE FOR CLEANING UP AFTER A METACOMPILATION )
VARIABLE A.OUT ( A.OUT HEADER )
FORTH 107 A.OUT ! 0 , 0 , 0 , 0 , 0 , 0 , 1 , HOST
: CLEANUP ( FREE_DICT_SIZE --- ) ( CLEANS UP )
( AFTER A METACOMPILATION. MAKES )
( DISK IMAGE FILE GROW UNTIL IT HAS )
( AT LEAST THE FREE_DICT_SIZE ASKED )
( FOR. WRITES THE A.OUT HEADER OUT. )
HERE + 10 + 200 + FE00 AND ( COMPUTE UPPER LIMIT DISK ADDRESS )
HERE 10 + ( COMPUTE LOWER LIMIT DISK ADDRESS )
DO 0 , LOOP ( GROW DICTIONARY )
?FLUSH
HERE A.OUT 2+ FORTH ! ( SIZE OBJECT SIZE IN A.OUT )
FILED @ 0 0 SEEK ( REWIND FILE )
A.OUT 10 FILED @ WRITE DROP ( WRITE A.OUT HEADER TO DISK )
FILED @ CLOSE HOST ;
+E+O+F
echo x - META2
cat >META2 <<'+E+O+F'
( METACOMPILER, PART 2 -- ALLOWS METACOMPILATION OF : DEFINITIONS, ) HEX
( VARIABLES AND CONSTANTS IN A SINGLE VOCABULARY )
: ] ( --- ) ( MAIN METACOMPILER INTERPRETATION LOOP )
TRUE METASTATE FORTH !
BEGIN
FORTH >IN @ 20 WORD SWAP >IN !
C@ METASTATE @ AND WHILE
HERE 4 20 FILL 20 WORD HOST FIND IF
EXECUTE
ELSE
NUMBER IF
META (LITERAL) HOST ,
ELSE
FORTH HERE COUNT TYPE ." ? [Meta]" CR ENDINTERP
THEN
THEN
?STACK IF ." Stack empty [Meta]" CR ENDINTERP THEN
REPEAT ; HOST
: FLOAD ( --- ) ( METACOMPILER LOADER; CONTINUES META : DEFINITIONS )
0 OPEN
DUP 0< IF
DROP ." can't open" CR
ELSE
>R BEGIN
R@ FQUERY WHILE
METASTATE FORTH @ HOST IF
]
THEN INTERPRET
REPEAT R> CLOSE CHUCKBUF
THEN ;
( METACOMPILER DIRECTIVES )
: ( 29 WORD DROP ; HOST-->META ( START OF COMMENT )
: [ ( --- ) ( EXIT METACOMPILER LOOP ']' )
FORTH FALSE METASTATE ! HOST ; HOST-->META
: IF META ?BRANCH HOST HERE 0 , ; HOST-->META
: WHILE META IF HOST ; HOST-->META
: ELSE META BRANCH HOST HERE 0 , HERE ROT ! ; HOST-->META
: THEN HERE SWAP ! ; HOST-->META
: DO META (DO) FORTH CLUE @ 0 CLUE ! HOST HERE ; HOST-->META
: LOOP META (LOOP) HOST ,
FORTH CLUE @ ?DUP IF HOST HERE SWAP ! THEN
FORTH CLUE ! HOST ; HOST-->META
: +LOOP META (+LOOP) HOST ,
FORTH CLUE @ ?DUP IF HOST HERE SWAP ! THEN
FORTH CLUE ! HOST ; HOST-->META
: LEAVE META (LEAVE) HOST HERE FORTH CLUE ! HOST 0 , ; HOST-->META
: BEGIN HERE ; HOST-->META
: UNTIL META ?BRANCH HOST , ; HOST-->META
: AGAIN META BRANCH HOST , ; HOST-->META
: REPEAT META BRANCH HOST SWAP , HERE SWAP ! ; HOST-->META
: ; META (;) HOST HOST-->META
FORTH FALSE METASTATE ! HOST ; HOST-->META
( METACOMPILER IMMEDIATOR )
: IMMEDIATE ( --- ) ( TOGGLES IMMEDIATE BIT IN LATEST TARGET HEAD)
PREVIOUS NFIELD DUP C@ 80 OR
SWAP C! ;
( DEFINING WORDS )
: CALL ( --- ) ( COMPILE JSR IAR,*$--- INTO TARGET CODE. )
091F , ;
: \CONSTANT ( N --- ) ( DEFINES THE NEXT INPUT WORD AS A CONSTANT )
( 'N' IN THE RESIDENT SYSTEM'S CURRENT VOCABULARY )
( WITHOUT MOVING THE INPUT POINTER '>IN'. )
>IN FORTH @ SWAP CONSTANT >IN ! ; HOST
: CONSTANT
DUP \CONSTANT
HEADER CALL META (CONSTANT) HOST , HOST-->META ;
: :
HEADER CALL META (:) HOST ] ;
FORTH : VARIABLE ( --- ) ( CREATES OBJECT VARIABLE INIT'ED TO 0 )
RAMOBJECT FORTH @ HOST
IF HERE CFIELD 4 + \CONSTANT ( RAM VERSION )
HEADER CALL META (VARIABLE) HOST 0 , HOST-->META
ELSE RAMHERE CONSTANT 2 RAMALLOT ( PROM VERSION )
THEN ;
FORTH : 2VARIABLE ( --- ) ( CREATES OBJECT 2VARIABLE INIT'ED TO 0 )
VARIABLE
RAMOBJECT FORTH @ HOST
IF 0 , ( RAM VERSION )
ELSE 2 RAMALLOT ( PROM VERSION )
THEN ;
+E+O+Flwt1@aplvax (06/08/84)
Here is part 6 of the source for FORTH for the PDP-11.
Delete everything thru the "-- cut here --" line, and extract with 'sh':
sh part1 part2 ... part7
where 'part?' are whatever you've named the files. Note the copyright
notice at the end of README. Please let us know how things go. While
we can't support this software, we'll be posting bug fixes/upgrades to
net.sources as time permits.
VAX-FORTH should be 'forth'-coming {yuk-yuk} within a couple of weeks.
Have fun!
-Lloyd W. Taylor
... seismo!umcp-cs!aplvax!lwt1
---I will have had been there before, soon---
---------------------------------- cut here ----------------------------------
echo x - auto
cat >auto <<'+E+O+F'
( automated meta-compilation file )
" META1" FLOAD
" METAASM" FLOAD
" newforth" -1 CREAT CLOSE
" newforth" 2 OPEN DUP . FORTH FILED ! ( object file )
0 WRN ! HOST
0 RAM HEADS METAMAP METAWARN
" SYS:ASM" FLOAD
" META2" FLOAD
" SYS:SRC" FLOAD
DECIMAL 20000 CLEANUP ( allot 20000 byte dictionary )
+E+O+F
echo x - SYS:ASM
cat >SYS:ASM <<'+E+O+F'
( Copyright 1984 by The Johns Hopkins University/Applied Physics Lab. )
( Free non-commercial distribution is *encouraged*, provided that: )
( )
( 1. This copyright notice is included in any distribution, and )
( 2. You let us know that you're using it. )
( )
( Please notify: )
( )
( Lloyd W. Taylor )
( JHU/Applied Physics Lab )
( Johns Hopkins Road )
( Laurel, MD 20707 )
( [301] 953-5000 )
( )
( Usenet: ... seismo!umcp-cs!aplvax!lwt1 )
( )
( )
( Unix-FORTH was developed under NASA contract NAS5-27000 for the )
( Hopkins Ultraviolet Telescope, a March 1986 Space Shuttle mission. )
( {We hope to take a peek at Halley's comet!} )
( )
( Written entirely by Wizard-In-Residence John R. Hayes. )
( )
( * Unix is a trademark of Bell Labs. )
( FORTH ASSEMBLY LANGUAGE SOUCE CODE ) OCTAL
( THIS IS SOURCE CODE TO BE RUN THROUGH THE METACOMPILER - METAASSEMBLER. )
( THEREFORE, THERE ARE DIFFERENCES BETWEEN THIS SOURCE CODE AND SOURCE )
( CODE TO BE ASSEMBLED IN THE ORDINARY WAY. IN PARTICULAR, THERE IS NO )
( IMPLICIT OR EXPLICIT SMUDGING. )
JMP 0 *$ ( JUMP TO STARTUP; WILL BE BACKPATCHED )
LABEL vector
MOV 0 $ IAR REG ( MOVE ABORT TO IAR; WILL BE BACKPATCHED )
60 TRAP 2 , vector ,
NEXT
( VARIABLES AND DATA BUFFERS )
LABEL rsp0 0 , ( INITIAL VALUE OF RETURN STACK POINTER )
LABEL in 0 , ( >IN: INPUT PARSER )
LABEL initvocab 0 , ( INITIAL FORTH VOCABULARY )
LABEL dp 0 , ( END OF DICTIONARY POINTER )
400 RAMALLOT ( 256 BYTE PARAMETER STACK )
LABEL inbuf
DECIMAL 120 RAMALLOT ( 120 BYTES OF INPUT BUFFER )
OCTAL
( INNER INTERPRETER AND LOW-LEVEL RUN TIME WORDS )
CODE (:) ( CODE FOR NEXT )
JMP IAR *)+
( THE CODE FOR CALL IS COMPILED IN-LINE FOR COLON DEFINITIONS. )
( )
( JSR IAR,*$NEXT
( )
CODE (;)
MOV SP )+ IAR REG
NEXT
( THIS IS TRICKY CODE. ALL WORDS DEFINED BY VARIABLE, CONSTANT, OR )
( <BUILDS .. DOES> WORDS WILL HAVE SIMILAR CODE FIELDS. THEREFORE, THE )
( CODE FOR [VARIABLE], [CONSTANT], AND [DOES>] IS SHOW BELOW. )
( EXAMPLE: CODE COMPILED FOR VARIABLE WILL BE: )
( JSR IAR,*$[VARIABLE] )
CODE (VARIABLE)
MOV IAR REG PSP -(
MOV SP )+ IAR REG
NEXT
CODE (CONSTANT)
MOV IAR ) PSP -(
MOV SP )+ IAR REG
NEXT
CODE (DOES>)
MOV IAR )+ 0 REG
MOV IAR REG PSP -(
MOV 0 REG IAR REG
NEXT
( BRANCHING PRIMITIVES )
CODE (LITERAL)
MOV IAR )+ PSP -(
NEXT
CODE BRANCH
MOV IAR ) IAR REG
NEXT
CODE ?BRANCH
MOV PSP )+ 0 REG
BNE 1 FWD
MOV IAR ) IAR REG
JMP IAR *)+ ( NEXT )
1 L: ADD 2 $ IAR REG
NEXT
CODE EXECUTE
JMP PSP *)+
( FORTH-83 DO LOOPS )
CODE (DO)
MOV PSP )+ 1 REG
MOV PSP )+ 0 REG
ADD 100000 $ 0 REG ( LIMIT' := LIMIT + 8000 )
MOV 0 REG SP -(
SUB 0 REG 1 REG ( IINIT' := INIT - LIMIT' )
MOV 1 REG SP -(
NEXT
CODE (LOOP)
INC SP )
BVS 1 FWD
MOV IAR ) IAR REG ( LOOP BACK )
JMP IAR *)+ ( NEXT )
1 L: ADD 4 $ SP REG ( POP RETURN STACK )
ADD 2 $ IAR REG ( SKIP LOOP ADDRESS )
NEXT
CODE (+LOOP)
ADD PSP )+ SP )
BVS 1 FWD
MOV IAR ) IAR REG ( LOOP BACK )
JMP IAR *)+ ( NEXT )
1 L: ADD 4 $ SP REG ( POP RETURN STACK )
ADD 2 $ IAR REG ( SKIP LOOP ADDRESS )
NEXT
CODE I
MOV SP ) 0 REG
ADD 2 SP X( 0 REG ( I := I' + LIMIT' )
MOV 0 REG PSP -(
NEXT
CODE J
MOV 4 SP X( 0 REG
ADD 6 SP X( 0 REG ( J := J' + LIMIT' )
MOV 0 REG PSP -(
NEXT
CODE (LEAVE)
ADD 4 $ SP REG ( POP RETURN STACK )
MOV IAR ) IAR REG ( BRANCH PAST LOOP )
NEXT
( BASIC UNIX SYSTEM INTERFACE ROUTINES )
( BUFFER FOR HOLDING INDIRECT SYSTEM CALLS )
LABEL SYSBUF 0 , ( TRAP INSTRUCTION )
0 , ( ARGUMENT 1 )
0 , ( ARGUMENT 2 )
0 , ( ARGUMENT 3 )
( DATA AND CODE FOR SPAWNING OFF SUBPROCESSES )
HEX
LABEL STATUS 0 , ( WORD FOR RECEIVING RETURN STATUS OF CHILD )
LABEL NAME 622F , 6E69 , 732F , 68 , ( "/bin/sh" )
LABEL 0ARG 6873 , 0 , ( "sh" )
LABEL 1ARG 632D , 0 , ( "-c" )
LABEL ARGV 0ARG , 1ARG , 0 , 0 , ( ARGUMENT LIST )
OCTAL
CODE SHELL ( --- ) ( SPAWN OFF INTERACTIVE SUB-SHELL )
CLR ARGV 2+ *$ ( sh WITH NO ARGUMENTS )
0 L: ( SPAWN SUB-PROCESS. SYSTEM BELOW SHARES THIS CODE )
2 TRAP ( FORK SYSTEM CALL )
BR 2 FWD ( BRANCH TO CHILD PROCESS CODE )
60 TRAP 2 , 1 , ( IGNORE INTERRUPTS )
MOV 0 REG 2 REG ( SAVE OLD VECTOR )
7 TRAP ( WAIT SYSTEM CALL )
ROR 2 REG
BCS 1 FWD ( SKIP IF INTERRUPTS WERE IGNORED )
60 TRAP 2 , vector , ( ELSE, CATCH INTERRUPTS )
1 L: NEXT ( DONE )
2 L: ( CHILD ) ( CHILD PROCESS CODE )
MOV 104473 $ SYSBUF *$ ( EXECE TRAP INSTRUCTION )
MOV NAME $ SYSBUF 2+ *$ ( MOVE NAME POINTER )
MOV ARGV $ SYSBUF 4 + *$ ( MOVE ARGUMENT POINTER )
MOV rsp0 *$ SYSBUF 6 + *$ ( MOVE ENVIRONMENT POINTER )
0 TRAP SYSBUF , ( INDIRECT EXECE SYSTEM CALL )
1 TRAP ( RETURN TO PARENT )
CODE SYSTEM ( ADDR[STRING] --- )
MOV 1ARG $ ARGV 2+ *$ ( MOVE POINTER TO "-c" TO ARGUMENT LIST )
MOV PSP )+ ARGV 4 + *$ ( MOVE POINTER TO COMMAND STRING TO LIST )
BR 0 BACK ( BRANCH TO CODE TO SPAWN SUB-SHELL )
( I/O BUFFER AND CONTROL VARIABLES
LABEL BLOCK 1000 RAMALLOT ( 512 BYTE DISK BUFFER )
LABEL SIZE 0 , ( SIZE IN BYTES )
LABEL INDEX 0 , ( CURRENT OFFSET INTO BLOCK )
LABEL FILED 0 , ( FILE DESCRIPTOR OF FILE THAT OWNS BLOCK )
( FILE POSITION TABLE: EACH SLOT HAS A 32 BIT FILE OFFSET. FILE )
( DESCRIPTOR IS OFFSET INTO TABLE. THERE ARE 15 SLOTS. )
LABEL FILEPOS 0 , 0 ,
0 , 0 ,
0 , 0 ,
0 , 0 ,
0 , 0 ,
0 , 0 ,
0 , 0 ,
0 , 0 ,
0 , 0 ,
0 , 0 ,
0 , 0 ,
0 , 0 ,
0 , 0 ,
0 , 0 ,
0 , 0 ,
( SUBROUTINE GETC: HANDLES ALL INPUT AND DOES BUFFERING )
( INPUT: FILE DESCRIPTOR IN R0 )
( OUTPUT: CHARACTER OF EOF IN R0 )
( SIDE EFFECTS: R0 AND R1 DESTROYED )
LABEL GETC
CMP 0 REG FILED *$ ( IS THIS FILE CURRENTLY BUFFERED? )
BEQ 0 FWD ( IS SO, DO NOT NEED TO TO SEEK )
MOV 0 REG FILED *$ ( SAVE NEW FD IN BUFFER DESCRIPTOR )
MOV SIZE *$ INDEX *$ ( INDICATE THAT BUFFER IS EMPTY )
MOV 104423 $ SYSBUF *$ ( MOVE LSEEK TRAP INSTRUCTION TO SYSBUF )
ASL 0 REG ASL 0 REG ( MULTIPLY BY 4 TO INDEX INTO POSITION TABLE )
MOV FILEPOS 0 X( SYSBUF 2+ *$ ( HIGH OFFSET WORD )
MOV FILEPOS 2+ 0 X( SYSBUF 4 + *$ ( LOW OFFSET WORD )
CLR SYSBUF 6 + *$ ( OFFSET FROM BEGINNING OF FILE )
MOV FILED *$ 0 REG ( FILE DESCRIPTOR IN R0 )
0 TRAP SYSBUF , ( LSEEK SYSTEM CALL )
MOV FILED *$ 0 REG ( RESTORE FD SINCE CALL DESTROYED R0, R1 )
0 L: MOV 2 REG SP -( ( SAVE R2 )
MOV INDEX *$ 2 REG ( R2 IS INDEX )
CMP 2 REG SIZE *$
BLT 1 FWD ( IF THERE IS STILL DATA IN BUFFER, USE IT )
3 TRAP BLOCK , 1000 , ( READ UP TO 512 BYTES )
BCS 2 FWD ( BRANCH IF ERROR )
MOV 0 REG SIZE *$ ( SAVE SIZE OF BLOCK )
BEQ 3 FWD ( BRANCH IF EOF )
CLR 2 REG ( RESET INDEX )
1 L: MOV BLOCK 2 X( 0 REG BYTE
( GET NEXT CHARACTER )
BIC 17400 $ 0 REG ( MASK OFF HIGH BYTE )
INC 2 REG
MOV 2 REG INDEX *$ ( UPDATE INDEX )
MOV FILED *$ 2 REG ( REUSE R2 TO HOLD FILE DESCRIPTOR )
ASL 2 REG ASL 2 REG ( MULTIPLY BY 4 TO INDEX INTO POSITION TABLE )
ADD 1 $ FILEPOS 2+ 2 X( ( ADD ONE TO CURRENT FILE POSITION )
ADC FILEPOS 2 X(
BR 4 FWD
2 L: 3 L:
MOV -1 $ 0 REG ( RETURN EOF ON ERROR )
4 L: MOV SP )+ 2 REG ( RESTORE R2 )
RTS PC REG-ONLY
CODE OPEN ( ADDR[STRING] MODE --- FD )
MOV 104405 $ SYSBUF *$ ( MOVE TRAP 5 INSTRUCTION TO INDIR AREA )
MOV PSP )+ SYSBUF 4 + *$ ( MOVE MODE )
MOV PSP ) SYSBUF 2+ *$ ( MOVE ADDR[STRING] )
0 TRAP SYSBUF , ( OPEN SYSTEM CALL )
BCC 1 FWD
MOV -1 $ PSP ) ( ERROR, NEGATIVE FILE DESCRIPTOR RETURNED )
BR 2 FWD
1 L: MOV 0 REG PSP ) ( RETURN FILE DESCRIPTOR )
ASL 0 REG ASL 0 REG ( MULTIPLY BY 4 IN INDEX INTO POSITION TABLE )
CLR FILEPOS 0 X( ( INITIALIZE FILE POSITION TO ZERO )
CLR FILEPOS 2+ 0 X(
2 L: NEXT
CODE CREAT ( ADDR[STRING] PMODE --- FD )
MOV 104410 $ SYSBUF *$ ( MOVE TRAP 8 INSTRUCTION TO INDIR AREA )
MOV PSP )+ SYSBUF 4 + *$ ( MOVE PMODE )
MOV PSP ) SYSBUF 2+ *$ ( MOVE ADDRESS OF FILE NAME )
0 TRAP SYSBUF , ( CREAT SYSTEM CALL )
BCC 1 FWD
MOV -1 $ PSP ) ( ERROR, NEGATIVE FILE DESCRIPTOR RETURNED )
BR 2 FWD
1 L: MOV 0 REG PSP ) ( RETURN FILE DESCRIPTOR )
ASL 0 REG ASL 0 REG ( MULTIPLY BY 4 TO INDEX INTO POSITION TABLE )
CLR FILEPOS 0 X( ( INITIALIZE FILE POSITION TO ZERO )
CLR FILEPOS 2+ 0 X(
2 L: NEXT
CODE CLOSE ( FD --- )
MOV 104406 $ SYSBUF *$ ( MOVE TRAP 6 INSTRUCTION TO INDIR AREA )
MOV PSP )+ 0 REG ( FILE DESCRIPTOR )
0 TRAP SYSBUF , ( CLOSE SYSTEM CALL )
NEXT
CODE FEXPECT ( FD ADDR COUNT --- ACTCOUNT )
MOV 2 PSP X( 2 REG ( BUFFER ADDRESS )
MOV PSP )+ 3 REG ( COUNT )
BEQ 3 FWD ( DO NOTHING IF COUNT IS ZERO )
1 L: MOV 2 PSP X( 0 REG ( FILE DESCRIPTOR )
JSR PC REG-ONLY GETC *$ ( GET NEXT CHARACTER )
CMP 0 REG -1 $ ( EOF? )
BEQ 4 FWD ( LEAVE LOOP ON EOF )
CMP 0 REG 011 $ BYTE ( TAB ? )
BNE 2 FWD
MOV 040 $ 0 REG BYTE ( CHANGE TABS TO BLANKS )
2 L: MOV 0 REG 2 )+ BYTE ( SAVE CHARACTER )
CMP 0 REG 012 $ BYTE ( NEWLINE? )
BEQ 5 FWD
1 3 SOB ( DECREMENT COUNT AND CONTINUE IF NON-ZERO )
3 L: 4 L: 5 L:
SUB PSP )+ 2 REG ( COMPUTE ACTUAL NUMBER OF CHARACTERS READ )
MOV 2 REG PSP ) ( RETURN ACTUAL NUMBER )
NEXT
CODE READ ( FD ADDR COUNT --- ACTCOUNT )
MOV 2 PSP X( 2 REG ( BUFFER ADDRESS )
MOV PSP )+ 3 REG ( COUNT )
BEQ 2 FWD ( DO NOTHING IF COUNT IS ZERO )
1 L: MOV 2 PSP X( 0 REG ( FILE DESCRIPTOR )
JSR PC REG-ONLY GETC *$ ( GET NEXT CHARACTER )
CMP 0 REG -1 $ ( EOF? )
BEQ 3 FWD ( LEAVE LOOP ON EOF )
MOV 0 REG 2 )+ BYTE ( SAVE CHARACTER )
1 3 SOB ( DECREMENT COUNT AND CONTINUE IF NON-ZERO )
2 L: 3 L:
SUB PSP )+ 2 REG ( COMPUTE ACTUAL NUMBER OF CHARACTERS READ )
MOV 2 REG PSP ) ( RETURN ACTUAL NUMBER )
NEXT
CODE WRITE ( ADDR COUNT FD --- ACTCOUNT )
MOV 104404 $ SYSBUF *$ ( MOVE TRAP INSTRUCTION TO INDIR AREA )
MOV PSP )+ 0 REG ( FILE DESCRIPTOR )
MOV PSP )+ SYSBUF 4 + *$ ( COUNT )
MOV PSP ) SYSBUF 2+ *$ ( ADDRESS )
0 TRAP SYSBUF , ( WRITE SYSTEM CALL )
BCC 1 FWD
MOV -1 $ 0 REG ( ERROR FLAG )
1 L: MOV 0 REG PSP ) ( RETURN ACTUAL COUNT )
NEXT
CODE SEEK ( FD OFFSETL OFFSETH --- )
MOV 4 PSP X( 0 REG ( FILE DESCRIPTOR )
CMP 0 REG FILED *$ ( IF SEEK ON CURRENTLY BUFFERED FILE )
BNE 1 FWD
MOV -1 $ FILED *$ ( FLAG BUFFER AS INVALID )
1 L: ASL 0 REG ASL 0 REG ( MULTIPLY BY 4 TO INDEX INTO POSITION TABLE )
MOV PSP ) FILEPOS 0 X( ( HIGH OFFSET INTO FILE POSITION TABLE )
MOV 2 PSP X( FILEPOS 2+ 0 X( ( LOW OFFSET INTO FILE POSITION TABLE )
MOV 104423 $ SYSBUF *$ ( MOVE SEEK TRAP INSTRUCTION TO SYSBUF )
MOV PSP )+ SYSBUF 2+ *$ ( MOVE HIGH OFFSET )
MOV PSP )+ SYSBUF 4 + *$ ( MOVE LOW OFFSET )
CLR SYSBUF 6 + *$ ( OFFSET FROM BEGINNING OF FILE )
MOV PSP )+ 0 REG ( FILE DESCRIPTOR IN R0 )
0 TRAP SYSBUF , ( SEEK SYSTEM CALL )
NEXT
CODE TERMINATE ( --- )
CLR 0 REG ( RETURN GOOD STATUS )
1 TRAP ( EXIT SYSTEM CALL )
( SHOULD NOT EXECUTE BEYOND TRAP )
CODE (FIND) ( ADDR[NAME] ADDR[VOCAB] --- 0 <OR> NFA )
MOV PSP )+ 0 REG
BEQ 3 FWD ( EMPTY VOCABULARY? )
MOV PSP ) 3 REG ( POINTER TO NAME )
MOV 3 )+ 2 REG ( NAME LS )
MOV 3 ) 3 REG ( NAME MS )
1 L: MOV 0 ) 1 REG
BIC 200 $ 1 REG ( CLEAR IMMEDIATE BIT )
CMP 1 REG 2 REG ( COMPARE LS )
BNE 2 FWD
CMP 2 0 X( 3 REG ( COMPARE MS )
BEQ 4 FWD
2 L: MOV 4 0 X( 0 REG ( NEXT LINK )
BNE 1 BACK ( ZERO LINK? )
3 L: 4 L:
MOV 0 REG PSP )
NEXT
CODE WORD ( DEL --- ADDR )
MOV PSP ) 0 REG ( DELIMITER )
MOV in *$ 1 REG ( >IN )
ADD inbuf $ 1 REG ( R1 HAS ADDRESS OF NEXT BYTE IN STREAM )
MOV dp *$ 2 REG ( HERE )
MOV 2 REG PSP ) ( RETURN HERE, ADDRESS OF STRING )
1 L: CMP 0 REG 1 )+ BYTE ( SKIP DELIMITERS )
BEQ 1 BACK
DEC 1 REG ( BACK UP ONE )
MOV 1 REG 3 REG
2 L: CMP 0 REG 3 ) BYTE ( DELIMITER? )
BEQ 3 FWD
CMP 012 $ 3 ) BYTE ( NEWLINE? )
BEQ 4 FWD
INC 3 REG ( SKIP UNTIL END OF WORD )
BR 2 BACK
3 L: 4 L:
SUB 1 REG 3 REG ( R3 HAS LENGTH )
MOV 3 REG 2 )+ BYTE ( SAVE COUNT )
BEQ 6 FWD ( SKIP IF EOL, I.E. ZERO LENGTH )
5 L: MOV 1 )+ 2 )+ BYTE ( MOVE CHARACTERS TO HERE )
5 3 SOB
6 L: CMP 012 $ 1 ) BYTE ( IF NOT NEWLINE )
BEQ 7 FWD
INC 1 REG ( SKIP DELIMITER )
7 L: SUB inbuf $ 1 REG ( >IN IS OFFSET FROM START OF TIB )
MOV 1 REG in *$ ( UPDATE >IN SCANNER )
MOV 040 $ 2 )+ BYTE ( ADD BLANK TO END OF WORD
NEXT
( STACK PRIMITIVES )
CODE ! ( DATA ADDR --- )
MOV PSP )+ 0 REG
MOV PSP )+ 0 )
NEXT
CODE !SP ( ADDR --- ) ( SET ADDRESS OF STACK TOP. )
MOV PSP ) PSP REG
NEXT
CODE + ( N1 N2 --- N1+N2 )
ADD PSP )+ PSP )
NEXT
CODE +! ( DATA ADDR --- )
MOV PSP )+ 0 REG
ADD PSP )+ 0 )
NEXT
CODE - ( N1 N2 --- N1-N2 )
SUB PSP )+ PSP )
NEXT
CODE -1 ( --- -1 )
MOV -1 $ PSP -(
NEXT
CODE 0 ( --- 0 )
CLR PSP -(
NEXT
CODE 0< ( N --- T/F )
CLR 0 REG
TST PSP )
BPL 1 FWD
MOV -1 $ 0 REG
1 L: MOV 0 REG PSP )
NEXT
CODE 0= ( N --- T/F )
CLR 0 REG
TST PSP )
BNE 1 FWD
MOV -1 $ 0 REG
1 L: MOV 0 REG PSP )
NEXT
CODE 1 ( --- 1 )
MOV 1 $ PSP -(
NEXT
CODE 1+ ( N --- N+1 )
INC PSP )
NEXT
CODE 1- ( N --- N-1 )
DEC PSP )
NEXT
CODE 2 ( --- 2 )
MOV 2 $ PSP -(
NEXT
CODE 2+ ( N --- N+2 )
ADD 2 $ PSP )
NEXT
CODE 2- ( N --- N-2 )
SUB 2 $ PSP )
NEXT
CODE 2* ( N --- 2*N )
ASL PSP )
NEXT
CODE 2/ ( N --- N/2 )
ASR PSP )
NEXT
CODE < ( N1 N2 --- T/F )
CLR 0 REG
CMP PSP )+ PSP )
BLE 1 FWD
MOV -1 $ 0 REG
1 L: MOV 0 REG PSP )
NEXT
CODE = ( N1 N2 --- T/F )
CLR 0 REG
CMP PSP )+ PSP )
BNE 1 FWD
MOV -1 $ 0 REG
1 L: MOV 0 REG PSP )
NEXT
CODE > ( N1 N2 --- T/F )
CLR 0 REG
CMP PSP )+ PSP )
BGE 1 FWD
MOV -1 $ 0 REG
1 L: MOV 0 REG PSP )
NEXT
CODE >R ( N1 --- )
MOV PSP )+ SP -(
NEXT
CODE @ ( ADDR --- DATA )
MOV 0 PSP *X( PSP )
NEXT
CODE @SP ( --- ADDR ) ( RETURN STACK POINTER )
MOV PSP REG 0 REG
MOV 0 REG PSP -(
NEXT
CODE AND ( N1 N2 --- N1 & N2 )
MOV PSP )+ 0 REG
COM 0 REG
BIC 0 REG PSP )
NEXT
CODE C! ( BYTE ADDR --- )
MOV PSP )+ 0 REG
MOV PSP )+ 1 REG
MOV 1 REG 0 ) BYTE
NEXT
CODE C@ ( ADDR --- BYTE )
MOV 0 PSP *X( 0 REG BYTE
BIC 177400 $ 0 REG
MOV 0 REG PSP )
NEXT
CODE CMOVE ( SRC DEST UCOUNT --- )
MOV PSP )+ 2 REG
BEQ 2 FWD ( DO NOTHING IF LENGTH ZERO )
MOV PSP )+ 0 REG ( DESTINATION )
MOV PSP )+ 1 REG ( SOURCE )
1 L: MOV 1 )+ 0 )+ BYTE ( MOVE BYTE )
1 2 SOB
BR 3 FWD
2 L: ADD 4 $ PSP REG ( POP TWO STACK ARGS )
3 L: NEXT
CODE D+ ( D1L D1H D2L D2H --- [D1+D2]L [D1+D2]H )
MOV PSP )+ 0 REG
ADD PSP )+ 2 PSP X(
ADC PSP )
ADD 0 REG PSP )
NEXT
CODE D< ( D1L D1H D2L D2H --- T/F )
CLR 0 REG
CMP PSP )+ 2 PSP X(
BLT 2 FWD
BNE 1 FWD
CMP PSP ) 4 PSP X(
BLE 3 FWD
1 L: MOV -1 $ 0 REG
2 L: 3 L:
ADD 4 $ PSP REG
MOV 0 REG PSP )
NEXT
CODE DNEGATE ( D1L D1H --- [-D1]L [-D1]H )
COM PSP )
COM 2 PSP X(
ADD 1 $ 2 PSP X(
ADC PSP )
NEXT
CODE DROP ( N --- )
ADD 2 $ PSP REG
NEXT
CODE DUP ( N --- N N )
MOV PSP ) PSP -(
NEXT
CODE M* ( S1 S2 --- [S1*S2]L [S1*S2]H )
MOV PSP ) 0 REG
MUL 0 REG-ONLY 2 PSP X(
MOV 1 REG 2 PSP X( ( LOW RESULT )
MOV 0 REG PSP ) ( HIGH RESULT )
NEXT
CODE M/ ( SDL SDH DIVISOR --- SREM SQUOT )
MOV PSP )+ 2 REG ( R2 HAS DIVISOR )
MOV PSP ) 0 REG ( R0 HAS HIGH DIVIDEND )
MOV 2 PSP X( 1 REG ( R1 HAS LOW DIVIDEND )
MOV 2 REG 3 REG
EXOR 0 REG-ONLY 3 REG ( R3 HAS SIGN )
DIV 0 REG-ONLY 2 REG ( DIVIDE BY R2 )
TST 3 REG
BPL 1 FWD ( BRANCH IF SIGN IS NOT NEGATIVE )
TST 1 REG
BEQ 2 FWD ( BRANCH IF REMAINDER IS ZERO )
DEC 0 REG ( SUBTRACT ONE FROM QUOTIENT )
ADDlwt1@aplvax (06/08/84)
Here is part 7 of the source for FORTH for the PDP-11.
Delete everything thru the "-- cut here --" line, and extract with 'sh':
sh part1 part2 ... part7
where 'part?' are whatever you've named the files. Note the copyright
notice at the end of README. Please let us know how things go. While
we can't support this software, we'll be posting bug fixes/upgrades to
net.sources as time permits.
VAX-FORTH should be 'forth'-coming {yuk-yuk} within a couple of weeks.
Have fun!
-Lloyd W. Taylor
... seismo!umcp-cs!aplvax!lwt1
---I will have had been there before, soon---
---------------------------------- cut here ----------------------------------
echo x - SYS:SRC
cat >SYS:SRC <<'+E+O+F'
( HIGH LEVEL FORTH DEFINITIONS ) HEX
( SYSTEM CONSTANTS AND VARIABLES )
inbuf CONSTANT TIB ( START OF TEXT INPUT BUFFER )
inbuf CONSTANT SP0 ( TOP OF PARAMETER STACK AREA )
dp CONSTANT DP ( CURRENT DICTIONARY POINTER )
in CONSTANT >IN ( TEXT SCANNER )
initvocab CONSTANT INITVOCAB ( INITIAL FORTH VOCABULARY )
VARIABLE WRN ( ENABLE 'NOT UNIQUE' WARNINGS )
VARIABLE STATE ( INTERPRETATION STATE )
VARIABLE BASE ( BASE HEX )
VARIABLE CURRENT ( CURRENT VOCABULARY )
VARIABLE CONTXT ( CONTEXT VOCABULARY )
VARIABLE CLUE ( USED FOR COMPILING LEAVE )
0 CONSTANT STDIN ( STANDARD INPUT FILE DESCRIPTOR )
1 CONSTANT STDOUT ( STANDARD OUTPUT FILE DESCRIPTOR )
0A CONSTANT EOL ( END OF LINE )
-1 CONSTANT TRUE ( TRUE )
0 CONSTANT FALSE ( FALSE )
( CODE EXTENSIONS: THESE ARE LOW LEVEL WORDS THAT MAY BE CANDIDATES )
( FOR REWRITING AS CODE DEFINTIONS. )
: ?DUP DUP IF DUP THEN ; ( N --- N N <OR> 0 )
: -ROT ROT ROT ; ( N1 N2 N3 --- N3 N1 N2 )
: * UM* DROP ; ( N1 N2 --- N1*N2 ) ( SIGNED MULTIPLY )
: 2DUP OVER OVER ; ( N1 N2 --- N1 N2 N1 N2 )
: S->D DUP 0< ; ( N1 --- DL DH ) ( SIGN EXTEND )
: +- 0< IF NEGATE THEN ; ( N1 N2 --- SIGN[N2]*N1 )
: D+- 0< IF DNEGATE THEN ; ( D1L D1H N1 --- D2L D2H )
: ABS DUP +- ; ( N --- |N| )
: DABS DUP D+- ; ( D --- |D| )
: 2DROP DROP DROP ; ( N1 N2 --- )
: 0> 0 > ; ( N --- T/F )
: MAX 2DUP < IF SWAP THEN DROP ; ( N1 N2 --- MAX[N1,N2] )
: MIN 2DUP > IF SWAP THEN DROP ; ( N1 N2 --- MIN[N1,N2] )
: <> = NOT ; ( N1 N2 --- T/F )
( UNSIGNED MULTIPLCATION AND DIVISITON OPERATORS )
: UM*M ( UL UH MUL --- UL' UH' )
SWAP OVER UM* DROP >R UM* 0 R> D+ ;
: M/MMOD ( DL DH DIV --- REM QUOTL QUOTH )
>R 0 R@ UM/ R> SWAP >R UM/ R> ;
: UM/MOD ( DL DH DIV --- REM QUOT )
M/MMOD DROP ;
( SIGNED MULTIPLICATION AND DIVISION OPERATORS )
: /MOD ( N1 DIV --- REM QUOT )
>R S->D R> M/ ;
: / ( N DIV --- DIVIDEND )
/MOD SWAP DROP ;
: MOD ( N DIV --- MOD )
/MOD DROP ;
: */MOD ( N MUL DIV --- REM QUOT )
>R M* R> M/ ;
: */ ( N MUL DIV --- QUOT )
*/MOD SWAP DROP ;
: DEPTH ( --- N ) ( RETURN DEPTH OF STACK )
( IN WORDS NOT COUNTING N. )
@SP SP0 SWAP - 2/ ;
: PICK ( N1 --- N2 ) ( N2 IS A COPY OF THE )
( N1TH STACK ITEM NOT COUNTING N1. )
( 0 PICK IS EQUIVALENT TO DUP. )
2* @SP + 2+ @ ;
: FILL ( ADDR N BYTE --- )
SWAP ?DUP IF
>R OVER C!
DUP 1+ R> 1- CMOVE
ELSE 2DROP
THEN ;
: CMOVE> ( ADDR1 ADDR2 U --- ) ( MOVE U BYTES )
( FROM ADDR1 TO ADDR2. STARTS MOVING )
( HIGH ADDRESSED CHARACTERS FIRST. )
?DUP IF
DUP >R + 1- SWAP DUP R> + 1-
DO I C@ OVER C! 1- -1 +LOOP
ELSE DROP
THEN DROP ;
: ROLL ( <'N' VALUES> N --- <'N' VALUES> )
( THE NTH STACK ITEM NOT COUNTING )
( N ITSELF IS TRANSFERRED TO THE )
( TOP OF THE STACK, MOVING THE RE-)
( MAINING VALUES INTO THE VACATED )
( POSITION. 0 ROLL IS A NOP. )
DUP >R PICK
@SP DUP 2+ R> 1+ 2* CMOVE> DROP ;
: TOGGLE ( ADDR BITS --- ) ( TOGGLE THE IN- )
( DICATED BITS AT ADDR. )
OVER @ XOR SWAP ! ;
: 2! ( DL DH ADDR --- ) ( M[ADDR]<--DH, )
( M[ADDR+2]<--DL. )
SWAP OVER ! 2+ ! ;
: 2@ ( ADDR --- DL DH ) ( DH<--M[ADDR], )
( DL<--M[ADDR+2]. )
DUP 2+ @ SWAP @ ;
: HEX 10 BASE ! ; ( SET BASE TO HEX )
: DECIMAL A BASE ! ; ( SET BASE TO DECIMAL )
: OCTAL 8 BASE ! ; ( SET BASE TO OCTAL )
( COMPILING WORDS )
: HERE DP @ ; ( --- ADDR )
: PAD HERE 50 + ; ( --- ADDR )
: LATEST CURRENT @ @ ; ( --- ADDR ) ( RETURNS ADDR OF MOST )
( RECENTLY COMPILED NAME FIELD. )
: ALLOT DP +! ; ( BYTECOUNT --- ) ( ALLOT DICTIONARY )
: , HERE ! 2 ALLOT ; ( WORD --- ) ( ADD TO DICTIONARY )
: IMMEDIATE LATEST 80 TOGGLE ; ( --- ) ( MAKE MOST RECENTLY COM- )
( PILED WORD IMMEDIATE. )
: SMUDGE LATEST 40 TOGGLE ; ( --- ) ( SMUDGE MOST RECENTLY )
( COMPILED WORD. )
: COMPILE
R> DUP @ , 2 + >R ;
: <MARK ( --- ADDR ) ( USED AS DESTINATION )
( OF BACKWARD BRANCH. )
HERE ;
: <RESOLVE ( ADDR --- ) ( RESOLVE BACKWARD )
( BRANCH. )
, ;
: >MARK ( --- ADDR ) ( SOURCE OF FORWARD )
( BRANCH. )
HERE 2 ALLOT ;
: >RESOLVE ( ADDR --- ) ( RESOLVE FORWARD )
( BRANCH. )
HERE SWAP ! ;
: >>RESOLVE ( OLDLINK --- ) ( RESOLVE A CHAIN )
( OF FORWARD BRANCHES. )
HERE SWAP BEGIN
DUP WHILE
OVER SWAP DUP @ -ROT !
REPEAT 2DROP ;
: IF ( --- ADDR )
COMPILE ?BRANCH >MARK ; IMMEDIATE METASMUDGE
: THEN ( ADDR --- )
>RESOLVE ; IMMEDIATE METASMUDGE
: ELSE ( ADDR --- ADDR' )
COMPILE BRANCH >MARK
SWAP >RESOLVE ; IMMEDIATE METASMUDGE
: BEGIN ( --- ADDR )
<MARK ; IMMEDIATE METASMUDGE
: UNTIL ( ADDR --- )
COMPILE ?BRANCH <RESOLVE ; IMMEDIATE METASMUDGE
: AGAIN ( ADDR --- )
COMPILE BRANCH <RESOLVE ; IMMEDIATE METASMUDGE
: WHILE ( --- ADDR )
COMPILE ?BRANCH >MARK ; IMMEDIATE METASMUDGE
: REPEAT ( ADDR1 ADDR2 --- )
COMPILE BRANCH SWAP <RESOLVE >RESOLVE ; IMMEDIATE METASMUDGE
: SEL
0 ; IMMEDIATE METASMUDGE
: << ( OLDLINK --- OLDLINK )
COMPILE DUP ; IMMEDIATE METASMUDGE
: => ( --- IFADDR )
COMPILE ?BRANCH >MARK
COMPILE DROP ; IMMEDIATE METASMUDGE
: ==> ( --- IFADDR )
COMPILE =
COMPILE ?BRANCH >MARK
COMPILE DROP ; IMMEDIATE METASMUDGE
: >> ( OLDLINK IFADDR --- NEWLINK )
COMPILE BRANCH SWAP ,
>RESOLVE
HERE 2- ; IMMEDIATE METASMUDGE
: ENDSEL ( OLDLINK --- )
COMPILE DROP >>RESOLVE ; IMMEDIATE METASMUDGE
( THE CODE WORDS [DO], [LOOP], AND [+LOOP] IMPLEMENT FORTH-83 DO..LOOPS. )
( [LEAVE] IS A FORTH-83 LEAVE. CLUE IS USED TO IMPLEMENT LEAVE. )
: DO ( --- CLUE HERE )
COMPILE (DO) CLUE @ 0 CLUE ! <MARK ; IMMEDIATE METASMUDGE
: LOOP ( CLUE HERE --- )
COMPILE (LOOP) <RESOLVE
CLUE @ >>RESOLVE
CLUE ! ; IMMEDIATE METASMUDGE
: +LOOP ( CLUE HERE --- )
COMPILE (+LOOP) <RESOLVE
CLUE @ >>RESOLVE
CLUE ! ; IMMEDIATE METASMUDGE
: LEAVE ( --- )
COMPILE (LEAVE) HERE CLUE @ , CLUE ! ; IMMEDIATE METASMUDGE
: EXIT ( --- ) ( EXIT THE CURRENT )
( COLON DEFINTION. CAN'T BE )
( USED INSIDE A LOOP. )
R> DROP ;
: [ 0 STATE ! ; IMMEDIATE METASMUDGE
: ] 1 STATE ! ;
: ( 29 WORD DROP ; IMMEDIATE METASMUDGE
( I/O WORDS: MOST OF THE I/O IS WRITTEN IN ASSEMBLY LANGUAGE )
VARIABLE OUTTABLE ( TABLE OF FILE DESCRIPTORS USED )
( BY TYPE. )
STDOUT OUTTABLE ! 0 , 0 , 0 , ( ZERO INDICATES NO FILE )
: FOREACHOUTPUT ( --- ADDR2 ADDR1 ) ( RETURNS UPPER)
( AND LOWER ADDRESSES OF OUTPUT TABLE)
( IN FORMAT SUITABLE FOR DO. )
OUTTABLE 8 + OUTTABLE ;
: OUTPUT ( FD --- ) ( ADD THE FILE DESCRIP- )
( TOR TO THE OUTPUT TABLE IF THERE IS)
( ROOM. )
FOREACHOUTPUT DO
I @ 0= IF DUP I ! LEAVE THEN
2 +LOOP DROP ;
: SILENT ( FD --- ) ( DELETE THE FILE DES- )
( CRIPTOR FROM THE OUTPUT TABLE. )
FOREACHOUTPUT DO
DUP I @ = IF 0 I ! THEN
2 +LOOP DROP ;
: TYPE ( ADDR COUNT --- ) ( SEND COUNT )
( BYTES TO EACH FILE IN THE OUTPUT)
( TABLE. )
FOREACHOUTPUT DO
I @ ?DUP IF >R 2DUP R> WRITE DROP THEN
2 +LOOP 2DROP ;
: EMIT ( CHAR --- ) ( SEND CHARACTER TO )
( STDOUT. )
@SP 1 TYPE DROP ;
: CR ( --- ) ( SEND NEWLINE CHARACTER )
EOL EMIT ;
: FQUERY ( FD --- ACTCOUNT ) ( READ ONE )
( LINE, UP TO 120 CHARACTERS, FROM )
( INDICATED FILE. ACTCOUNT IS )
( ACTUAL NUMBER OF CHARACTERS READ.)
( WILL BE ZERO ON END OF FILE. )
0 >IN ! TIB 78 FEXPECT ;
: COUNT ( ADDR --- ADDR+1 LEN )
DUP 1+ SWAP C@ ;
: ALIGN ( ADDR --- ADDR' ) ( FORCE WORD )
( ALIGNMENT OF AN ADDRESS. )
1+ 2/ 2* ;
: ,WORD ( DEL --- ) ( ADD TEXT DELIMITED BY )
( DEL INTO DICTIONARY. )
WORD C@ 1+ ALIGN ALLOT ;
: (.") ( --- )
R> COUNT 2DUP TYPE + ALIGN >R ;
: ."
COMPILE (.") 22 ,WORD ; IMMEDIATE METASMUDGE
FORTH : ."
META (.") FORTH
22 WORD DUP COUNT + ALIGN
SWAP DO
I @ HOST ,
2 +LOOP ; HOST-->META
: SPACE ( --- ) ( EMIT SPACE )
20 EMIT ;
: SPACES ( COUNT --- )
0 MAX ?DUP IF 0 DO SPACE LOOP THEN ;
: -TRAILING ( ADDR N1 --- ADDR N2 ) ( THE CHAR- )
( ACTER COUNT OF A STRING BEGINNING )
( AT ADDR IS ADJUSTED TO REMOVE TRAIL-)
( ING BLANKS. IF N1 IS ZERO, THEN N2 )
( IS ZERO. IF THE ENTIRE STRING CON- )
( SISTS OF SPACES, THEN N2 IS ZERO. )
DUP IF
DUP 0 DO
2DUP + 1- C@ 20 - IF LEAVE ELSE 1- THEN
LOOP
THEN ;
: STRING ( ADDR[COUNTED_STRING] --- )
( ADDR[UNIX_STRING )
COUNT DUP >R PAD SWAP CMOVE 0 PAD R> + C! PAD ;
: " ( --- ADDR[STRING] )
22 WORD STRING ;
: ("") ( --- ADDR[STRING] )
R> DUP COUNT + ALIGN >R STRING ;
: ""
COMPILE ("") 22 ,WORD ; IMMEDIATE METASMUDGE
( DEFINING WORDS )
: CFIELD ( NFA --- CFA )
6 + ;
: NFIELD ( CFA --- NFA )
6 - ;
: -IMM ( NFA --- CFA N ) ( GIVEN A NAME )
( FIELD ADDRESS, CONVERTS TO CODE )
( FIELD ADDRESS AND RETURNS A FLAG )
( N WHICH IS -1 IF THE WORD IS NON-)
( IMMEDIATE AND 1 IF THE WORD IS )
( IMMEDIATE. )
DUP CFIELD -1 ROT C@ 80 AND IF NEGATE THEN ;
: FIND ( ADDR[NAME] --- ADDR2 N ) ( TRIES )
( TO FIND NAME IN THE DICTIONARY. )
( ADDR2 IS ADDR[NAME] AND N IS 0 IF )
( NOT FOUND. IF THE NAME IS FOUND, )
( ADDR2 IS THE CFA. N IS -1 IF THE )
( WORD IS NON-IMMEDIATE AND 1 IF IT )
( IS IMMEDIATE. )
DUP CONTXT @ @ (FIND) ( LOOKUP IN CONTEXT VOCABULARY )
?DUP IF ( ADDR[NAME] NFA )
SWAP DROP -IMM
ELSE
DUP LATEST (FIND) ( LOOKUP IN CURRENT VOCABULARY )
?DUP IF
SWAP DROP -IMM
ELSE
0 ( NOT FOUND )
THEN
THEN ;
: ' ( --- 0 <> CFA ) ( MOVES NEXT )
( WORD IN INPUT STREAM TO HERE )
( AND LOOKS UP IN CONTEXT AND )
( CURRENT VOCABULARIES. RETURNS )
( CFA IF FOUND, ZERO OTHERWISE. )
HERE 4 20 FILL ( BLANK HERE AREA )
20 WORD FIND 0= IF DROP 0 THEN ;
: HEADER ( --- ) ( CREATE DICTIONARY )
( HEADER FOR NEXT WORD IN )
( INPUT STREAM. )
' IF
WRN @ IF
HERE COUNT TYPE ." isn't unique" CR
THEN
THEN
HERE 4 ALLOT LATEST , CURRENT @ ! ;
: CALL ( --- ) ( COMPILE OPCODE FOR )
( JSR IAR,*$--- )
091F , ;
: :
CURRENT @ CONTXT ! ( SET CONTEXT TO CURRENT )
HEADER CALL COMPILE (:) ] SMUDGE ;
: ;
COMPILE (;) SMUDGE 0 STATE ! ; IMMEDIATE METASMUDGE
: VARIABLE
HEADER CALL COMPILE (VARIABLE) 0 , ;
: CONSTANT
HEADER CALL COMPILE (CONSTANT) , ;
: 2VARIABLE
VARIABLE 0 , ;
: DOES>
R> LATEST CFIELD 4 + ! ;
: CREATE
HEADER CALL COMPILE (DOES>) 0 , DOES> ;
: VOCABULARY
CREATE HERE 2+ , LATEST ,
DOES> @ CONTXT ! ;
: DEFINITIONS
CONTXT @ CURRENT ! ;
: FORTH
INITVOCAB CONTXT ! ; IMMEDIATE
( FORMATTED OUTPUT )
VARIABLE HLD
: HOLD ( CHAR --- ) ( ADD CHARACTER TO )
( FRONT OF STRING POINTED TO BY )
( HLD. )
-1 HLD +! HLD @ C! ;
: <# ( --- )
PAD HLD ! ;
: #> ( DL DH --- ADDR COUNT )
2DROP HLD @ PAD OVER - ;
: SIGN ( SIGN --- )
0< IF 2D HOLD THEN ;
: # ( DL DH --- DL' DH' )
BASE @ M/MMOD ROT 9 OVER < IF 7 + THEN
30 + HOLD ;
: #S ( DL DH --- 0 0 )
BEGIN # 2DUP OR 0= UNTIL ;
: D.R ( DL DH FILEDSIZE --- )
>R SWAP OVER DABS <# #S ROT SIGN #>
R> OVER - SPACES TYPE ;
: ZEROES ( N --- ) ( EMIT N ZEROES )
0 MAX ?DUP IF 0 DO 30 EMIT LOOP THEN ;
: D.LZ ( DL DH FIELDSIZE --- )
>R SWAP OVER DABS <# #S ROT SIGN #>
R> OVER - ZEROES TYPE ;
: D. ( DL DH --- )
0 D.R SPACE ;
: .R >R S->D R> D.R ; ( N FIELDSIZE --- )
: . ( N --- )
S->D D. ;
: U.R 0 SWAP D.R ; ( N FIELDSIZE --- )
: U.LZ 0 SWAP D.LZ ; ( N FIELDSIZE --- )
: U. 0 D. ; ( N --- )
: ? @ . ; ( ADDR --- )
: U? @ U. ; ( ADDR --- )
( UTILITIES )
: [COMPILE]
' , ; IMMEDIATE METASMUDGE
: [']
' COMPILE (LITERAL) , ; IMMEDIATE METASMUDGE
: LITERAL
COMPILE (LITERAL) , ; IMMEDIATE METASMUDGE
: .(
29 WORD COUNT TYPE CR ; IMMEDIATE METASMUDGE
: DUMP
CR
FFFF 0 <# #S #> SWAP DROP -ROT
FF 0 <# #S #> SWAP DROP -ROT
OVER + SWAP DO
I 2 PICK U.LZ ." :" SPACE
I 8 + I DO
I C@ OVER U.LZ SPACE
LOOP 4 SPACES
I 8 + I DO
I C@ DUP 20 < OVER 7E > OR
IF DROP 2E THEN
EMIT
LOOP
CR 8 +LOOP 2DROP ;
: FORGET ( --- ) ( DELETE THE NEXT WORD )
( IN THE INPUT STREAM FROM THE COM- )
( PILATION VOCABULARY. )
HERE 4 20 FILL
20 WORD LATEST (FIND) ?DUP
IF DUP DP ! 4 + @ CURRENT @ !
ELSE HERE COUNT TYPE ." ?" CR
THEN ;
( OPERATING SYSTEM SUPPORT WORDS )
: DIGIT ( CHR --- N TRUE <OR> FALSE )
30 -
DUP 9 > OVER 11 < AND IF
DROP FALSE
ELSE
DUP 9 U> IF 7 - THEN
DUP BASE @ 1- U> IF
DROP FALSE
ELSE
TRUE
THEN
THEN ;
: CONVERT ( DL DH ADDR1 --- DL' DH' ADDR2 )
( CONVERT CHARACTERS TO NUMBERS )
( STARTING AT ADDR1 ACCUMULATING)
( IN D. ADDR2 IS THE ADDRESS OF )
( THE FIRST UNCONVERTIBLE CHAR. )
>R BEGIN
R> 1+ DUP >R C@ DIGIT ( TRY TO CONVERT NEXT DIGIT )
WHILE >R BASE @ UM*M R> 0 D+
REPEAT R> ;
: NUMBER ( ADDR --- N TRUE <OR> FALSE )
DUP 1+ C@ 2D = DUP >R - ( SAVE SIGN ON RETURN STACK )
0 0 ROT CONVERT
C@ 20 = IF ( IF SUCCESSFUL )
DROP R> +- TRUE ( TRUNCATE, APPLY SIGN, RETURN TRUE )
ELSE
2DROP R> DROP FALSE ( ELSE RETURN FALSE )
THEN ;
: ?STACK ( --- T/F ) ( RETURNS TRUE )
( ON STACK UNDERFLOW. )
@SP SP0 > ;
: CHUCKBUF ( --- ) ( FLUSH REST OF INPUT LINE )
TIB >IN @ + BEGIN
DUP C@ EOL <>
WHILE 1+
REPEAT TIB - >IN ! ;
: ENDINTERP ( --- ) ( RESET STACK POINTER AND )
( FLUSH REST OF INPUT LINE. )
SP0 !SP CHUCKBUF ;
: INTERPRET ( --- )
BEGIN
HERE 4 20 FILL
20 WORD C@ WHILE ( WHILE NOT AT END OF LINE )
HERE FIND ?DUP IF
STATE @ + IF EXECUTE ELSE , THEN
ELSE
NUMBER IF
STATE @ IF
COMPILE (LITERAL) ,
THEN
ELSE
HERE COUNT TYPE ." ?" CR ENDINTERP
THEN
THEN
?STACK IF
." Stack empty" CR ENDINTERP
THEN
REPEAT ;
: FLOAD ( ADDR[UNIX_STRING] --- )
0 OPEN
DUP 0< IF
DROP ." can't open" CR
ELSE
>R BEGIN R@ FQUERY WHILE INTERPRET REPEAT
R> CLOSE CHUCKBUF
THEN ;
: QUIT ( --- )
RESET 0 STATE ! ( RESET RETURN STACK; INTERPRET STATE )
BEGIN
CR STDIN FQUERY WHILE
INTERPRET STATE @ 0= IF ." OK" THEN
REPEAT CR TERMINATE ;
: ABORT ( --- )
SP0 !SP QUIT ;
: ABORT" ( T/F --- ) ( PRINTS MESSAGE AND )
( ABORTS IF FLAG IS TRUE. )
COMPILE ?BRANCH >MARK
COMPILE (.") 22 ,WORD COMPILE ABORT
>RESOLVE ; IMMEDIATE METASMUDGE
( INITIALIZATION CODE AND STARTUP CODE )
' ABORT 4 + vector 2+ ! ( BACKPATCH INTERRUPT ROUTINE )
HERE 2 ! ( BACKPATCH STARTING JUMP )
MOV inbuf $ PSP REG ( INITIALIZE PSP )
30 TRAP 2 , 1 , ( IGNORE INTERRUPT SIGNALS )
ROR 0 REG
BCS 1 FWD ( SKIP IF INTERRUPTS ARE ALREADY IGNORED )
30 TRAP 2 , vector , ( CATCH INTERRUPTS )
1 L: MOV SP )+ 0 REG ( R0 HAS ARGUMENT COUNT )
ASL 0 REG ( R0 HAS BYTE COUNT )
ADD 0 REG SP REG ( POP ARGUMENTS )
TST SP )+ ( POP NULL POINTER; SP NOW HAS ENVIRONMENT )
( POINTER USED BY EXEC CALLS )
MOV SP REG rsp0 *$ ( SAVE RETURN STACK POINTER FOR USE BY QUIT )
( AND EXEC CALL )
MOV HERE 4 + $ IAR REG ( TRICKY; IAR POINTS TO HIGH LEVEL STARTUP )
NEXT ( EXECUTE FORTH )
( HIGH LEVEL STARTUP CODE )
] HEX TRUE WRN ! 0 CLUE !
FORTH DEFINITIONS
CR ." unix-FORTH, version 2.1"
ABORT
[
( INITILIZE VARIABLES AT COMPILE TIME )
HERE DP ! ( INITIAL DP )
OBJLINK FORTH @ HOST initvocab ! ( INITIAL VOCABULARY )
+E+O+F