UNIX FORTH for the VAX (part 1 of 8)
lwt1 at aplvax.UUCP
lwt1 at aplvax.UUCP
Sat Jun 23 04:41:23 AEST 1984
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!F
More information about the Comp.sources.unix
mailing list