UNIX FORTH for the PDP11 (part 5 of 7)
lwt1 at aplvax.UUCP
lwt1 at aplvax.UUCP
Sat Jun 9 05:56:38 AEST 1984
Here is part 5 of the source for FORTH for the PDP-11.
Delete everything thru the "-- cut here --" line, and extract with 'sh':
sh part1 part2 ... part7
where 'part?' are whatever you've named the files. Note the copyright
notice at the end of README. Please let us know how things go. While
we can't support this software, we'll be posting bug fixes/upgrades to
net.sources as time permits.
VAX-FORTH should be 'forth'-coming {yuk-yuk} within a couple of weeks.
Have fun!
-Lloyd W. Taylor
... seismo!umcp-cs!aplvax!lwt1
---I will have had been there before, soon---
---------------------------------- cut here ----------------------------------
echo x - METAASM
cat >METAASM <<'+E+O+F'
( FORTH PDP-11 ASSEMBLER ) OCTAL
VARIABLE *OPCODE ( VARIABLE POINTS TO LATEST OPCODE )
: CODE ( CREATES A CODE DEFINITION )
HEADER HOST-->META ;
: OPBUILD ( OPERANDFIELD --- ) ( ADDS OPERAND FIELD )
( CONSISTING OF ADDRESSING MODE AND REGISTER)
( TO LATEST OPCODE. )
*OPCODE FORTH @ DUP HOST @ ( OPERAND OPADDR OPCODE )
6 ROTATE ROT OR SWAP ! ;
: BYTE ( --- ) ( CONVERTS MOST RECENT OPCODE TO )
( BYTE ADDRESSING. MUST BE USED AT END OF )
( ASSEMBLY LANGUAGE LINE. )
*OPCODE FORTH @
HOST DUP @ 100000 OR SWAP ! ;
: MNEMONIC ( OPCODE --- ) ( DEFINING WORD DEFINES )
( MNEMONIC. WORDS DEFINED WITH MNEMONIC )
( COMMA THEIR OPCODES INTO THE DICTION- )
( ARY WHEN EXECUTED. )
CREATE FORTH , HOST ( SAVE OPCODE )
DOES> HERE *OPCODE FORTH ! @ HOST , ;
( SAVE OPCODE ADDRESS; COMMA OPCODE INTO DIC )
( ADDRESSING MODES )
: REG ( REG# --- ) ( REGISTER ADDRESSING )
OPBUILD ;
: ) ( REG# --- ) ( REGISTER DEFERRED )
10 OR OPBUILD ;
: )+ ( REG# --- ) ( AUTO-INCREMENT )
20 OR OPBUILD ;
: *)+ ( REG# --- ) ( AUTO-INCREMENT DEFERRED )
30 OR OPBUILD ;
: -( ( REG# --- ) ( AUTO-DECREMENT )
40 OR OPBUILD ;
: *-( ( REG# --- ) ( AUTO-DECREMENT DEFERRED )
50 OR OPBUILD ;
: X( ( OFFSET REG# --- ) ( INDEXED ADDRESSING )
60 OR OPBUILD , ;
: *X( ( OFFSET REG# --- ) ( INDEX DEFERRED )
70 OR OPBUILD , ;
: $ ( IMMEDIATE --- ) ( IMMEDIATE )
27 OPBUILD , ;
: *$ ( ADDR --- ) ( ABSOLUTE )
37 OPBUILD , ;
: REL ( ADDR --- ) ( RELATIVE )
67 OPBUILD
*OPCODE FORTH @ HOST - 4 - , ;
: *REL ( ADDR --- ) ( RELATIVE DEFERRED )
77 OPBUILD
*OPCODE FORTH @ HOST - 4 - , ;
: REG-ONLY ( REG# --- ) ( FOR REGISTER ONLY INSTRUC- )
( TIONS SUCH AS MUL OR DIV. )
*OPCODE FORTH @ DUP HOST @ ( REG# OPADDR OPCODE )
3 ROTATE ROT OR SWAP ! ;
( LOCAL LABELS: EIGHT LOCAL LABELS ARE ALLOWED NUMBERED FROM 0 TO 7 )
( ONLY ONE FORWARD BRANCH PER LABEL IS ALLOWED. ANY NUMBER OF BACK- )
( WARD BRANCHES IS ALLOWED. )
VARIABLE LTABLE FORTH 0 , 10 1- 4 * ALLOT HOST
LTABLE 10 4 * 0 FILL ( LABEL TABLE )
: FWD ( LABEL# --- ) ( LEAVE ADDRESS IN TABLE. )
HERE SWAP 2* 2* LTABLE + 2+ FORTH ! HOST ;
: BACK ( LABEL# --- ) ( ADD OFFSET TO PREVIOUSLY )
( COMPILED WORD. )
2* 2* LTABLE + FORTH @ HOST HERE - 2/ 377 AND HERE 2- DUP @ ROT OR SWAP ! ;
: L: ( LABEL# --- ) ( RESOLVE FORWARD BRANCHES, )
( PURGE TABLE, AND ADD CURRENT ADDRESS. )
2* 2* LTABLE + DUP 2+ FORTH @ ?DUP IF ( IF LABEL NEEDS RESOLUTION )
HOST HERE OVER - 2/ 377 AND SWAP 2- DUP @ ROT OR SWAP ! THEN
0 OVER 2+ FORTH ! ( OLD LABEL ADDRESS IS DEFUNCT )
HOST HERE SWAP FORTH ! HOST ; ( CURRENT ADDRESS )
( MNEMONICS )
050 MNEMONIC CLR 051 MNEMONIC COM 052 MNEMONIC INC
053 MNEMONIC DEC 054 MNEMONIC NEG 057 MNEMONIC TST
060 MNEMONIC ROR 061 MNEMONIC ROL 062 MNEMONIC ASR
063 MNEMONIC ASL 003 MNEMONIC SWB 055 MNEMONIC ADC
056 MNEMONIC SBC 067 MNEMONIC SXT 01 MNEMONIC MOV
02 MNEMONIC CMP 06 MNEMONIC ADD 16 MNEMONIC SUB
03 MNEMONIC BIT 04 MNEMONIC BIC 05 MNEMONIC BIS
074 MNEMONIC EXOR 070 MNEMONIC MUL 071 MNEMONIC DIV
001 MNEMONIC JMP 004 MNEMONIC JSR 020 MNEMONIC RTS
261 MNEMONIC SEC
002 MNEMONIC RTI
000400 MNEMONIC BR 001000 MNEMONIC BNE 001400 MNEMONIC BEQ
100000 MNEMONIC BPL 100400 MNEMONIC BMI 102000 MNEMONIC BVC
102400 MNEMONIC BVS 103000 MNEMONIC BCC 103400 MNEMONIC BCS
002000 MNEMONIC BGE 002400 MNEMONIC BLT 003000 MNEMONIC BGT
003400 MNEMONIC BLE 101000 MNEMONIC BHI 101400 MNEMONIC BLOS
103000 MNEMONIC BHIS 103400 MNEMONIC BLO
( SOB: SUBTRACT ONE AND BRANCH INSTRUCTION )
: SOB ( LABEL# REG# --- )
6 ROTATE 77000 OR
HERE 2+ ROT 2* 2* LTABLE + FORTH @ HOST - 2/ OR , ;
: TRAP ( TRAP# --- )
104400 + , ;
( MACROS )
4 CONSTANT IAR 5 CONSTANT PSP 6 CONSTANT SP
7 CONSTANT PC
: NEXT ( --- ) ( COMPILES CODE FOR NEXT )
JMP IAR *)+ ;
+E+O+F
echo x - META1
cat >META1 <<'+E+O+F'
( METACOMPILER, PART 1 -- ALLOWS METACOMPILATION OF PRIMITIVES ) HEX
: METACOMPILER ; ( MARK BEGINNING OF METACOMPILER FOR 'FORGET')
( METACOMPILER DATABASE )
VARIABLE OBJLINK ( OBJECT SYSTEM VOCABULARY POINTER )
2VARIABLE WDS ( OBJECT SYSTEM HEADER LENGTH IN BYTES )
VARIABLE W0 ( BASE OF OBJECT DICTIONARY SPACE )
VARIABLE 'H ( OBJECT SYSTEM DICTIONARY POINTER )
VARIABLE 'R ( OBJECT SYSTEM RAM POINTER )
VARIABLE RAMOBJECT ( TRUE=RAM OBJECT, FALSE=PROM OBJECT )
VARIABLE METASTATE ( TRUE=METACOMPILE, FALSE=EXECUTE )
0 METASTATE !
VARIABLE METAMP ( METACOMPILER MAPPING ENABLE/DISABLE )
: METAMAP TRUE METAMP ! ;
: NOMETAMAP FALSE METAMP ! ;
VARIABLE WRNMETA ( METACOMPILER WARNING ENABLE/DISABLE )
: METAWARN TRUE WRNMETA ! ;
: NOMETAWARN FALSE WRNMETA ! ;
VOCABULARY META IMMEDIATE
VOCABULARY HOST IMMEDIATE HOST DEFINITIONS
: VOCSSAVE ( --- V1 V2 ) ( SAVE VOCABS ON STACK )
CONTXT @ CURRENT @ ;
: VOCSRESTORE ( V1 V2 --- ) ( UNDO 'VOCSSAVE' )
CURRENT ! CONTXT ! ;
: PREVIOUS ( --- N ) ( PRODUCES THE CONTENTS OF THE FIRST WORD OF )
( THE PARAMETER FIELD OF THE MOST RECENT DEFINTION IN )
( VOCABULARY META. IF THIS WAS AN 'EMPLACE' DEFINTION, THE )
( VALUE RETURNED WILL BE THE TARGET SYSTEM OPCODE OF THE )
( EMPLACE WORD. THIS IS USEFUL FOR IMMEDIATING. )
VOCSSAVE
[COMPILE] META DEFINITIONS
LATEST CFIELD 6 + @ -ROT
VOCSRESTORE ;
: FIND ( ADDR[NAME] --- ADDR2 N ) ( DICTIONARY SEARCH )
( RESTRICTED TO VOCABULARY 'META' )
VOCSSAVE >R >R ( SAVE CONTEXT, CURRENT ON RET STACK )
[COMPILE] META DEFINITIONS ( SELECT META VOCABULARY )
FIND ( SEARCH DICTIONARY )
R> R> VOCSRESTORE ; ( RESTORE CURRENT AND CONTEXT )
: HOST-->META ( --- ) ( UNLINK LATEST ENTRY IN VOCABULARY 'HOST' AND )
( RELINK IT INTO VOCABULARY 'META'. )
VOCSSAVE ( SAVE CONTEXT AND CURRENT ON STACK )
[COMPILE] HOST DEFINITIONS ( SET CONTEXT AND CURRENT TO 'HOST' )
LATEST DUP 4 + @ CURRENT @ ! ( MOVE BACK 'HOST' VOCAB POINTER )
[COMPILE] META DEFINITIONS ( SET CONTEXT AND CURRENT TO 'META' )
LATEST @ 4D84 = ( SET LINK OF FIRST ENTRY IN 'META' )
IF 0 ELSE LATEST ( [I.E., THE ONE AFTER 'META' ITSELF])
THEN OVER 4 + ! ( TO 0, ELSE LINK NORMALLY )
CURRENT @ ! ( MOVE UP 'META' VOCAB POINTER )
VOCSRESTORE ; ( RESTORE OLD CURRENT AND CONTEXT )
: METASMUDGE ( --- ) ( SMUDGE THE MOST RECENT META DEFINITION )
VOCSSAVE
[COMPILE] META DEFINITIONS SMUDGE
VOCSRESTORE ;
: HERE 'H @ ; ( --- N ) ( RETURN VALUE OF OBJECT DICTIONARY POINTER )
: RAMHERE ( --- N ) ( RETURN VALUE OF OBJECT RAM POINTER )
RAMOBJECT @ IF HERE ELSE 'R @ THEN ;
: ALLOT ( N --- ) ( ALLOT 'N' WORDS OF OBJECT DICTIONARY SPACE )
'H +! ;
: RAMALLOT ( N --- ) ( ALLOT 'N' WORDS OF OBJECT RAM SPACE )
RAMOBJECT @
IF ALLOT
ELSE 'R +!
THEN ;
: RAM ( N --- ) ( SET RAMOBJECT FLAG TRUE [RAM], INITIALIZE )
( 'H, W0 AND 'R TO N, AND ZERO ENTIRE OBJECT DICTIONARY. )
( 'H, W0 AND 'R TO N, OBJLINK TO 0, AND ZERO ENTIRE )
( OBJECT DICTIONARY. )
TRUE RAMOBJECT !
DUP 'H ! DUP W0 ! 'R ! 0 OBJLINK ! ;
: PROM ( N --- ) ( SET RAMOBJECT FLAG FALSE [PROM], INITIALIZE )
( 'H AND W0 TO N, OBJLINK TO 0, OBJECT DICTIONARY TO 0'S. )
FALSE RAMOBJECT !
DUP 'H ! W0 ! 0 OBJLINK ! ;
: NOHEAD 0 WDS ! ; ( --- ) ( MAKE NEXT OBJECT DEFINITION HEADLESS )
: HEADS 6 6 WDS 2! ; ( --- ) ( FOLLOWING OBJECT DEFINITIONS HAVE HEADS )
: NOHEADS 0 0 WDS 2! ; ( --- ) ( FOLLOWING OBJECT DEFINITIONS HEADLESS )
( CODE FOR HANDLING META-COMPILATION RANDOM ACCESS FILES ) DECIMAL
VARIABLE BUFFER 510 FORTH ALLOT HOST
BUFFER 512 0 FILL
VARIABLE DIRTY ( TRUE IF BUFFER IS INCONSISTENT )
FALSE DIRTY ! ( WITH DISK FILE. )
VARIABLE IMAGE ( HOLDS TARGET ADDRESS THAT COR- )
-1 IMAGE ! ( RESPONDS TO BUFFER. )
VARIABLE FILED ( FILE DESCRIPTOR OF META OBJECT FILE)
: ?FLUSH ( --- ) ( FLUSH BUFFER IF DIRTY )
( FLAG SET. )
DIRTY @ IF
FILED @ IMAGE @ 0 SEEK ( SEEK POSITION IN FILE FOR BUFFER )
BUFFER 512 FILED @ WRITE DROP ( WRITE BACK TO DISK )
FALSE DIRTY ! ( BUFFER IS CONSISTENT WITH DISK )
THEN ;
: GET ( ADDR --- ) ( TRIES TO READ 512 )
( BYTES FROM DISK AT ADDR AND PUTS )
( INTO BUFFER. )
BUFFER 512 0 FILL ( ZERO BUFFER )
DUP IMAGE ! ( RECORD ADDRESS )
FILED @ SWAP 0 SEEK ( POSITION FILE READ POINTER )
FILED @ BUFFER 512 READ DROP ; ( TRY TO READ 512 BYTES )
HEX
: T->R ( ADDR --- ADDR' ) ( TRANSLATES )
( TARGET ADDRESS IN ADDRESS IN )
( BUFFER. DOES BUFFER FLUSHING )
( AND READING IF NECESSARY. )
10 + ( SKIP A.OUT HEADER )
DUP 1FF AND SWAP FE00 AND ( OFFSET 512*BLOCK# )
DUP IMAGE @ = IF ( IF ALREADY IN RAM )
DROP ( DO NOTHING )
ELSE
?FLUSH GET ( ELSE GET NEEDED BLOCK )
THEN BUFFER + ;
: C@ ( ADDR --- BYTE )
T->R C@ ;
: C! ( BYTE ADDR --- )
T->R C! TRUE DIRTY ! ;
: @ ( ADDR --- WORD )
DUP 1+ C@ 8 ROTATE ( FETCH HIGH BYTE FIRST )
SWAP C@ OR ; ( THEN FETCH LOW BYTE )
: ! ( WORD ADDR --- )
>R DUP FF AND R@ C! ( STORE LOW BYTE )
FF00 AND 8 ROTATE R> 1+ C! ; ( STORE HIGH BYTE )
: , ( WORD --- )
HERE ! 2 ALLOT ;
: .O ( N --- ) ( PRINT N IN OCTAL WITHOUT CHANGEING BASE. )
BASE FORTH @ OCTAL SWAP . BASE ! HOST ;
: EMPLACE ( --- ) ( LOGS AND CREATES A WORD WHOSE PARAMETER FIELD )
( CONTAINS THE TARGET ADDRESS OF THE NEXT CODE FIELD IN THE )
( TARGET SPACE. WHEN THE WORD IS EXECUTED, THIS VALUE )
( [PRESUMABLY THE OPCODE OF THE 'EMPLACED' WORD] IS )
( COMPILED INTO THE OBJECT DICTIONARY. )
HERE FORTH WDS @ + ( HEADER? )
FORTH METAMP @
IF
DUP .O HERE COUNT TYPE CR ( PRINT CFA[OCTAL] AND NAME )
THEN
CREATE , DOES> @ HOST , ;
: HEADER ( --- ) ( CREATES AN OBJECT DICTIONARY ENTRY AND A )
( CORRESPONDING 'EMPLACE' ENTRY IN THE HOST VOCABULARY. )
WRNMETA FORTH @ HOST ( CHECK METAWARNING FLAG )
IF >IN FORTH @ ( SAVE INPUT POINTER )
HERE 4 20 FILL 20 WORD HOST FIND ( SEARCH META FOR NEW WORD )
IF FORTH HERE COUNT TYPE ( PRINT WARNING IF WORD FOUND)
SPACE ." isn't unique [Meta]" CR
THEN DROP
>IN ! HOST ( RESTORE INPUT POINTER )
THEN
EMPLACE ( CREATE 'EMPLACE' ENTRY )
WDS FORTH @ HOST ( TEST FOR OBJ HDR CREATION )
IF HERE FORTH LATEST @ HOST , ( OBJECT HEADER, 1ST WORD )
FORTH LATEST 2+ @ HOST , ( OBJECT HEADER, 2ND WORD )
OBJLINK FORTH @ HOST , ( OBJECT LINK FIELD )
OBJLINK FORTH ! HOST ( UPDATE PTR TO OBJECT VOCAB )
THEN WDS 2+ FORTH @ WDS ! HOST ; ( RESET TEMP HEADER LENGTH )
: LABEL
HERE METAMP FORTH @ IF
DUP .O ( PRINT ADDRESS OF LABEL )
>IN @ ( PEEK AHEAD INTO INPUT STREAM )
20 WORD COUNT TYPE ." Label" CR
>IN !
THEN
CONSTANT HOST ;
: ' ( --- CFA <OR> 0 ) ( RETURNS CFA OF TARGET WORD THAT FOLLOWS)
FORTH HERE 4 20 FILL
HOST 20 WORD FIND
IF 6 + FORTH @ HOST
ELSE DROP 0
THEN ;
: DUMPOBJ ( ADDR N --- ) ( DUMPS N WORDS OF OBJECT SPACE FROM ADDR )
CR OVER + SWAP
DO
I 4 U.LZ ." :" SPACE
I 8 + I DO
I C@ 2 U.LZ SPACE
LOOP
I 8 + I DO
I C@ DUP 20 < OVER 7F = OR
IF DROP 2E THEN
EMIT
LOOP
CR
8 +LOOP ;
( CODE FOR CLEANING UP AFTER A METACOMPILATION )
VARIABLE A.OUT ( A.OUT HEADER )
FORTH 107 A.OUT ! 0 , 0 , 0 , 0 , 0 , 0 , 1 , HOST
: CLEANUP ( FREE_DICT_SIZE --- ) ( CLEANS UP )
( AFTER A METACOMPILATION. MAKES )
( DISK IMAGE FILE GROW UNTIL IT HAS )
( AT LEAST THE FREE_DICT_SIZE ASKED )
( FOR. WRITES THE A.OUT HEADER OUT. )
HERE + 10 + 200 + FE00 AND ( COMPUTE UPPER LIMIT DISK ADDRESS )
HERE 10 + ( COMPUTE LOWER LIMIT DISK ADDRESS )
DO 0 , LOOP ( GROW DICTIONARY )
?FLUSH
HERE A.OUT 2+ FORTH ! ( SIZE OBJECT SIZE IN A.OUT )
FILED @ 0 0 SEEK ( REWIND FILE )
A.OUT 10 FILED @ WRITE DROP ( WRITE A.OUT HEADER TO DISK )
FILED @ CLOSE HOST ;
+E+O+F
echo x - META2
cat >META2 <<'+E+O+F'
( METACOMPILER, PART 2 -- ALLOWS METACOMPILATION OF : DEFINITIONS, ) HEX
( VARIABLES AND CONSTANTS IN A SINGLE VOCABULARY )
: ] ( --- ) ( MAIN METACOMPILER INTERPRETATION LOOP )
TRUE METASTATE FORTH !
BEGIN
FORTH >IN @ 20 WORD SWAP >IN !
C@ METASTATE @ AND WHILE
HERE 4 20 FILL 20 WORD HOST FIND IF
EXECUTE
ELSE
NUMBER IF
META (LITERAL) HOST ,
ELSE
FORTH HERE COUNT TYPE ." ? [Meta]" CR ENDINTERP
THEN
THEN
?STACK IF ." Stack empty [Meta]" CR ENDINTERP THEN
REPEAT ; HOST
: FLOAD ( --- ) ( METACOMPILER LOADER; CONTINUES META : DEFINITIONS )
0 OPEN
DUP 0< IF
DROP ." can't open" CR
ELSE
>R BEGIN
R@ FQUERY WHILE
METASTATE FORTH @ HOST IF
]
THEN INTERPRET
REPEAT R> CLOSE CHUCKBUF
THEN ;
( METACOMPILER DIRECTIVES )
: ( 29 WORD DROP ; HOST-->META ( START OF COMMENT )
: [ ( --- ) ( EXIT METACOMPILER LOOP ']' )
FORTH FALSE METASTATE ! HOST ; HOST-->META
: IF META ?BRANCH HOST HERE 0 , ; HOST-->META
: WHILE META IF HOST ; HOST-->META
: ELSE META BRANCH HOST HERE 0 , HERE ROT ! ; HOST-->META
: THEN HERE SWAP ! ; HOST-->META
: DO META (DO) FORTH CLUE @ 0 CLUE ! HOST HERE ; HOST-->META
: LOOP META (LOOP) HOST ,
FORTH CLUE @ ?DUP IF HOST HERE SWAP ! THEN
FORTH CLUE ! HOST ; HOST-->META
: +LOOP META (+LOOP) HOST ,
FORTH CLUE @ ?DUP IF HOST HERE SWAP ! THEN
FORTH CLUE ! HOST ; HOST-->META
: LEAVE META (LEAVE) HOST HERE FORTH CLUE ! HOST 0 , ; HOST-->META
: BEGIN HERE ; HOST-->META
: UNTIL META ?BRANCH HOST , ; HOST-->META
: AGAIN META BRANCH HOST , ; HOST-->META
: REPEAT META BRANCH HOST SWAP , HERE SWAP ! ; HOST-->META
: ; META (;) HOST HOST-->META
FORTH FALSE METASTATE ! HOST ; HOST-->META
( METACOMPILER IMMEDIATOR )
: IMMEDIATE ( --- ) ( TOGGLES IMMEDIATE BIT IN LATEST TARGET HEAD)
PREVIOUS NFIELD DUP C@ 80 OR
SWAP C! ;
( DEFINING WORDS )
: CALL ( --- ) ( COMPILE JSR IAR,*$--- INTO TARGET CODE. )
091F , ;
: \CONSTANT ( N --- ) ( DEFINES THE NEXT INPUT WORD AS A CONSTANT )
( 'N' IN THE RESIDENT SYSTEM'S CURRENT VOCABULARY )
( WITHOUT MOVING THE INPUT POINTER '>IN'. )
>IN FORTH @ SWAP CONSTANT >IN ! ; HOST
: CONSTANT
DUP \CONSTANT
HEADER CALL META (CONSTANT) HOST , HOST-->META ;
: :
HEADER CALL META (:) HOST ] ;
FORTH : VARIABLE ( --- ) ( CREATES OBJECT VARIABLE INIT'ED TO 0 )
RAMOBJECT FORTH @ HOST
IF HERE CFIELD 4 + \CONSTANT ( RAM VERSION )
HEADER CALL META (VARIABLE) HOST 0 , HOST-->META
ELSE RAMHERE CONSTANT 2 RAMALLOT ( PROM VERSION )
THEN ;
FORTH : 2VARIABLE ( --- ) ( CREATES OBJECT 2VARIABLE INIT'ED TO 0 )
VARIABLE
RAMOBJECT FORTH @ HOST
IF 0 , ( RAM VERSION )
ELSE 2 RAMALLOT ( PROM VERSION )
THEN ;
+E+O+F
More information about the Comp.sources.unix
mailing list