lwt1@aplvax.UUCP (06/22/84)
Here is part 1 of 8 of the source for FORTH for the VAX.
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.
Have fun!
-John Hayes
Johns Hopkins University
Applied Physics Laboratory
... seismo!umcp-cs!aplvax!lwt1
---------------------------------- cut here ----------------------------------
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 4 + @ -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 6 + @ 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 6 + ! ( 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 8 8 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 1022 FORTH ALLOT HOST
BUFFER 1024 -1 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 1024 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 1024 0 FILL ( ZERO BUFFER )
DUP IMAGE ! ( RECORD ADDRESS )
FILED @ SWAP 0 SEEK ( POSITION FILE READ POINTER )
FILED @ BUFFER 1024 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. )
20 + ( SKIP A.OUT HEADER )
DUP 3FF AND SWAP FC00 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 ;
: C, ( BYTE --- )
HERE C! 1 ALLOT ;
: 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 . 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 6 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 )
FORTH LATEST 4 + @ HOST , ( OBJECT HEADER, 3RD 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 . ( 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 6 20 FILL
HOST 20 WORD FIND
IF 4 + 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 , 0 ,
0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 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 + 20 + 400 + FC00 AND ( COMPUTE UPPER LIMIT DISK ADDRESS )
HERE 20 + ( COMPUTE LOWER LIMIT DISK ADDRESS )
DO 0 , LOOP ( GROW DICTIONARY )
?FLUSH
HERE A.OUT 4 + FORTH ! ( SIZE OBJECT SIZE IN A.OUT )
FILED @ 0 0 SEEK ( REWIND FILE )
A.OUT 20 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 6 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 )
: \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 META (CONSTANT) HOST , HOST-->META ;
: :
HEADER META (:) HOST ] ;
FORTH : VARIABLE ( --- ) ( CREATES OBJECT VARIABLE INIT'ED TO 0 )
RAMOBJECT FORTH @ HOST
IF HERE CFIELD 2+ \CONSTANT ( RAM VERSION )
HEADER 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.UUCP (06/22/84)
Here is part 2 of 8 of the source for FORTH for the VAX.
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.
Have fun!
-John Hayes
Johns Hopkins University
Applied Physics Laboratory
... seismo!umcp-cs!aplvax!lwt1
---------------------------------- cut here ----------------------------------
echo x - METAASM
cat >METAASM <<'!E!O!F'
( FORTH VAX-11 ASSEMBLER ) HEX
: CODE HEADER HERE 2+ , HOST-->META ;
: PRIM HEADER HOST-->META ;
: MNEMONIC ( OPCODE --- ) ( DEFINING WORD: AT COMPILE )
( TIME, SAVES AN OPCODE; AT RUN-TIME, COMPILES)
( OPCODE INTO DICTIONARY. )
CREATE FORTH , DOES> @ HOST C, ;
: MODE ( MODE# --- ) ( DEFINING WORD: AT COMPILE )
( TIME, SAVES MODE; AT RUN-TIME CATENATE THE )
( MODE AND REG# AND COMPILES INTO DICTIONARY.)
CREATE 4 ROTATE FORTH , DOES> @ + HOST C, ;
F CONSTANT PC ( PC REGISTER )
( ADDRESSING MODES )
4 MODE [] 5 MODE REG 6 MODE )
7 MODE -( 8 MODE )+ 9 MODE *)+
C MODE W( D MODE *W(
: OFFSET ( OFFSET REG# MODE --- ) ( ASSEMBLES A )
( DISPLACEMENT OR DISPLACEMENT DEFERRED )
( ADDRESSING MODE ACCORDING 'MODE'. IF )
( OFFSET WILL FIT IN A BYTE, BYTE OFFSET )
( IS USED. OTHERWISE WORD OFFSET IS USED.)
4 ROTATE +
OVER DUP 80 U< SWAP FF7F U> OR ( WILL OFFSET FIT IN A BYTE? )
IF C, C, ELSE 20 + C, , THEN ;
: X( ( OFFSET REG# --- ) ( TRIES TO ASSEMBLE A )
( BYTE OFFSET. OTHERWISE WORD OFFSET IS USED)
A OFFSET ;
: *X( ( OFFSET REG# --- ) ( TRIES TO ASSEMBLE A )
( BYTE OFFSET. OTHERWISE WORD OFFSET IS USED)
B OFFSET ;
: B$ ( BYTE --- ) ( ASSEMBLE AN IMMEDIATE BYTE. )
( IF POSSIBLE, A SHORT LITERAL IS USED. )
DUP 40 U< IF C, ELSE 8F C, C, THEN ;
: W$ ( WORD --- ) ( ASSEMBLE AN IMMEDIATE WORD. )
( IF POSSIBLE, A SHORT LITERAL IS USED. )
DUP 40 U< IF C, ELSE 8F C, , THEN ;
: L$ ( WORD --- ) ( ASSEMBLE AN IMMEDIATE LONG. )
( IF POSSIBLE, A SHORT LITERAL IS USED. )
DUP 40 U< IF C, ELSE 8F C, S->D SWAP , , THEN ;
: *$ ( ADDR --- ) ( AN ABSOLUTE ADDRESS IS AS- )
( SEMBLED AS A LONG WORD. )
9F C, , 0 , ;
: REL ( ADDR --- ) ( PC WORD RELATIVE ADDRESS IS )
( ASSEMBLED. NO ATTEMPT IS MADE TO COMPACT )
( TO BYTE RELATIVE MODE. )
PC W( HERE 2+ - , ;
: *REL ( ADDR --- ) ( PC WORD RELATIVE ADDRESS IS )
( ASSEMBLED. NO ATTEMPT IS MAKE TO COMPACT )
( TO BYTE RELATIVE MODE. )
PC *W( HERE 2+ - , ;
( 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 , 8 1- 4 * ALLOT HOST
LTABLE 8 4 * 0 FILL ( LABEL TABLE )
: FWD ( LABEL# --- ) ( LEAVE ONE BYTE OF SPACE )
( FOR OFFSET AND LEAVE ADDRESS IN TABLE. )
1 ALLOT HERE SWAP 2* 2* LTABLE + 2+ FORTH ! HOST ;
: BACK ( LABEL# --- ) ( ASSEMBLE BYTE OFFSET FROM )
( ADDRESS IN TABLE AND CURRENT ADDRESS. )
2* 2* LTABLE + FORTH @ HOST HERE 1+ - C, ;
: 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 - SWAP 1- C! THEN
0 OVER 2+ FORTH ! ( OLD LABEL ADDRESS IS DEFUNCT )
HOST HERE SWAP FORTH ! HOST ; ( CURRENT ADDRESS )
( MNEMONICS )
90 MNEMONIC MOVB B0 MNEMONIC MOVW D0 MNEMONIC MOVL
DD MNEMONIC PUSHL 94 MNEMONIC CLRB B4 MNEMONIC CLRW
D4 MNEMONIC CLRL 8E MNEMONIC MNEGB AE MNEMONIC MNEGW
CE MNEMONIC MNEGL 92 MNEMONIC MCOMB B2 MNEMONIC MCOMW
D2 MNEMONIC MCOML 32 MNEMONIC CVTWL 9B MNEMONIC MOVBWZ
9A MNEMONIC MOVZBL 3C MNEMONIC MOVZWL 91 MNEMONIC CMPB
B1 MNEMONIC CMPW D1 MNEMONIC CMPL 96 MNEMONIC INCB
B6 MNEMONIC INCW D6 MNEMONIC INCL 95 MNEMONIC TSTB
B5 MNEMONIC TSTW D5 MNEMONIC TSTL A0 MNEMONIC ADDW2
A1 MNEMONIC ADDW3 C0 MNEMONIC ADDL2 A2 MNEMONIC SUBW2
A3 MNEMONIC SUBW3 C2 MNEMONIC SUBL2 97 MNEMONIC DECB
B7 MNEMONIC DECW D7 MNEMONIC DECL C4 MNEMONIC MULL2
C5 MNEMONIC MULL3 CD MNEMONIC XORL3
7B MNEMONIC EDIV A8 MNEMONIC BISW2 A9 MNEMONIC BISW3
C8 MNEMONIC BISL2 C9 MNEMONIC BISL3 AA MNEMONIC BICW2
AB MNEMONIC BICW3 CA MNEMONIC BICL2 CB MNEMONIC BICL3
AC MNEMONIC XORW2 78 MNEMONIC ASHL 9C MNEMONIC ROTL
12 MNEMONIC BNEQ 13 MNEMONIC BEQL 14 MNEMONIC BGTR
15 MNEMONIC BLEQ 18 MNEMONIC BGEQ 19 MNEMONIC BLSS
1E MNEMONIC BGTRU 1B MNEMONIC BLEQU 1C MNEMONIC BVC
1D MNEMONIC BVS 1E MNEMONIC BGEQU 1F MNEMONIC BLSSU
1E MNEMONIC BCC 1F MNEMONIC BCS
E8 MNEMONIC BLBS E9 MNEMONIC BLBC
11 MNEMONIC BRB F5 MNEMONIC SOBGTR 16 MNEMONIC JSB
05 MNEMONIC RSB FB MNEMONIC CALLS 17 MNEMONIC JMP
BC MNEMONIC CHMK 3B MNEMONIC SKPC 00 MNEMONIC HALT
04 MNEMONIC RET DF MNEMONIC PUSHAL DE MNEMONIC MOVAL
28 MNEMONIC MOVC3
( MACROS )
8 CONSTANT PSP 9 CONSTANT IAR E CONSTANT SP
C CONSTANT AP
: EVEN ( --- ) ( FORCE WORD ALIGNMENT )
HERE 1 AND ALLOT ;
!E!O!F
echo x - README
cat >README <<'!E!O!F'
.TL
Unix-FORTH for the VAX
.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. 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
Two possible portability problems exist. The first is in the a.out format
used. Our version of unix (4.2BSD) uses:
.DS L
/*
* Header prepended to each a.out file.
*/
struct exec {
long a_magic; /* magic number */
unsigned long a_text; /* size of text segment */
unsigned long a_data; /* size of initialized data */
unsigned long a_bss; /* size of uninitialized data */
unsigned long a_syms; /* size of symbol table */
unsigned long a_entry; /* entry point */
unsigned long a_trsize; /* size of text relocation */
unsigned long a_drsize; /* size of data relocation */
};
#define OMAGIC 0407 /* old impure format */
#define NMAGIC 0410 /* read-only text */
#define ZMAGIC 0413 /* demand load format */
.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.
.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.
.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:
John Hayes
JHU/Applied Physics Lab
Johns Hopkins Road
Laurel, MD 20707
(301) 953-5000 x8086
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!Flwt1@aplvax.UUCP (06/22/84)
Here is part 3 of 8 of the source for FORTH for the VAX. 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. Have fun! -John Hayes Johns Hopkins University Applied Physics Laboratory ... seismo!umcp-cs!aplvax!lwt1 ---------------------------------- cut here ---------------------------------- 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: ) ( ) ( John Hayes ) ( JHU/Applied Physics Lab ) ( Johns Hopkins Road ) ( Laurel, MD 20707 ) ( [301] 953-5000 x8086 ) ( ) ( 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. ) ( ) ( VAX FORTH ASSEMBLY LANGUAGE NUCLEUS ) HEX 0 , ( ENTRY MASK ) JMP -1 *$ ( JUMP TO STARTUP CODE: WILL BE BACKPATCHED ) LABEL rsp0 0 , 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 78 RAMALLOT ( 120 BYTE INPUT BUFFER ) ( INDIRECT THREADED CODE INNER INTERPRETER ) PRIM (:) ( CALL: SHOULD NOT BE USED IN A COLON DEF. ) MOVW IAR REG SP -( MOVW 0 REG IAR REG LABEL NEXT ( NEXT ) MOVZWL IAR )+ 0 REG MOVZWL 0 )+ 1 REG JMP 1 ) CODE (;) ( RETURN ) MOVZWL SP )+ IAR REG MOVZWL IAR )+ 0 REG ( NEXT CODE REPEATED FOR SPEED ) MOVZWL 0 )+ 1 REG JMP 1 ) ( [VARIABLE], [CONSTANT], AND [DOES>] ARE RUN TIME WORDS AND SHOULD NOT BE ) ( USED IN COLON DEFINITIONS. POINTERS TO THEIR PFA'S SHOULD BE COMPILED ) ( BY A DEFINING WORD. THIS IS AN ALTERNATIVE TO ;CODE USED IN SOME FORTH ) ( SYSTEMS. ) PRIM (VARIABLE) MOVW 0 REG PSP -( JMP NEXT REL PRIM (CONSTANT) MOVW 0 ) PSP -( JMP NEXT REL PRIM (DOES>) MOVW IAR REG SP -( MOVZWL 0 )+ IAR REG MOVW 0 REG PSP -( JMP NEXT REL ( CONTROL FLOW PRIMITIVES ) CODE (LITERAL) MOVW IAR )+ PSP -( JMP NEXT REL CODE BRANCH 1 L: MOVZWL IAR ) IAR REG JMP NEXT REL CODE ?BRANCH TSTW PSP )+ BEQL 1 BACK ADDW2 2 W$ IAR REG JMP NEXT REL CODE EXECUTE MOVZWL PSP )+ 0 REG MOVZWL 0 )+ 1 REG JMP 1 ) CODE (DO) ADDW3 2 PSP X( 8000 W$ 0 REG MOVW 0 REG SP -( SUBW3 0 REG PSP )+ SP -( ADDW2 2 W$ PSP REG JMP NEXT REL CODE (LOOP) INCW SP ) BVC 1 BACK ADDL2 4 L$ SP REG ADDW2 2 W$ IAR REG JMP NEXT REL CODE (+LOOP) ADDW2 PSP )+ SP ) BVC 1 BACK ADDL2 4 L$ SP REG ADDW2 2 W$ IAR REG JMP NEXT REL CODE I ADDW3 SP ) 2 SP X( PSP -( JMP NEXT REL CODE J ADDW3 4 SP X( 6 SP X( PSP -( JMP NEXT REL CODE (LEAVE) ADDL2 4 L$ SP REG MOVZWL IAR ) IAR REG JMP NEXT REL ( BASIC UNIX SYSTEM INTERFACE ) ( LOW LEVEL SYSTEM CALLS ) LABEL _READ 0 , ( ENTRY MASK ) CHMK 3 W$ BCC 1 FWD CLRL 0 REG 1 L: RET LABEL _WRITE 0 , ( ENTRY MASK ) CHMK 4 W$ BCC 1 FWD MNEGL 1 L$ 0 REG 1 L: RET LABEL _LSEEK 0 , ( ENTRY MASK ) CHMK 13 W$ BCC 1 FWD CLRL 0 REG 1 L: RET LABEL _CREAT 0 , ( ENTRY MASK ) CHMK 8 W$ BCC 1 FWD MNEGL 1 L$ 0 REG ( RETURN A -1 IF ERROR ) 1 L: RET LABEL _OPEN 0 , ( ENTRY MASK ) CHMK 5 W$ BCC 1 FWD MNEGL 1 L$ 0 REG ( RETURN -1 IF ERROR ) 1 L: RET LABEL _CLOSE 0 , ( ENTRY MASK ) CHMK 6 W$ RET LABEL _EXIT 0 , ( ENTRY MASK ) CHMK 1 W$ ( SHOULD NEVER RETURN ) HALT LABEL _FORK 0 , ( ENTRY MASK ) CHMK 2 W$ BGEQU 1 FWD MNEGL 1 L$ 0 REG ( ERROR ) RET 1 L: BLBC 1 REG 2 FWD CLRL 0 REG ( RETURN ZERO IF CHILD ) 2 L: RET LABEL _SIGNAL 0 , ( ENTRY MASK ) CHMK 30 W$ BGEQU 1 FWD MNEGL 1 L$ 0 REG ( ERROR ) 1 L: RET LABEL _WAIT 0 , ( ENTRY MASK ) CHMK 7 W$ BGEQU 1 FWD MNEGL 1 L$ 0 REG ( ERROR ) RET 1 L: TSTL 4 AP X( BEQL 2 FWD MOVL 1 REG 4 AP *X( 2 L: RET LABEL _EXECVE 0 , ( ENTRY MASK ) CHMK 3B W$ HALT ( SHOULD NEVER BE EXECUTED ) EVEN ( INTERRUPT ROUTINES MUST START AT WORD ADDR ) LABEL vector 0 , ( SIGINT INTERRUPT SERVICE ROUTINE ) MOVZWL -1 W$ IAR REG ( MOVE ABORT TO IAR; WILL BE BACKPATCHED ) PUSHAL vector *$ ( PUSH ADDRESS OF INTERRUPT ROUTINE ) PUSHL 2 L$ ( SIGINT ) CALLS 2 L$ _SIGNAL *$ ( IGNORE INTERRUPTS ) JMP NEXT REL ( DATA AND CODE FOR SPAWNING OFF SUB-PROCESSES ) LABEL STATUS 0 , 0 , ( LONG WORD FOR RECEIVING STATUS FROM WAIT ) LABEL NAME 622F , 6E69 , 632F , 6873 , 0 , ( "/bin/csh" ) LABEL 0ARG 7363 , 68 , ( "csh" ) LABEL 1ARG 632D , 0 , ( "-c" ) LABEL ARGV 0ARG , 0 , 1ARG , 0 , 0 , 0 , ( ARGUMENT LIST ) 0 , 0 , ( LIST TERMINATOR ) CODE SHELL ( --- ) ( SPAWN OFF INTERACTIVE SUB-SHELL ) CLRL ARGV 4 + *$ ( sh WITH NO ARGUMENTS ) 0 L: ( SPAWN SUB-PROCESS; SYSTEM SHARES THIS CODE ) CALLS 0 L$ _FORK *$ ( FORK ) TSTL 0 REG BNEQ 1 FWD ( BRANCH IF NOT THE CHILD PROCES ) PUSHL rsp0 *$ ( ENVIRONMENT POINTER ) PUSHAL ARGV *$ ( ADDRESS OF ARGUMENT ARRAY ) PUSHAL NAME *$ ( ADDRESS OF COMMAND NAME ) CALLS 3 L$ _EXECVE *$ ( EXEC CALL; SHOULD NOT RETURN ) 1 L: PUSHL 1 L$ ( SIG_IGN ) PUSHL 2 L$ ( SIGIGT ) CALLS 2 L$ _SIGNAL *$ ( DISABLE INTERRUPTS ) MOVL 0 REG 2 REG ( SAVE OLD INTERRUPT ADDRESS ) PUSHAL STATUS *$ ( ADDRESS OF STATUS WORD ) CALLS 1 L$ _WAIT *$ ( WAIT ) PUSHL 2 REG ( OLD INTERRUPT ADDRESS ) PUSHL 2 L$ ( SIGINT ) CALLS 2 L$ _SIGNAL *$ ( RESTORE OLD INTERRUPT STATE ) JMP NEXT REL CODE SYSTEM ( ADDR[STRING] --- ) ( PASS NULL-TERMINATED ) ( STRING TO SHELL FOR EXECUTION. ) MOVZWL 1ARG W$ ARGV 4 + *$ ( MOVE POINTER TO "-c" TO ARGUMENT LIST ) MOVZWL PSP )+ ARGV 8 + *$ ( MOVE POINTER TO COMMAND STRING TO LIST ) BRB 0 BACK ( BRANCH TO CODE TO SPAWN SUB-SHELL ) ( I/O BUFFER AND CONTROL VARIABLES ) LABEL BLOCK 400 RAMALLOT ( 1024 BYTE INPUT BUFFER ) LABEL SIZE 0 , ( SIZE OF BUFFER IN BYTES ) LABEL INDEX 0 , ( CURRENT OFFSET INTO BLOCK ) LABEL FD 0 , ( FILE DESCRIPTOR OF ASSOCIATED FILE ) ( FILE POSITION TABLE : EACH SLOT HAS A 32 BIT FILE OFFSET. FILE DES- ) ( CRIPTOR 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 R2 ) ( OUTPUT: CHARACTER OR EOF IN R0 ) ( SIDE EFFECTS: R3 IS MODIFIED ) LABEL GETC CMPW 2 REG FD REL BEQL 1 FWD ( SEEK IF NEW FD IS NOT SAME AS OLD FD ) MOVW 2 REG FD REL MOVW SIZE REL INDEX REL ( INDICATE THAT BUFFER IS EMPTY ) CLRL SP -( ( WHENCE IS START OF FILE ) PUSHL 2 [] FILEPOS REL ( PUSH FILE POSITION ) PUSHL 2 REG ( PUSH FILE DESCRITPTOR ) CALLS 3 L$ _LSEEK REL ( SEEK ) 1 L: MOVZWL INDEX REL 3 REG ( R3 HAS INDEX ) CMPW 3 REG SIZE REL BLSS 2 FWD ( READ FILE IF BUFFER IS EMPTY ) PUSHL 400 L$ ( PUSH BLOCK SIZE ) PUSHL BLOCK L$ ( PUSH ADDRESS OF BLOCK ) PUSHL 2 REG ( PUSH FILE DESCRIPTOR ) CALLS 3 L$ _READ REL ( READ ) MOVW 0 REG SIZE REL ( SAVE SIZE ) CLRL 3 REG ( RESET INDEX ) 2 L: CMPW 3 REG SIZE REL BEQL 3 FWD ( BRANCH IF END OF FILE ) INCL 2 [] FILEPOS REL ( UPDATE FILE POSITION ) MOVZBL BLOCK 3 X( 0 REG ( RETURN CHARACTER ) INCW 3 REG ( UPDATE INDEX ) BRB 4 FWD 3 L: MNEGL 1 L$ 0 REG ( RETURN EOF: -1 ) 4 L: MOVW 3 REG INDEX REL ( SAVE INDEX ) RSB CODE FEXPECT ( FD ADDR COUNT --- ACTCOUNT ) MOVZWL 2 PSP X( 4 REG ( BUFFER ADDRESS ) MOVZWL PSP )+ 5 REG ( COUNT ) BEQL 3 FWD 1 L: MOVZWL 2 PSP X( 2 REG ( FILE DESCRIPTOR ) JSB GETC REL ( GET NEXT CHARACTER ) CMPW 0 REG -1 W$ BEQL 4 FWD ( LEAVE LOOP ON EOF ) CMPB 0 REG 09 B$ BNEQ 2 FWD MOVB 20 B$ 0 REG ( CHANGE TABS TO BLANKS ) 2 L: MOVB 0 REG 4 )+ ( SAVE CHARACTER ) CMPB 0 REG 0A B$ BEQL 5 FWD ( LEAVE LOOP ON NEW LINE ) SOBGTR 5 REG 1 BACK ( DECREMENT COUNT AND CONTINUE IF NON-ZERO ) 3 L: 4 L: 5 L: SUBW2 PSP )+ 4 REG ( COMPUTE ACTUAL NUMBER OF CHARACTERS READ ) MOVW 4 REG PSP ) ( RETURN ACTUAL NUMBER ) JMP NEXT REL CODE READ ( FD ADDR COUNT --- ACTCOUNT ) MOVZWL 2 PSP X( 4 REG ( BUFFER ADDRESS ) MOVZWL PSP )+ 5 REG ( COUNT ) BEQL 3 FWD 1 L: MOVZWL 2 PSP X( 2 REG ( FILE DESCRIPTOR ) JSB GETC REL ( GET NEXT CHARACTER ) CMPW 0 REG -1 W$ BEQL 4 FWD ( LEAVE LOOP ON END OF FILE ) MOVB 0 REG 4 )+ ( SAVE CHARACTER ) SOBGTR 5 REG 1 BACK ( DECREMENT COUNT AND CONTINUE IF NON-ZERO ) 3 L: 4 L: SUBW2 PSP )+ 4 REG ( COMPUTE ACTUAL NUMBER OF CHARACTERS READ ) MOVW 4 REG PSP ) ( RETURN ACTUAL COUNT ) JMP NEXT REL CODE WRITE ( ADDR COUNT FD --- ACTCOUNT ) MOVZWL PSP )+ 0 REG ( FILE DESCRIPTOR ) MOVZWL PSP )+ SP -( ( STACK COUNT ) MOVZWL PSP ) SP -( ( STACK ADDRESS ) PUSHL 0 REG ( STACK FILE DESCRIPTOR ) CALLS 3 L$ _WRITE REL ( WRITE ) MOVW 0 REG PSP ) ( RETURN ACTUAL COUNT ) JMP NEXT REL CODE SEEK ( FD OFFSETL OFFSETH --- ) MOVW 2 PSP X( PSP -( MOVL PSP )+ 0 REG ( OFFSET ) ADDW2 2 W$ PSP REG MOVZWL PSP )+ 1 REG ( FILE DESCRIPTOR ) CMPW 1 REG FD REL BNEQ 1 FWD MOVW SIZE REL INDEX REL ( IF SEEKING BUFFERED FILE, RESET BUFFER ) 1 L: MOVL 0 REG 1 [] FILEPOS REL ( SAVE NEW POSITION IN POSITION TABLE ) CLRL SP -( ( WHENCE IS START OF FILE ) PUSHL 0 REG ( OFFSET ) PUSHL 1 REG ( FD ) CALLS 3 W$ _LSEEK REL ( SEEK ) JMP NEXT REL CODE CREAT ( ADDR[STRING] PMODE --- FD ) MOVZWL PSP )+ SP -( ( STACK PROTECTION MODE ) MOVZWL PSP ) SP -( ( STACK ADDRESS OF FILE NAME STRING ) CALLS 2 W$ _CREAT REL ( CREAT SYSTEM CALL ) MOVW 0 REG PSP ) ( RETURN FILE DESCRIPTOR ) BLSS 1 FWD ( SKIP IF CREATION FAILED ) CLRL 0 [] FILEPOS REL ( SET FILE POSITION TO ZERO ) 1 L: JMP NEXT REL CODE OPEN ( ADDR[STRING] MODE --- FD ) MOVZWL PSP )+ SP -( ( STACK MODE ) MOVZWL PSP ) SP -( ( STACK ADDRESS OF FILE NAME ) CALLS 2 W$ _OPEN REL ( OPEN ) MOVW 0 REG PSP ) ( RETURN FILE DESCRIPTOR ) BLSS 1 FWD ( SKIP IF OPEN FAILED ) CLRL 0 [] FILEPOS REL ( RESET FILE POSITION ) 1 L: JMP NEXT REL CODE CLOSE ( FD --- ) MOVZWL PSP )+ SP -( ( STACK FILE DESCRIPTOR ) CALLS 1 W$ _CLOSE REL ( CLOSE ) JMP NEXT REL CODE TERMINATE ( --- ) CLRL SP -( ( RETURN GOOD STATUS ) CALLS 1 W$ _EXIT REL ( EXIT ) JMP NEXT REL ( SHOULD NEVER BE EXECUTED ) ( HIGH LEVEL UTILITIES WRITTEN IN ASSEMBLY LANGUAGE FOR SPEED ) CODE (FIND) ( ADDR[WORD] ADDR[VOCAB] --- 0 <OR> NFA ) MOVZWL PSP )+ 0 REG BEQL 3 FWD MOVZWL PSP ) 1 REG MOVL 1 ) 2 REG 1 L: BICL3 80 L$ 0 ) 3 REG CMPL 2 REG 3 REG BNEQ 2 FWD CMPW 4 1 X( 4 0 X( BEQL 4 FWD 2 L: MOVZWL 6 0 X( 0 REG BNEQ 1 BACK 3 L: 4 L: MOVW 0 REG PSP ) JMP NEXT REL CODE WORD ( DEL --- ADDR ) CLRL 1 REG ADDW3 inbuf W$ in REL 1 REG SKPC PSP ) 100 W$ 1 ) MOVZWL PSP ) 0 REG MOVZWL dp REL 2 REG MOVW 2 REG PSP ) MOVL 1 REG 3 REG 1 L: CMPB 0 REG 3 ) BEQL 2 FWD CMPB 0A B$ 3 ) BEQL 3 FWD INCW 3 REG BRB 1 BACK 2 L: 3 L: SUBW2 1 REG 3 REG MOVB 3 REG 2 )+ BEQL 5 FWD 4 L: MOVB 1 )+ 2 )+ SOBGTR 3 REG 4 BACK 5 L: CMPB 0A B$ 1 ) BEQL 6 FWD INCW 1 REG 6 L: SUBW3 inbuf W$ 1 REG in REL MOVB 20 B$ 2 ) JMP NEXT REL ( STACK PRIMITIVES ) CODE ! MOVZWL PSP )+ 0 REG MOVW PSP )+ 0 ) JMP NEXT REL CODE !SP MOVZWL PSP ) PSP REG JMP NEXT REL CODE + ADDW2 PSP )+ PSP ) JMP NEXT REL CODE +! MOVZWL PSP )+ 0 REG ADDW2 PSP )+ 0 ) JMP NEXT REL CODE - SUBW2 PSP )+ PSP ) JMP NEXT REL CODE -1 MNEGW 1 W$ PSP -( JMP NEXT REL CODE 0 CLRW PSP -( JMP NEXT REL CODE 0< CLRW 0 REG TSTW PSP ) BGEQ 1 FWD MNEGW 1 W$ 0 REG 1 L: MOVW 0 REG PSP ) JMP NEXT REL CODE 0= CLRW 0 REG TSTW PSP ) BNEQ 1 FWD MNEGW 1 W$ 0 REG 1 L: MOVW 0 REG PSP ) JMP NEXT REL CODE 1 MOVW 1 W$ PSP -( JMP NEXT REL CODE 1+ INCW PSP ) JMP NEXT REL CODE 1- DECW PSP ) JMP NEXT REL CODE 2 MOVW 2 W$ PSP -( JMP NEXT REL CODE 2+ ADDW2 2 W$ PSP ) JMP NEXT REL CODE 2- SUBW2 2 W$ PSP ) JMP NEXT REL CODE 2* MOVW PSP ) 0 REG ASHL 1 B$ 0 REG 0 REG MOVW 0 REG PSP ) JMP NEXT REL CODE 2/ CVTWL PSP ) 0 REG ASHL -1 B$ 0 REG 0 REG MOVW 0 REG PSP ) JMP NEXT REL CODE < CLRW 0 REG CMPW PSP )+ PSP ) BLEQ 1 FWD MNEGW 1 W$ 0 REG 1 L: MOVW 0 REG PSP ) JMP NEXT REL CODE = CLRW 0 REG CMPW PSP )+ PSP ) BNEQ 1 FWD MNEGW 1 W$ 0 REG 1 L: MOVW 0 REG PSP ) JMP NEXT REL CODE > CLRW 0 REG CMPW PSP )+ PSP ) BGEQ 1 FWD MNEGW 1 W$ 0 REG 1 L: MOVW 0 REG PSP ) JMP NEXT REL CODE >R MOVW PSP )+ SP -( JMP NEXT REL CODE @ MOVZWL PSP ) 0 REG MOVW 0 ) PSP ) JMP NEXT REL CODE @SP MOVW PSP REG 0 REG MOVW 0 REG PSP -( JMP NEXT REL CODE AND MCOMW PSP )+ 0 REG BICW2 0 REG PSP ) JMP NEXT REL CODE C! MOVZWL PSP )+ 0 REG MOVB PSP )+ 0 ) INCW PSP REG JMP NEXT REL CODE C@ MOVZWL PSP ) 0 REG MOVBWZ 0 ) PSP ) JMP NEXT REL CODE CMOVE MOVZWL PSP )+ 2 REG BEQL 2 FWD MOVZWL PSP ) 0 REG MOVZWL 2 PSP X( 1 REG 1 L: MOVB 1 )+ 0 )+ SOBGTR 2 REG 1 BACK 2 L: ADDW2 4 W$ PSP REG JMP NEXT REL CODE D+ MOVW 2 PSP X( PSP -( MOVW 8 PSP X( 4 PSP X( ADDL2 PSP )+ PSP ) MOVW PSP )+ 2 PSP X( JMP NEXT REL CODE DNEGATE MOVW 2 PSP X( PSP -( MNEGL PSP ) PSP ) MOVW PSP )+ 2 PSP X( JMP NEXT REL CODE D< MOVW 2 PSP X( PSP -( MOVW 8 PSP X( 4 PSP X( CLRW 0 REG CMPL PSP )+ PSP )+ BLEQ 1 FWD MNEGW 1 W$ 0 REG 1 L: MOVW 0 REG PSP ) JMP NEXT REL CODE DROP ADDW2 2 W$ PSP REG JMP NEXT REL CODE DUP MOVW PSP ) PSP -( JMP NEXT REL CODE M* ( S1 S3 --- [S1*S2]L [S1*S2]H ) CVTWL PSP )+ 0 REG CVTWL PSP ) 1 REG MULL3 0 REG 1 REG PSP -( MOVW PSP )+ 2 PSP X( JMP NEXT REL CODE M/ ( SDL SDH DIV --- REM QUOT ) CVTWL PSP ) 0 REG ( DIVISOR IS IN R0 ) MOVW 4 PSP X( PSP ) CLRL 2 REG MOVL PSP )+ 1 REG BGEQ 1 FWD DECL 2 REG ( SIGNED QUADWORD DIVIDEND IS IN R1,R2 ) 1 L: XORL3 2 REG 0 REG 3 REG ( SIGN IS IN R3 ) EDIV 0 REG 1 REG 4 REG 5 REG TSTL 3 REG BGEQ 2 FWD ( BRANCH IF SIGN IS NOT NEGATIVE ) TSTL 5 REG BEQL 3 FWD ( BRANCH IF REMAINDER IS ZERO ) DECL 4 REG ( SUBTRACT ONE FROM QUOTIENT ) ADDL2 0 REG 5 REG ( ADD DIVISOR TO REMAINDER ) 2 L: 3 L: MOVW 5 REG PSP ) ( REMAINDER ) MOVW 4 REG PSP -( ( QUOTIENT ) JMP NEXT REL CODE NEGATE MNEGW PSP ) PSP ) JMP NEXT REL CODE NOT MCOMW PSP ) PSP ) JMP NEXT REL CODE OR BISW2 PSP )+ PSP ) JMP NEXT REL CODE OVER MOVW 2 PSP X( PSP -( JMP NEXT REL CODE R> MOVW SP )+ PSP -( JMP NEXT REL CODE R@ MOVW SP ) PSP -( JMP NEXT REL CODE RESET MOVL rsp0 REL SP REG JMP NEXT REL CODE ROT MOVW 4 PSP X( 0 REG MOVW 2 PSP X( 4 PSP X( MOVW PSP ) 2 PSP X( MOVW 0 REG PSP ) JMP NEXT REL CODE ROTATE BICW3 FFF0 W$ PSP ) 0 REG MOVW 2 PSP X( PSP ) MOVL PSP ) 1 REG ADDW2 2 W$ PSP REG ROTL 0 REG 1 REG 1 REG MOVW 1 REG PSP ) JMP NEXT REL CODE SWAP MOVW 2 PSP X( 0 REG MOVW PSP ) 2 PSP X( MOVW 0 REG PSP ) JMP NEXT REL CODE U< CLRW 0 REG CMPW PSP )+ PSP ) BLEQU 1 FWD MNEGW 1 W$ 0 REG 1 L: MOVW 0 REG PSP ) JMP NEXT REL CODE U> CLRW 0 REG CMPW PSP )+ PSP ) BGEQU 1 FWD MNEGW 1 W$ 0 REG 1 L: MOVW 0 REG PSP ) JMP NEXT REL CODE UM* MOVZWL PSP )+ 0 REG MOVZWL PSP ) 1 REG MULL2 1 REG 0 REG MOVL 0 REG PSP -( MOVW PSP )+ 2 PSP X( JMP NEXT REL CODE UM/ MOVZWL PSP ) 2 REG MOVW 4 PSP X( PSP ) MOVL PSP )+ 3 REG CLRL 4 REG EDIV 2 REG 3 REG 0 REG 1 REG MOVW 1 REG PSP ) MOVW 0 REG PSP -( JMP NEXT REL CODE XOR XORW2 PSP )+ PSP ) JMP NEXT REL !E!O!F
lwt1@aplvax.UUCP (06/22/84)
Here is part 4 of 8 of the source for FORTH for the VAX.
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.
Have fun!
-John Hayes
Johns Hopkins University
Applied Physics Laboratory
... seismo!umcp-cs!aplvax!lwt1
---------------------------------- 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. )
BEGIN
DUP WHILE
DUP @ HERE ROT !
REPEAT DROP ;
: 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
: OTHERWISE ( --- ) ( [OPTIONALLY] COMPILE )
( AN OTHERWISE CASE. )
COMPILE DUP ; 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. IN THIS )
( VERSION, ONLY ONE LEAVE IS ALLOWED PER LOOP LEVEL. )
: 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@ ;
: ,WORD ( DEL --- ) ( ADD TEXT DELIMITED BY )
( DEL INTO DICTIONARY. )
WORD C@ 1+ ALLOT ;
: (.") ( --- )
R> COUNT 2DUP TYPE + >R ;
: ."
COMPILE (.") 22 ,WORD ; IMMEDIATE METASMUDGE
FORTH : ."
META (.") FORTH
22 WORD COUNT DUP HOST C,
OVER + SWAP DO
I FORTH C@ HOST C,
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 + >R STRING ;
: ""
COMPILE ("") 22 ,WORD ; IMMEDIATE METASMUDGE
( DEFINING WORDS )
: CFIELD ( NFA --- CFA )
8 + ;
: NFIELD ( CFA --- NFA )
8 - ;
: -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 6 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 6 ALLOT LATEST , CURRENT @ ! ;
: :
CURRENT @ CONTXT ! ( SET CONTEXT TO CURRENT )
HEADER COMPILE (:) ] SMUDGE ;
: ;
COMPILE (;) SMUDGE 0 STATE ! ; IMMEDIATE METASMUDGE
: VARIABLE
HEADER COMPILE (VARIABLE) 0 , ;
: CONSTANT
HEADER COMPILE (CONSTANT) , ;
: 2VARIABLE
VARIABLE 0 , ;
: DOES>
R> LATEST CFIELD 2+ ! ;
: CREATE
HEADER 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 6 20 FILL
20 WORD LATEST (FIND) ?DUP
IF DUP DP ! 6 + @ 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 6 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
( BACKPATCH )
' ABORT 2+ vector 4 + ! ( PATCH INTERRUPT ROUTINE )
HERE 4 ! ( PATCH JUMP TO STARTUP CODE )
( STARTUP CODE )
MOVZWL inbuf W$ PSP REG ( INITIAL PSP )
PUSHL 1 L$ ( SIG_IGN )
PUSHL 2 L$ ( SIGINT )
CALLS 2 L$ _SIGNAL *$ ( DISABLE INTERRUPTS )
BLBS 0 REG 1 FWD ( BRANCH IF INTERRUPS ALREADY IGNORED )
PUSHAL vector *$ ( PUSH ADDRESS OF INTERRUPT ROUTINE )
PUSHL 2 L$ ( SIGINT )
CALLS 2 L$ _SIGNAL *$ ( CATCH SIGNALS )
1 L: MOVL SP ) 0 REG
INCL 0 REG INCL 0 REG
MOVAL 0 [] SP ) rsp0 *$ ( SAVE ENVIRONMENT POINTER )
MOVZWL HERE 8 + W$ IAR REG ( TRICKY; INITIALIZE IAR )
JMP NEXT REL
( HIGH LEVEL STARTUP CODE )
] HEX TRUE WRN ! 0 CLUE !
FORTH DEFINITIONS
CR ." VAX FORTH, version 2.0"
CR ." (c) 1984 JHU/Applied Physics Lab"
ABORT
[
( INITILIZE VARIABLES AT COMPILE TIME )
HERE DP ! ( INITIAL DP )
OBJLINK FORTH @ HOST initvocab ! ( INITIAL VOCABULARY )
!E!O!Flwt1@aplvax.UUCP (06/22/84)
Here is part 5 of 8 of the source for FORTH for the VAX.
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.
Have fun!
-John Hayes
Johns Hopkins University
Applied Physics Laboratory
... seismo!umcp-cs!aplvax!lwt1
---------------------------------- cut here ----------------------------------
echo x - auto
cat >auto <<'!E!O!F'
" META1" FLOAD
" METAASM" FLOAD
" newforth" -1 CREAT CLOSE
" newforth" 2 OPEN DUP . FORTH FILED !
0 WRN ! HOST
0 RAM HEADS METAMAP METAWARN
" SYS:ASM" FLOAD
" META2" FLOAD
" SYS:SRC" FLOAD
DECIMAL 10000 CLEANUP
!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: no 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!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.
.SH AUTHORS
J. Hayes
!E!O!Flwt1@aplvax.UUCP (06/22/84)
Here is part 6 of 8 of the source for FORTH for the VAX.
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.
Have fun!
-John Hayes
Johns Hopkins University
Applied Physics Laboratory
... seismo!umcp-cs!aplvax!lwt1
---------------------------------- 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.
\
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.
\
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.
\
OTHERWISE - -
Optionally compile an OTHERWISE case into a case control structure. See
SEL for description of its use.
\
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/22/84)
Here is part 7 of 8 of the source for FORTH for the VAX.
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.
Have fun!
-John Hayes
Johns Hopkins University
Applied Physics Laboratory
... seismo!umcp-cs!aplvax!lwt1
---------------------------------- 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; .ascii "TIB "
.word exor-8
tib: .word con+2
.word inbuf
/* SP0 */
.byte 3; .ascii "SP0 "
.word tib-8
sp0: .word con+2
.word pstack
/* DP0 */
.byte 3; .ascii "DP0 "
.word sp0-8
dp0: .word con+2
.word dict
/* WRN */
.byte 3; .ascii "WRN "
.word dp0-8
wrn: .word var+2
.word -1
/* DP */
.byte 2; .ascii "DP "
.word wrn-8
dp: .word var+2
DP: .word 0
/* >IN */
.byte 3; .ascii ">IN "
.word dp-8
in: .word var+2
IN: .word 0
/* STATE */
.byte 5; .ascii "STATE"
.word in-8
state: .word var+2
.word 0
/* BASE */
.byte 4; .ascii "BASE "
.word state-8
base: .word var+2
BASE: .word 0
/* INITVOCAB ( intial vocabulary - will be FORTH ) */
.byte 11; .ascii "INITV"
.word base-8
initvocab: .word var+2
INITVOCAB: .word 0
/* CONTXT ( context vocabulary ) */
.byte 6; .ascii "CONTX"
.word initvocab-8
context: .word var+2
.word INITVOCAB
/* CURRENT ( current vocabulary ) */
.byte 7; .ascii "CURRE"
.word context-8
current: .word var+2
.word INITVOCAB
/* CLUE */
.byte 4; .ascii "CLUE "
.word current-8
clue: .word var+2
.word 0
/* STDIN */
.byte 5; .ascii "STDIN"
.word clue-8
stdin: .word con+2
.word 0
/* STDOUT */
.byte 6; .ascii "STDOU"
.word stdin-8
stdout: .word con+2
.word 1
/* EOL */
.byte 3; .ascii "EOL "
.word stdout-8
eol: .word con+2
.word 012
/* TRUE */
.byte 4; .ascii "TRUE "
.word eol-8
true: .word con+2
.word -1
/* FALSE */
.byte 5; .ascii "FALSE"
.word true-8
false: .word con+2
.word 0
/* Code extensions */
/* ?DUP */
.byte 4; .ascii "?DUP "
.word false-8
qdup: .word call
.word dup, zbranch, 1f, dup; 1: .word return
/* -ROT */
.byte 4; .ascii "-ROT "
.word qdup-8
mrot: .word call
.word rot, rot, return
/* * */
.byte 1; .ascii "* "
.word mrot-8
star: .word call
.word umstar, drop, return
/* 2DUP */
.byte 4; .ascii "2DUP "
.word star-8
twodup: .word call
.word over, over, return
/* S->D */
.byte 4; .ascii "S->D "
.word twodup-8
stod: .word call
.word dup, zeroless, return
/* +- */
.byte 2; .ascii "+- "
.word stod-8
plusminus: .word call
.word zeroless, zbranch, 1f, negate; 1: .word return
/* D+- */
.byte 3; .ascii "D+- "
.word plusminus-8
dplusminus: .word call
.word zeroless, zbranch, 1f, dnegate; 1: .word return
/* ABS */
.byte 3; .ascii "ABS "
.word dplusminus-8
abs: .word call
.word dup, plusminus, return
/* DABS */
.byte 4; .ascii "DABS "
.word abs-8
dabs: .word call
.word dup, dplusminus, return
/* 2DROP */
.byte 5; .ascii "2DROP"
.word dabs-8
twodrop: .word call
.word drop, drop, return
/* UM*M ( ul uh mul --- ul' uh' ) */
.byte 4; .ascii "UM*M "
.word twodrop-8
umstarm: .word call
.word swap, over, umstar, drop, tor, umstar, zero, fromr, dplus
.word return
/* M/MMOD */
.byte 6; .ascii "M/MMO"
.word umstarm-8
mslashmmod: .word call
.word tor, zero, rat, umslash, fromr, swap, tor, umslash, fromr
.word return
/* FILL */
.byte 4; .ascii "FILL "
.word mslashmmod-8
fill: .word call
.word mrot, qdup, zbranch, 2f
.word over, plus, swap, pdo; 1:
.word dup, i, cstore, ploop, 1b, branch, 3f
2: .word drop
3: .word drop, return
/* TOGGLE */
.byte 6; .ascii "TOGGL"
.word fill-8
toggle: .word call
.word over, at, exor, swap, store, return
/* <> */
.byte 2; .ascii "<> "
.word toggle-8
nequal: .word call
.word equal, not, return
/* MAX */
.byte 3; .ascii "MAX "
.word nequal-8
max: .word call
.word twodup, less, zbranch, 1f, swap; 1: .word drop, return
/* HEX */
.byte 3; .ascii "HEX "
.word max-8
hex: .word call
.word lit, 16, base, store, return
/* DECIMAL */
.byte 7; .ascii "DECIM"
.word hex-8
decimal: .word call
.word lit, 10, base, store, return
/* OCTAL */
.byte 5; .ascii "OCTAL"
.word decimal-8
octal: .word call
.word lit, 8, base, store, return
/* 2! ( n1 n2 addr --- ) */
.byte 2; .ascii "2! "
.word octal-8
twostore: .word call
.word swap, over, store, twoplus, store, return
/* Compiling words */
/* HERE */
.byte 4; .ascii "HERE "
.word twostore-8
here: .word call
.word dp, at, return
/* PAD */
.byte 3; .ascii "PAD "
.word here-8
pad: .word call
.word here, lit, 80, plus, return
/* LATEST */
.byte 6; .ascii "LATES"
.word pad-8
latest: .word call
.word current, at, at, return
/* ALLOT */
.byte 5; .ascii "ALLOT"
.word latest-8
allot: .word call
.word dp, plusstore, return
/* , */
.byte 1; .ascii ", "
.word allot-8
comma: .word call
.word here, store, two, allot, return
/* IMMEDIATE */
.byte 9; .ascii "IMMED"
.word comma-8
immediate: .word call
.word latest, lit, 0200, toggle, return
/* SMUDGE */
.byte 6; .ascii "SMUDG"
.word immediate-8
smudge: .word call
.word latest, lit, 0100, toggle, return
/* COMPILE */
.byte 7; .ascii "COMPI"
.word smudge-8
compile: .word call
.word fromr, dup, at, comma, two, plus, tor, return
/* IF */
.byte 2+128; .ascii "IF "
.word compile-8
if: .word call
.word compile, zbranch, here, two, allot, return
/* THEN */
.byte 4+128; .ascii "THEN "
.word if-8
then: .word call
.word here, swap, store, return
/* ELSE */
.byte 4+128; .ascii "ELSE "
.word then-8
else: .word call
.word compile, branch, here, two, allot, here, rot, store, return
/* BEGIN */
.byte 5+128; .ascii "BEGIN"
.word else-8
begin: .word call
.word here, return
/* UNTIL */
.byte 5+128; .ascii "UNTIL"
.word begin-8
until: .word call
.word compile, zbranch, comma, return
/* AGAIN */
.byte 5+128; .ascii "AGAIN"
.word until-8
again: .word call
.word compile, branch, comma, return
/* WHILE */
.byte 5+128; .ascii "WHILE"
.word again-8
while: .word call
.word compile, zbranch, here, two, allot, return
/* REPEAT */
.byte 6+128; .ascii "REPEA"
.word while-8
repeat: .word call
.word compile, branch, swap, comma, here, swap, store, return
/* DO */
.byte 2+128; .ascii "DO "
.word repeat-8
do: .word call
.word compile, pdo, clue, at, zero, clue, store, here, return
/* LOOP */
.byte 4+128; .ascii "LOOP "
.word do-8
loop: .word call
.word compile, ploop, comma, clue, at, qdup, zbranch, 1f
.word here, swap, store
1: .word clue, store, return
/* +LOOP */
.byte 5+128; .ascii "+LOOP"
.word loop-8
plusloop: .word call
.word compile, pploop, comma, clue, at, qdup, zbranch, 1f
.word here, swap, store
1: .word clue, store, return
/* LEAVE */
.byte 5+128; .ascii "LEAVE"
.word plusloop-8
leave: .word call
.word compile, pleave, here, clue, store, two, allot, return
/* [ */
.byte 1+128; .ascii "[ "
.word leave-8
lbracket: .word call
.word zero, state, store, return
/* ] */
.byte 1; .ascii "] "
.word lbracket-8
rbracket: .word call
.word one, state, store, return
/* ( */
.byte 1+128; .ascii "( "
.word rbracket-8
paren: .word call
.word lit, 051, word, drop, return
/* I/O words */
/* TYPE ( addr count --- ) */
.byte 4; .ascii "TYPE "
.word paren-8
type: .word call
.word stdout, write, drop, return
/* EMIT ( chr --- ) */
.byte 4; .ascii "EMIT "
.word type-8
emit: .word call
.word atsp, one, type, drop, return
/* CR */
.byte 2; .ascii "CR "
.word emit-8
cr: .word call
.word eol, emit, return
/* FQUERY ( fd --- actcount ) */
.byte 6; .ascii "FQUER"
.word cr-8
fquery: .word call
.word zero, in, store
.word tib, lit, 120, fexpect, return
/* COUNT */
.byte 5; .ascii "COUNT"
.word fquery-8
count: .word call
.word dup, oneplus, swap, cat, return
/* (.") */
.byte 4; .ascii "(.\") "
.word count-8
pdotquote: .word call
.word fromr, count, twodup, type, plus, tor, return
/* ,WORD */
.byte 5; .ascii "WORD"
.word pdotquote-8
commaword: .word call
.word word, cat, oneplus, allot, return
/* ." */
.byte 2+128; .ascii ".\" "
.word commaword-8
dotquote: .word call
.word compile, pdotquote, lit, 042, commaword, return
/* SPACE */
.byte 5; .ascii "SPACE"
.word dotquote-8
space: .word call
.word lit, 040, emit, return
/* SPACES */
.byte 6; .ascii "SPACE"
.word space-8
spaces: .word call
.word zero, max, qdup, zbranch, 2f
.word zero, pdo; 1: .word space, ploop, 1b
2: .word return
/* STRING ( adr[counted_string] --- adr[string] ) */
.byte 6; .ascii "STRIN"
.word spaces-8
string: .word call
.word count, dup, tor, pad, swap, cmove, zero, pad, fromr, plus
.word cstore, pad, return
/* " ( --- adr[string] ) */
.byte 1; .ascii "\" "
.word string-8
quote: .word call
.word lit, 042, word, string, return
/* ("") ( --- adr[string] ) */
.byte 4; .ascii "(\"\") "
.word quote-8
pdquote: .word call
.word fromr, dup, count, plus, tor, string, return
/* "" */
.byte 2; .ascii "\"\" "
.word pdquote-8
dquote: .word call
.word compile, pdquote, lit, 042, commaword, return
/* Defining words */
/* CFIELD */
.byte 6; .ascii "CFIEL"
.word dquote-8
cfield: .word call
.word lit, 8, plus, return
/* NFIELD */
.byte 6; .ascii "NFIEL"
.word cfield-8
nfield: .word call
.word lit, 8, minus, return
/* -IMM ( nfa --- cfa n ) */
.byte 4; .ascii "-IMM "
.word nfield-8
notimm: .word call
.word dup, cfield, minusone, rot, cat, lit, 0200, and
.word zbranch, 1f, negate; 1: .word return
/* FIND ( addr[name] --- addr2 n ) */
.byte 4; .ascii "FIND "
.word notimm-8
find: .word call
.word dup, context, at, at, pfind
.word qdup, zbranch, 1f, swap, drop, notimm, branch, 3f
1: .word dup, latest, pfind
.word qdup, zbranch, 2f, swap, drop, notimm, branch, 3f
2: .word zero
3: .word return
/* ' */
.byte 1; .ascii "' "
.word find-8
tic: .word call
.word here, lit, 6, lit, 040, fill
.word lit, 040, word
.word find, zeroeq, zbranch, 1f, drop, zero; 1: .word return
/* HEADER */
.byte 6; .ascii "HEADE"
.word tic-8
cheader: .word call
.word tic, zbranch, 1f
.word wrn, at, zbranch, 1f
.word here, count, type
.word pdotquote; .byte 13; .ascii " isn't unique"
.word cr
1: .word here, lit, 6, allot, latest, comma, current, at, store
.word return
/* : */
.byte 1; .ascii ": "
.word cheader-8
colon: .word call
.word current, at, context, store
.word cheader, compile, call, rbracket, smudge, return
/* ; */
.byte 1+128; .ascii "; "
.word colon-8
semicolon: .word call
.word compile, return, smudge, zero, state, store, return
/* VARIABLE */
.byte 8; .ascii "VARIA"
.word semicolon-8
variable: .word call
.word cheader, compile, var+2, zero, comma, return
/* CONSTANT */
.byte 8; .ascii "CONST"
.word variable-8
constant: .word call
.word cheader, compile, con+2, comma, return
/* 2VARIABLE */
.byte 9; .ascii "2VARI"
.word constant-8
twovar: .word call
.word variable, zero, comma, return
/* DOES> */
.byte 5; .ascii "DOES>"
.word twovar-8
does: .word call
.word fromr, latest, cfield, twoplus, store, return
/* CREATE */
.byte 6; .ascii "CREAT"
.word does-8
create: .word call
.word cheader, compile, pdoes+2, zero, comma, does, return
/* VOCABULARY */
.byte 10; .ascii "VOCAB"
.word create-8
vocabulary: .word call
.word create, here, twoplus, comma, latest, comma
.word does, at, context, store, return
/* DEFINITIONS */
.byte 11; .ascii "DEFIN"
.word vocabulary-8
definitions: .word call
.word context, at, current, store, return
/* FORTH FORTH vocabulary */
.byte 5+128; .ascii "FORTH"
.word definitions-8
forth: .word call
.word initvocab, context, store, return
/* numeric output words */
/* HLD */
.byte 3; .ascii "HLD "
.word forth-8
hld: .word var+2
.word 0
/* HOLD */
.byte 4; .ascii "HOLD "
.word hld-8
hold: .word call
.word minusone, hld, plusstore, hld, at, cstore, return
/* <# */
.byte 2; .ascii "<# "
.word hold-8
lnum: .word call
.word pad, hld, store, return
/* #> */
.byte 2; .ascii "#> "
.word lnum-8
gnum: .word call
.word twodrop, hld, at, pad, over, minus, return
/* SIGN */
.byte 4; .ascii "SIGN "
.word gnum-8
sign: .word call
.word zeroless, zbranch, 1f, lit, 055, hold; 1: .word return
/* # */
.byte 1; .ascii "# "
.word sign-8
num: .word call
.word base, at, mslashmmod, rot, lit, 011, over, less
.word zbranch, 1f, lit, 7, plus; 1:
.word lit, 060, plus, hold, return
/* #S */
.byte 2; .ascii "#S "
.word num-8
nums: .word call
1: .word num, twodup, or, zeroeq, zbranch, 1b, return
/* D.R */
.byte 3; .ascii "D.R "
.word nums-8
ddotr: .word call
.word tor, swap, over, dabs, lnum, nums, rot, sign, gnum
.word fromr, over, minus, spaces, type, return
/* ZEROES */
.byte 6; .ascii "ZEROE"
.word ddotr-8
zeroes: .word call
.word zero, max, qdup, zbranch, 2f, zero, pdo; 1:
.word lit, 060, emit, ploop, 1b
2: .word return
/* D.LZ */
.byte 4; .ascii "D.LZ "
.word zeroes-8
ddotlz: .word call
.word tor, swap, over, dabs, lnum, nums, rot, sign, gnum
.word fromr, over, minus, zeroes, type, return
/* D. */
.byte 2; .ascii "D. "
.word ddotlz-8
ddot: .word call
.word zero, ddotr, space, return
/* .R */
.byte 2; .ascii ".R "
.word ddot-8
dotr: .word call
.word tor, stod, fromr, ddotr, return
/* . */
.byte 1; .ascii ". "
.word dotr-8
dot: .word call
.word stod, ddot, return
/* U.R */
.byte 3; .ascii "U.R "
.word dot-8
udotr: .word call
.word zero, swap, ddotr, return
/* U.LZ */
.byte 4; .ascii "U.LZ "
.word udotr-8
udotlz: .word call
.word zero, swap, ddotlz, return
/* utilities */
/* [COMPILE] */
.byte 9+128; .ascii "[COMP"
.word udotlz-8
bcompile: .word call
.word tic, comma, return
/* DUMP ( addr bytes --- ) */
.byte 4; .ascii "DUMP "
.word bcompile-8
dump: .word call
.word cr, over, plus, swap, pdo; 1:
.word i, lit, 4, udotlz, pdotquote; .byte 1; .ascii ":"
.word space
.word i, lit, 8, plus, i, pdo; 2:
.word i, cat, two, udotlz, space, ploop, 2b
.word i, lit, 8, plus, i, pdo; 3:
.word i, cat, dup, lit, 040, less
.word over, lit, 0177, equal, or
.word zbranch, 4f, drop, lit, 056; 4:
.word emit, ploop, 3b
.word cr, lit, 8, pploop, 1b
.word return
/* operating system support words */
/* DIGIT ( char --- n true <or> false ) */
.byte 5; .ascii "DIGIT"
.word dump-8
digit: .word call
.word lit, 060, minus
.word dup, lit, 9, greater, over, lit, 17, less, and
.word zbranch, 1f
.word drop, false, branch, 4f
1: .word dup, lit, 9, ugreater, zbranch, 2f
.word lit, 7, minus
2: .word dup, base, at, oneminus, ugreater, zbranch, 3f
.word drop, false, branch, 4f
3: .word true
4: .word return
/* CONVERT ( dl dh addr1 --- dl' dh' addr2 ) */
.byte 7; .ascii "CONVE"
.word digit-8
convert: .word call
.word tor; 1:
.word fromr, oneplus, dup, tor, cat, digit
.word zbranch, 2f, tor, base, at, umstarm, fromr, zero, dplus
.word branch, 1b
2: .word fromr, return
/* NUMBER ( ADDR --- N TRUE <OR> FALSE ) */
.byte 6; .ascii "NUMBE"
.word convert-8
number: .word call
.word dup, oneplus, cat, lit, 055, equal, dup, tor, minus
.word zero, zero, rot, convert
.word cat, lit, 040, equal, zbranch, 1f
.word drop, fromr, plusminus, true, branch, 2f
1: .word twodrop, fromr, drop, false
2: .word return
/* ?STACK ( --- T/F ) ( returns true if stack underflow ) */
.byte 6; .ascii "?STAC"
.word number-8
qstack: .word call
.word atsp, sp0, greater, return
/* CHUCKBUF ( chuck rest of input buffer ) */
.byte 8; .ascii "CHUCK"
.word qstack-8
chuckbuf: .word call
.word tib, in, at, plus
1: .word dup, cat, eol, nequal, zbranch, 2f, oneplus
.word branch, 1b
2: .word tib, minus, in, store, return
/* ENDINTERP ( --- ) ( flush reset of input buffer ) */
.byte 9; .ascii "ENDIN"
.word chuckbuf-8
endinterp: .word call
.word sp0, storesp /* reset stack pointer */
.word chuckbuf, return
/* INTERPRET */
.byte 9; .ascii "INTER"
.word endinterp-8
interpret: .word call
1: .word here, lit, 6, lit, 040, fill
.word lit, 040, word, cat, zbranch, 9f
.word here, find, qdup, zbranch, 4f
.word state, at, plus
.word zbranch, 2f, execute, branch, 3f; 2: .word comma; 3:
.word branch, 7f
4: .word number, zbranch, 6f
.word state, at, zbranch, 5f, compile, lit, comma; 5:
.word branch, 7f
6: .word here, count, type, pdotquote; .byte 2; .ascii " ?"
.word cr,endinterp
7: .word qstack, zbranch, 8f, pdotquote
.byte 12; .ascii " Stack empty"; .word cr, endinterp; 8:
.word branch, 1b
9: .word return
/* FLOAD ( adr[string] --- ) */
.byte 5; .ascii "FLOAD"
.word interpret-8
fload: .word call
.word zero, open, dup, zeroless, zbranch, 0f
.word drop, pdotquote; .byte 11; .ascii " can't open"
.word cr, branch, 3f
0: .word tor
1: .word rat, fquery, zbranch, 2f, interpret, branch, 1b
2: .word fromr, close, chuckbuf
3: .word return
/* QUIT */
.byte 4; .ascii "QUIT "
.word fload-8
quit: .word call
.word zero, state, store, sp0, storesp
.word cr, pdotquote; .byte 21; .ascii "VAX FORTH version 1.0"
1: .word cr, stdin, fquery, zbranch, 3f
.word interpret
.word state, at, zeroeq, zbranch, 2f, pdotquote
.byte 3; .ascii " OK"
2: .word branch, 1b
3: .word cr, terminate, return
/* the rest of the dictionary */
dict: .space 20000
!E!O!Flwt1@aplvax.UUCP (06/22/84)
Here is part 8 of 8 of the source for FORTH for the VAX. 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. Have fun! -John Hayes Johns Hopkins University Applied Physics Laboratory ... seismo!umcp-cs!aplvax!lwt1 ---------------------------------- 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: * * John Hayes * JHU/Applied Physics Lab * Johns Hopkins Road * Laurel, MD 20707 * (301) 953-5000 x8086 * * 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. */ /* * VAX-FORTH indirect threaded code inner interpreter */ .text .word 0x0 /* entry mask */ /* start-up code */ movzwl $pstack,r8 /* initialize r8 */ movw $dict,DP /* initialize dictionary pointer */ movw $16,BASE /* base is hex */ movw $quit-8,INITVOCAB movzwl $quit+2,r9 /* initialize r9 */ brw next /* parameter stack */ .space 256 pstack: /* text input buffer */ inbuf: .space 120 /* (:) */ .byte 3; .ascii "(:) " .word 0 /* end of dictionary */ pcolon: .word call call: movw r9,-(sp) movw r0,r9 next: movzwl (r9)+,r0 movzwl (r0)+,r1 jmp (r1) /* (;) */ .byte 3; .ascii "(;) " .word pcolon-8 return: .word return+2 movzwl (sp)+,r9 movzwl (r9)+,r0 /* repetion of next code for speed */ movzwl (r0)+,r1 jmp (r1) /* (VARIABLE) */ .byte 10; .ascii "(VARI" .word return-8 var: .word var+2 movw r0,-(r8) brw next /* (CONSTANT) */ .byte 10; .ascii "(CONS" .word var-8 con: .word con+2 movw (r0),-(r8) brw next /* (DOES>) */ .byte 7; .ascii "(DOES" .word con-8 pdoes: .word pdoes+2 movw r9,-(sp) movzwl (r0)+,r9 movw r0,-(r8) brw next /* (LITERAL) */ .byte 9; .ascii "(LITE" .word pdoes-8 lit: .word lit+2 movw (r9)+,-(r8) brw next /* BRANCH */ .byte 6; .ascii "BRANC" .word lit-8 branch: .word branch+2 1: movzwl (r9),r9 brw next /* ?BRANCH */ .byte 7; .ascii "?BRAN" .word branch-8 zbranch: .word zbranch+2 tstw (r8)+ beql 1b addw2 $2,r9 brw next /* EXECUTE */ .byte 7; .ascii "EXECU" .word zbranch-8 execute: .word execute+2 movzwl (r8)+,r0 movzwl (r0)+,r1 jmp (r1) /* (DO) */ .byte 4; .ascii "(DO) " .word execute-8 pdo: .word pdo+2 addw3 2(r8),$0100000,r0 movw r0,-(sp) subw3 r0,(r8)+,-(sp) addw2 $2,r8 brw next /* (LOOP) */ .byte 6; .ascii "(LOOP" .word pdo-8 ploop: .word ploop+2 incw (sp) bvc 1b addl2 $4,sp addw2 $2,r9 brw next /* (+LOOP) */ .byte 7; .ascii "(+LOO" .word ploop-8 pploop: .word pploop+2 addw2 (r8)+,(sp) bvc 1b addl2 $4,sp addw2 $2,r9 brw next /* I */ .byte 1; .ascii "I " .word pploop-8 i: .word i+2 addw3 (sp),2(sp),-(r8) brw next /* J */ .byte 1; .ascii "J " .word i-8 j: .word j+2 addw3 4(sp),6(sp),-(r8) brw next /* (LEAVE) */ .byte 7; .ascii "(LEAV" .word j-8 pleave: .word pleave+2 addl2 $4,sp movzwl (r9),r9 brw next /* basic system interface */ /* I/O buffer and control variables */ block: .space 1024 size: .word 0 /* size in bytes */ indx: .word 0 /* current offset into block */ fd: .word 0 /* file descriptor of associated file*/ /* file position table: each slot has a 32 bit file ofsett. file des- criptor is offset into table. There are 15 slots */ filepos: .long 0 .long 0 .long 0 .long 0 .long 0 .long 0 .long 0 .long 0 .long 0 .long 0 .long 0 .long 0 .long 0 .long 0 .long 0 /* low level system calls */ _read: .word 0 /* entry mask */ chmk $3 bcc 1f clrl r0 /* if error, length is zero */ 1: ret _write: .word 0 /* entry mask */ chmk $4 bcc 1f mnegl $1,r0 /* return -1 on error */ 1: ret _lseek: .word 0 /* entry mask */ chmk $19 bcc 1f clrl r0 /* return zero if error */ 1: ret _creat: .word 0 /* entry mask */ chmk $8 bcc 1f mnegl $1,r0 1: ret _open: .word 0 /* entry mask */ chmk $5 bcc 1f mnegl $1,r0 /* return negative file descriptor on error */ 1: ret _close: .word 0 /* entry mask */ chmk $6 ret /* ignore errors */ _exit: .word 0 /* entry mask */ chmk $1 /* should never return */ halt /* subroutine getc: handles all input and does buffering input: file descriptor in r2 output: character of -1 in r0 side effects: r2, r3 */ getc: cmpw r2,*$fd beql 1f /* do seek if new fd is not same as old fd */ movw r2,*$fd movw *$size,*$indx /* indicate that buffer is empty */ clrl -(sp) /* whence is start of file */ pushl *$filepos[r2] /* push file position */ pushl r2 /* push file descriptor */ calls $3,_lseek /* seek */ 1: movzwl *$indx,r3 /* r3 has index */ cmpw r3,*$size blss 2f /* read file if buffer is empty */ pushl $1024 /* push block size */ pushl $block /* push address of buffer */ pushl r2 /* push file descriptor */ calls $3,_read /* read */ movw r0,*$size /* save size */ clrl r3 /* reset index */ 2: cmpw r3,*$size beql 3f /* branch if end of file */ incl *$filepos[r2] /* update file position */ movzbl block(r3),r0 /* return character */ incw r3 /* update index */ brb 4f 3: movl $-1,r0 /* return -1 */ 4: movw r3,*$indx /* save index */ rsb /* FEXPECT ( fd addr count --- actcount ) */ .byte 7; .ascii "FEXPE" .word pleave-8 fexpect: .word fexpect+2 movzwl 2(r8),r6 /* buffer address */ movzwl (r8)+,r7 /* count */ beql 3f /* do nothing if count is zero */ 1: movzwl 2(r8),r2 /* file descriptor */ jsb *$getc /* get next character */ cmpb r0,$-1 beql 3f /* leave loop on -1 */ cmpb r0,$011 bneq 2f movw $040,r0 /* change tabs to blanks */ 2: movb r0,(r6)+ /* save character */ cmpb r0,$012 beql 3f /* leave loop on newline */ sobgtr r7,1b /* decrement counter and continue if non-zero */ 3: subw2 (r8)+,r6 /* compute actual number of characters read */ movw r6,(r8) /* return actual number */ brw next /* READ ( fd addr count --- actcount ) */ .byte 4; .ascii "READ " .word fexpect-8 read: .word read+2 movzwl 2(r8),r4 /* buffer address */ movzwl (r8)+,r5 /* count */ beql 3f 1: movzwl 2(r8),r2 /* file descriptor */ jsb *$getc /* get next character */ cmpw r0,$-1 beql 3f /* leave loop on -1 */ movb r0,(r4)+ /* save character */ sobgtr r5,1b /* decrement count and continue if non-zero */ 3: subw2 (r8)+,r4 /* compute actual number of characters read */ movw r4,(r8) /* return actual count */ brw next /* WRITE ( addr count fd --- actcount ) */ .byte 5; .ascii "WRITE" .word read-8 write: .word write+2 movzwl (r8)+,r0 /* file descriptor */ movzwl (r8)+,-(sp) /* stack count */ movzwl (r8),-(sp) /* stack address */ pushl r0 /* stack file descriptor */ calls $3,_write /* write */ movw r0,(r8) /* return actual count */ brw next /* SEEK ( fd offsetl offseth --- ) */ .byte 4; .ascii "SEEK " .word write-8 seek: .word seek+2 movw 2(r8),-(r8) movl (r8)+,r0 /* offset */ addw2 $2,r8 movzwl (r8)+,r1 /* file descriptor */ cmpw r1,*$fd bneq 1f movw *$size,*$index /* if seeking buffered file, reset buffer */ 1: movl r0,filepos[r1] /* save new position in position table */ clrl -(sp) /* whence is start of file */ pushl r0 /* offset */ pushl r1 /* fd */ calls $3,_lseek /* seek */ brw next /* CREAT ( addr[string] pmode --- fd ) */ .byte 5; .ascii "CREAT" .word seek-8 creat: .word creat+2 movzwl (r8)+,-(sp) /* stack protection mode */ movzwl (r8),-(sp) /* stack address of file name string */ calls $2,_creat /* creat system call */ movw r0,(r8) /* return file descriptor */ blss 1f /* skip if creation failed */ clrl filepos[r0] /* set file position to zero */ 1: brw next /* OPEN ( addr[strin] mode --- fd ) */ .byte 4; .ascii "OPEN " .word creat-8 open: .word open+2 movzwl (r8)+,-(sp) /* stack mode */ movzwl (r8),-(sp) /* stack address of file name */ calls $2,_open /* open */ movw r0,(r8) /* return file descriptor */ blss 1f /* skip of open faled */ clrl filepos[r0] /* reset file positions */ 1: brw next /* CLOSE ( fd --- ) */ .byte 5; .ascii "CLOSE" .word open-8 close: .word close+2 movzwl (r8)+,-(sp) /* stack file descriptor */ calls $1,_close /* close */ brw next /* TERMINATE ( --- ) */ .byte 9; .ascii "TERMI" .word close-8 terminate: .word terminate+2 clrl -(sp) /* return good status */ calls $1,_exit /* exit */ /* high level utilities written in assembly language for speed */ /* (FIND) ( addr[word] addr[vocab] --- 0 <or> nfa ) */ .byte 6; .ascii "(FIND" .word terminate-8 pfind: .word pfind+2 movzwl (r8)+,r0 beql 3f movzwl (r8),r1 movl (r1),r2 1: bicl3 $128,(r0),r3 cmpl r2,r3 bneq 2f cmpw 4(r1),4(r0) beql 3f 2: movzwl 6(r0),r0 bneq 1b 3: movw r0,(r8) brw next /* WORD */ .byte 4; .ascii "WORD " .word pfind-8 word: .word word+2 clrl r1 addw3 $inbuf,*$IN,r1 skpc (r8),$1000,(r1) movzwl (r8),r0 movzwl *$DP,r2 movw r2,(r8) movzwl r1,r3 1: cmpb r0,(r3) beql 2f cmpb $012,(r3) beql 2f incw r3 brb 1b 2: subw2 r1,r3 movb r3,(r2)+ beql 4f 3: movb (r1)+,(r2)+ sobgtr r3,3b 4: cmpb $012,(r1) beql 5f incw r1 5: subw3 $inbuf,r1,*$IN movb $040,(r2) brw next /* VAX-FORTH stack primitives */ /* ! */ .byte 1; .ascii "! " .word word-8 store: .word store+2 movzwl (r8)+,r0 movw (r8)+,(r0) brw next /* !SP */ .byte 3; .ascii "!SP " .word store-8 storesp: .word storesp+2 movzwl (r8),r8 brw next /* + */ .byte 1; .ascii "+ " .word storesp-8 plus: .word plus+2 addw2 (r8)+,(r8) brw next /* +! */ .byte 2; .ascii "+! " .word plus-8 plusstore: .word plusstore+2 movzwl (r8)+,r0 addw2 (r8)+,(r0) brw next /* - */ .byte 1; .ascii "- " .word plusstore-8 minus: .word minus+2 subw2 (r8)+,(r8) brw next /* -1 */ .byte 2; .ascii "-1 " .word minus-8 minusone: .word minusone+2 movw $-1,-(r8) brw next /* 0 */ .byte 1; .ascii "0 " .word minusone-8 zero: .word zero+2 clrw -(r8) brw next /* 0< */ .byte 2; .ascii "0< " .word zero-8 zeroless: .word zeroless+2 clrw r0 tstw (r8) bgeq 1f movw $-1,r0 1: movw r0,(r8) brw next /* 0= */ .byte 2; .ascii "0= " .word zeroless-8 zeroeq: .word zeroeq+2 clrw r0 tstw (r8) bneq 1f movw $-1,r0 1: movw r0,(r8) brw next /* 1 */ .byte 1; .ascii "1 " .word zeroeq-8 one: .word one+2 movw $1,-(r8) brw next /* 1+ */ .byte 2; .ascii "1+ " .word one-8 oneplus: .word oneplus+2 incw (r8) brw next /* 1- */ .byte 2; .ascii "1- " .word oneplus-8 oneminus: .word oneminus+2 decw (r8) brw next /* 2 */ .byte 1; .ascii "2 " .word oneminus-8 two: .word two+2 movw $2,-(r8) brw next /* 2+ */ .byte 2; .ascii "2+ " .word two-8 twoplus: .word twoplus+2 addw2 $2,(r8) brw next /* 2- */ .byte 2; .ascii "2- " .word twoplus-8 twominus: .word twominus+2 subw2 $2,(r8) brw next /* 2* */ .byte 2; .ascii "2* " .word twominus-8 twostar: .word twostar+2 movw (r8),r0 ashl $1,r0,r0 movw r0,(r8) brw next /* 2/ */ .byte 2; .ascii "2/ " .word twostar-8 twoslash: .word twoslash+2 cvtwl (r8),r0 ashl $-1,r0,r0 movw r0,(r8) brw next /* < */ .byte 1; .ascii "< " .word twoslash-8 less: .word less+2 clrw r0 cmpw (r8)+,(r8) bleq 1f movw $-1,r0 1: movw r0,(r8) brw next /* = */ .byte 1; .ascii "= " .word less-8 equal: .word equal+2 clrw r0 cmpw (r8)+,(r8) bneq 1f movw $-1,r0 1: movw r0,(r8) brw next /* > */ .byte 1; .ascii "> " .word equal-8 greater: .word greater+2 clrw r0 cmpw (r8)+,(r8) bgeq 1f movw $-1,r0 1: movw r0,(r8) brw next /* >R */ .byte 2; .ascii ">R " .word greater-8 tor: .word tor+2 movw (r8)+,-(sp) brw next /* @ */ .byte 1; .ascii "@ " .word tor-8 at: .word at+2 movzwl (r8),r0 movw (r0),(r8) brw next /* @SP */ .byte 3; .ascii "@SP " .word at-8 atsp: .word atsp+2 movw r8,r0 movw r0,-(r8) brw next /* AND */ .byte 3; .ascii "AND " .word atsp-8 and: .word and+2 mcomw (r8)+,r0 bicw2 r0,(r8) brw next /* C! */ .byte 2; .ascii "C! " .word and-8 cstore: .word cstore+2 movzwl (r8)+,r0 movb (r8)+,(r0) incw r8 brw next /* C@ */ .byte 2; .ascii "C@ " .word cstore-8 cat: .word cat+2 movzwl (r8),r0 movzbw (r0),(r8) brw next /* CMOVE */ .byte 5; .ascii "CMOVE" .word cat-8 cmove: .word cmove+2 movzwl (r8)+,r2 beql 2f movzwl (r8),r0 movzwl 2(r8),r1 1: movb (r1)+,(r0)+ sobgtr r2,1b 2: addl2 $4,r8 brw next /* D+ */ .byte 2; .ascii "D+ " .word cmove-8 dplus: .word dplus+2 movw 2(r8),-(r8) movw 8(r8),4(r8) addl2 (r8)+,(r8) movw (r8)+,2(r8) brw next /* DNEGATE */ .byte 7; .ascii "DNEGA" .word dplus-8 dnegate: .word dnegate+2 movw 2(r8),-(r8) mnegl (r8),(r8) movw (r8)+,2(r8) brw next /* D< */ .byte 2; .ascii "D< " .word dnegate-8 dless: .word dless+2 movw 2(r8),-(r8) movw 8(r8),4(r8) clrw r0 cmpl (r8)+,(r8)+ bleq 1f movw $-1,r0 1: movw r0,(r8) brw next /* DROP */ .byte 4; .ascii "DROP " .word dless-8 drop: .word drop+2 addw2 $2,r8 brw next /* DUP */ .byte 3; .ascii "DUP " .word drop-8 dup: .word dup+2 movw (r8),-(r8) brw next /* M* */ .byte 2; .ascii "M* " .word dup-8 mstar: .word mstar+2 cvtwl (r8)+,r0 cvtwl (r8),r1 mull3 r0,r1,-(r8) movw (r8)+,2(r8) brw next /* M/ */ .byte 2; .ascii "M/ " .word mstar-8 mslash: .word mslash+2 cvtwl (r8),r0 /* divisor in r0 */ movw 4(r8),(r8) clrl r2 movl (r8)+,r1 bgeq 1f decl r2 /* signed quadword dividend in r1,r2 */ 1: xorl3 r2,r0,r3 /* expected sign in r3 */ ediv r0,r1,r4,r5 tstl r3 bgeq 2f /* branch if sign not negative */ tstl r1 beql 2f /* branch if remainder is zero */ decl r4 /* subtract one from quotient */ addl2 r0,r5 /* add divisor to remainder */ 2: movw r5,(r8) /* remainder */ movw r4,-(r8) /* quotient */ brw next /* NEGATE */ .byte 6; .ascii "NEGAT" .word mslash-8 negate: .word negate+2 mnegw (r8),(r8) brw next /* NOT */ .byte 3; .ascii "NOT " .word negate-8 not: .word not+2 mcomw (r8),(r8) brw next /* OR */ .byte 2; .ascii "OR " .word not-8 or: .word or+2 bisw2 (r8)+,(r8) brw next /* OVER */ .byte 4; .ascii "OVER " .word or-8 over: .word over+2 movw 2(r8),-(r8) brw next /* R> */ .byte 2; .ascii "R> " .word over-8 fromr: .word fromr+2 movw (sp)+,-(r8) brw next /* R@ */ .byte 2; .ascii "R@ " .word fromr-8 rat: .word rat+2 movw (sp),-(r8) brw next /* ROT */ .byte 3; .ascii "ROT " .word rat-8 rot: .word rot+2 movw 4(r8),r0 movw 2(r8),4(r8) movw (r8),2(r8) movw r0,(r8) brw next /* ROTATE */ .byte 6; .ascii "ROTAT" .word rot-8 rotate: .word rotate+2 bicw3 $0177760,(r8),r0 movw 2(r8),(r8) movl (r8),r1 addw2 $2,r8 rotl r0,r1,r1 movw r1,(r8) brw next /* SWAP */ .byte 4; .ascii "SWAP " .word rotate-8 swap: .word swap+2 movw 2(r8),r0 movw (r8),2(r8) movw r0,(r8) brw next /* U< */ .byte 2; .ascii "U< " .word swap-8 uless: .word uless+2 clrw r0 cmpw (r8)+,(r8) blequ 1f movw $-1,r0 1: movw r0,(r8) brw next /* U> */ .byte 2; .ascii "U> " .word uless-8 ugreater: .word ugreater+2 clrw r0 cmpw (r8)+,(r8) bgequ 1f movw $-1,r0 1: movw r0,(r8) brw next /* UM* */ .byte 3; .ascii "UM* " .word ugreater-8 umstar: .word umstar+2 movzwl (r8)+,r0 movzwl (r8),r1 mull2 r1,r0 movl r0,-(r8) movw (r8)+,2(r8) brw next /* UM/ */ .byte 3; .ascii "UM/ " .word umstar-8 umslash: .word umslash+2 movzwl (r8),r2 movw 4(r8),(r8) movl (r8)+,r3 clrl r4 ediv r2,r3,r0,r1 movw r1,(r8) movw r0,-(r8) brw next /* XOR */ .byte 3; .ascii "XOR " .word umslash-8 exor: .word exor+2 xorw2 (r8)+,(r8) brw next !E!O!F