Relay-Version: version B 2.10 5/3/83; site utzoo.UUCP Posting-Version: version B 2.10 5/3/83; site aplvax.UUCP Path: utzoo!watmath!clyde!burl!mgnetp!ihnp4!drutx!houxe!hogpc!houti!ariel!vax135!cornell!uw-beaver!tektronix!hplabs!hao!seismo!rlgvax!cvl!umcp-cs!aplvax!lwt1 From: lwt1@aplvax.UUCP Newsgroups: net.sources Subject: UNIX FORTH for the VAX (part 1 of 8) Message-ID: <670@aplvax.UUCP> Date: Fri, 22-Jun-84 14:41:23 EDT Article-I.D.: aplvax.670 Posted: Fri Jun 22 14:41:23 1984 Date-Received: Wed, 27-Jun-84 09:24:32 EDT Organization: JHU/Applied Physics Lab, Laurel, MD Lines: 358 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 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