\ META86.SEQ The META compiler Source for F-PC. \ F-PC : Forth-83 with separated heads, handles, and sequential files. \ Meta compiler. Loaded by F-PC to produce KERNEL.COM. \ ************************************************************* \ *** ORIGINALLY Based on F83 version 2.1.0 by *** \ *** *** \ *** Henry Laxen and Michael Perry *** \ *** 1259 Cornell Avenue 1125 Bancroft Way *** \ *** Berkeley, California Berkeley, California *** \ *** 94706 94702 *** \ *** *** \ ************************************************************* \ Heads separation by: J. D. Hopper \ P.O. Box 2782 \ Stanford, Ca. 94305 \ Handles and \ sequential files by: Tom Zimmer Hm (408) 263-8859 \ 292 Falcato Drive Wk (408) 432-4643 \ Milpitas, Ca. 95035 \ Direct Threaded Code \ conversion by: Bob Smith and Tom Zimmer \ \ Contact: Tom Zimmer Hm (408) 263-8859 \ 292 Falcato Drive Wk (408) 432-4643 \ Milpitas, Ca. 95035 0COMPILER : ZSAVE ( Addr len | filename -- ) \ Save code from external segment. SHNDL+ !HCB SHNDL+ HDELETE DROP SHNDL+ HCREATE ABORT" Save Create ERR!" SHNDL+ HWRITE 0= ABORT" Save Write ERR!" SHNDL+ HCLOSE ABORT" Save Close ERR!" ; WARNING OFF ONLY FORTH ALSO DEFINITIONS 15 TABSIZE ! \ WIDER TABS 78 RMARGIN ! \ WIDER RIGHT MARGIN 0 LMARGIN ! \ LEFT MARGIN TO LEFT EDGE ?DARK \ CLEAR SCREEN AND CLEAR #LINE : .TITLE CR ." Meta Compiled Direct Threaded Forth " .DATE TAB .TIME CR CR ; ONLY FORTH ALSO VOCABULARY META META ALSO META DEFINITIONS VARIABLE SEG-Y VARIABLE SEG-X 64 CONSTANT #TTHREADS : MEMCHK ABORT" Insufficient Memory" ; HEX : DOSVER 0 30 BDOS 0FF AND ; : DOSCHK DOSVER 2 < ABORT" Must have DOS >=2" ; DOSCHK 800 CONSTANT HEADSEGS \ 800 hex is 32k decimal bytes 800 CONSTANT LISTSEGS \ Create and erase the buffers HEADSEGS ALLOC 8 = MEMCHK NIP DUP SEG-Y ! 0 HEADSEGS 10 * 0 LFILL LISTSEGS ALLOC 8 = MEMCHK NIP DUP SEG-X ! 0 LISTSEGS 10 * 0 LFILL DECIMAL : NYTH ( cfa -- ythread) 512 / 2* ; : ?NEWPAGE ( --- ) PRINTING @ 0= IF EXIT THEN #LINE @ 60 > IF CR 12 SP@ 1 TYPE DROP #LINE OFF CR .TITLE THEN ; VARIABLE LABELS LABELS OFF \ DEFAULT TO NOT DISPLAY MAP : ?LABELS ( --- ) CR CR ." Do you want LABELS printed Y/N [N]? " KEY BL OR ASCII y = DUP LABELS ! IF ." Y" ELSE ." N" THEN CR .TITLE TIME-RESET ; ?LABELS 3 CONSTANT BODY_SIZE \ SIZE OF BODY FIELD IN BYTES : >BODY-T ( A1 --- A2 ) \ Move to body of target BODY_SIZE + ; VARIABLE DP-T : [FORTH] FORTH ; IMMEDIATE : [META] META ; IMMEDIATE : [ASSEMBLER] ASSEMBLER ; IMMEDIATE : SWITCH ( -- ) NOOP ( Context ) NOOP ( Current ) DOES> \ @ DUP X@ CONTEXT @ SWAP CONTEXT ! OVER X! 2+ \ DUP X@ CURRENT @ SWAP CURRENT ! SWAP X! ; @ XSEG @ + DUP 0 @L CONTEXT @ SWAP CONTEXT ! OVER 0 !L DUP 2 @L CURRENT @ SWAP CURRENT ! SWAP 2 !L ; SWITCH ( Redefine itself ) 0 CONSTANT TARGET-ORIGIN : THERE ( taddr -- addr ) TARGET-ORIGIN + ; : C@-T ( taddr -- char ) THERE C@ ; : @-T ( taddr -- n ) THERE @ ; : C!-T ( char taddr -- ) THERE C! ; : !-T ( n taddr -- ) THERE ! ; : HERE-T ( -- taddr ) DP-T @ ; : ALLOT-T ( n -- ) DP-T +! ; : C,-T ( char -- ) HERE-T C!-T 1 ALLOT-T ; : ,-T ( n -- ) HERE-T !-T 2 ALLOT-T ; : S,-T ( addr len -- ) 0 ?DO COUNT C,-T LOOP DROP ; : XS: ( taddr -- taddr tseg ) SEG-X @ SWAP ; VARIABLE DP-X 0 DP-X ! VARIABLE DPSEG-X SEG-X @ DPSEG-X ! : PARAGRAPH-X ( N1 --- SEG-DELTA ) 15 + U16/ ; : >XREL ( SEG OFFSET --- OFFSET ) \ RELATIVE TO SEG-X SWAP SEG-X @ - 16 * + ; : C@-X ( taddr -- char ) XS: C@L ; : @-X ( taddr -- n ) XS: @L ; : C!-X ( char taddr -- ) XS: C!L ; : !-X ( n taddr -- ) XS: !L ; : HERE-X ( -- XDPSEG taddr ) DPSEG-X @ DP-X @ ; : ALLOT-X ( n -- ) DP-X +! ; : C,-X ( char -- ) HERE-X C!L 1 ALLOT-X ; : ,-X ( n -- ) HERE-X !L 2 ALLOT-X ; : S,-X ( addr len -- ) 0 ?DO COUNT C,-X LOOP DROP ; : ALIGN-X ( --- ) HERE-X NIP 1 AND IF 0 C,-X THEN ; : YS: SEG-Y @ SWAP ; VARIABLE DP-Y 256 DP-Y ! : C@-Y ( yaddr -- char ) YS: C@L ; : @-Y ( yaddr -- n ) YS: @L ; : C!-Y ( char yaddr -- ) YS: C!L ; : !-Y ( n yaddr -- ) YS: !L ; : HERE-Y ( -- yaddr ) DP-Y @ ; : ALLOT-Y ( n -- ) DP-Y +! ; : C,-Y ( char -- ) HERE-Y C!-Y 1 ALLOT-Y ; : ,-Y ( n -- ) HERE-Y !-Y 2 ALLOT-Y ; : S,-Y ( addr len ) 0 ?DO COUNT C,-Y LOOP DROP ; : CSET-Y ( byte yaddr -- ) TUCK C@-Y OR SWAP C!-Y ; : SVXSEG ( - xstart ) SEG-X @ 0 ?CS: HERE-T DUP >R THERE HERE-X PARAGRAPH-X + SEG-X @ - 16 * CR ." LIST size = " DUP U. CMOVEL R> ; : SVYSEG ( - ystart ) SEG-Y @ 0 ?CS: HERE-T DUP >R THERE HERE-Y CR ." HEAD size = " DUP U. CMOVEL R> ; HEX : CNHASH ( CFA-YA ) 0FE00 AND FLIP ; DECIMAL VOCABULARY TARGET VOCABULARY TRANSITION VOCABULARY FORWARD VOCABULARY USER ONLY DEFINITIONS FORTH ALSO META ALSO : META META ; : TARGET TARGET ; : TRANSITION TRANSITION ; : FORWARD FORWARD ; : USER USER ; : ASSEMBLER ASSEMBLER ; ONLY FORTH ALSO META ALSO DEFINITIONS : X?>MARK ( -- f addr ) TRUE HERE-X NIP 0 ,-X ; : X?>RESOLVE ( f addr -- ) HERE-X -ROT SWAP !L ?CONDITION ; : X?MARK ( -- f addr ) TRUE HERE-T 0 C,-T ; : AM?>RESOLVE ( f addr -- ) HERE-T OVER 1+ - SWAP C!-T ?CONDITION ; : AM?MARK ASSEMBLER IS ?>MARK ' AM?>RESOLVE ASSEMBLER IS ?>RESOLVE ' AM?IN @ >R HERE-T CONSTANT LABELS @ IF R> >IN ! BL WORD DUP C@ 5 + ?LINE HERE-T H. COUNT TYPE TAB ?NEWPAGE ELSE r>drop THEN !CSP ; : XLABEL ( | NAME -- ) 0 ['] DROP A;! ['] RUN-A; IS RUN ASSEMBLER DEFINITIONS >IN @ >R HERE-X >XREL CONSTANT LABELS @ IF R> >IN ! BL WORD DUP C@ 5 + ?LINE HERE-T H. COUNT TYPE TAB ?NEWPAGE ELSE r>drop THEN !CSP ; : MAKE-CODE ( PFA -- ) @ ,-X ; \ Absolute address : MAKE-CODE-REL ( PFA -- ) @ HERE-T 2+ - ,-T ; \ Relative offset : IN-TARGET ( -- ) ONLY TARGET DEFINITIONS ; : IN-TRANSITION ( -- ) ONLY FORWARD ALSO TARGET DEFINITIONS ALSO TRANSITION ; : IN-META ( -- ) ONLY FORTH ALSO META DEFINITIONS ALSO ; : IN-FORWARD ( -- ) FORWARD DEFINITIONS ; : LINK-BACKWARDS ( PFA -- ) HERE-X >XREL OVER @ ,-X SWAP ! ; : LINK-BACKWARDS-REL ( PFA -- ) HERE-T OVER @ ,-T SWAP ! ; : RESOLVED? ( pfa -- f ) 2+ @ ; : FORWARD-CODE ( pfa -- ) DUP RESOLVED? IF MAKE-CODE ELSE LINK-BACKWARDS THEN ; : FORWARD-CODE-REL ( pfa -- ) DUP RESOLVED? IF MAKE-CODE-REL ELSE LINK-BACKWARDS-REL THEN ; : FORWARD: ( -- ) SWITCH FORWARD DEFINITIONS CREATE SWITCH 0 , 0 , DOES> FORWARD-CODE ; : FORWARD_REL: ( -- ) SWITCH FORWARD DEFINITIONS CREATE SWITCH 0 , 0 , DOES> FORWARD-CODE-REL ; VARIABLE WIDTH 31 WIDTH ! VARIABLE LAST-T VARIABLE CONTEXT-T VARIABLE CURRENT-T : HASH ( str-addr voc-addr -- thread ) SWAP DUP C@ SWAP 1+ C@ + \ **** 1+ C@ #TTHREADS 1- AND 2* + ; : HEADER ( -- ) BL WORD C@ 1+ WIDTH @ MIN ?DUP IF ( HERE-Y 2- ) ( for ylink at end) ALIGN HERE-Y 2- @-Y CNHASH HERE-T CNHASH <> IF HERE-Y HERE-T CNHASH !-Y THEN ( >NAME hash entry ) LOADLINE @ ,-Y HERE CURRENT-T @ HASH DUP @-T ,-Y ( link ) HERE-Y 2- SWAP !-T ( point voc thread to link field ) HERE-Y HERE ROT S,-Y ALIGN DUP LAST-T ! 128 SWAP CSET-Y 128 HERE-Y 1- CSET-Y HERE-T ,-Y ( cfa ptr ) HERE-Y HERE-T CNHASH 2+ !-Y ( stopper >NAME hash entry ) THEN ; : TARGET-CREATE ( -- ) >IN @ HEADER DUP >IN ! LABELS @ IF BL WORD DUP C@ 5 + ?LINE HERE-T H. COUNT TYPE TAB ?NEWPAGE THEN >IN ! IN-TARGET CREATE IN-META HERE-T , TRUE , DOES> MAKE-CODE ; : RECREATE ( -- ) >IN @ TARGET-CREATE >IN ! ; FORTH DEFINITIONS : CODE ( NAME --- ) 0 ['] DROP A;! ['] RUN-A; IS RUN TARGET-CREATE ASSEMBLER !CSP ; : INLINE ( --- ) 0 ['] DROP A;! ['] RUN-A; IS RUN ASSEMBLER !CSP HERE-T ,-X ; ASSEMBLER ALSO DEFINITIONS : END-CODE ['] IS RUN A; IN-META ?CSP ; : END-INLINE ['] IS RUN A; IN-META ?CSP ; : C; ['] IS RUN A; IN-META ?CSP ; META IN-META : 'T ( -- cfa ) CONTEXT @ TARGET DEFINED ROT CONTEXT ! 0= ?MISSING ; : [TARGET] ( -- ) 'T X, ; IMMEDIATE : 'F ( -- cfa ) CONTEXT @ FORWARD DEFINED ROT CONTEXT ! 0= ?MISSING ; : [FORWARD] ( -- ) 'F X, ; IMMEDIATE : T: ( -- ) SWITCH TRANSITION DEFINITIONS CREATE XHERE PARAGRAPH + DUP XDPSEG ! XSEG @ - , XDP OFF SWITCH ] DOES> @ XSEG @ + >R 0 >R ; : T; ( -- ) SWITCH TRANSITION DEFINITIONS [COMPILE] ; SWITCH ; IMMEDIATE : DIGIT? ( CHAR -- F ) BASE @ DIGIT NIP ; : PUNCT? ( CHAR -- F ) ASCII . OVER = SWAP ASCII - OVER = SWAP ASCII / OVER = SWAP DROP OR OR ; : NUMERIC? ( ADDR LEN -- F ) DUP 1 = IF DROP C@ DIGIT? EXIT THEN 1 -ROT 0 ?DO DUP C@ DUP DIGIT? SWAP PUNCT? OR ROT AND SWAP 1+ LOOP DROP ; T: ( [COMPILE] ( T; T: ( [COMPILE] ( T; T: \ [COMPILE] \ T; : STRING,-T ( -- ) ASCII " PARSE DUP C,-T S,-T ALIGN ; : STRING,-X ( -- ) ASCII " PARSE DUP C,-X S,-X ALIGN-X ; FORWARD: <(.")> T: ." [FORWARD] <(.")> STRING,-X T; FORWARD: <(")> T: " [FORWARD] <(")> HERE-T ,-X STRING,-T T; FORWARD: <(ABORT")> T: ABORT" [FORWARD] <(ABORT")> STRING,-X T; FORWARD_REL: : CREATE RECREATE 232 C,-T [FORWARD] HERE-T CONSTANT ; : VARIABLE ( | name -- ) CREATE 0 ,-T ; FORWARD_REL: : DEFER ( -- ) TARGET-CREATE 232 C,-T \ CALL instruction [FORWARD] 0 ,-T ; FORTH VARIABLE #USER-T META ALSO USER DEFINITIONS : ALLOT ( n -- ) #USER-T +! ; FORWARD_REL: : VARIABLE ( -- ) SWITCH RECREATE 232 C,-T [FORWARD] #USER-T @ DUP ,-T 2 ALLOT META DEFINITIONS CONSTANT SWITCH ; FORWARD_REL: : DEFER ( -- ) SWITCH TARGET-CREATE 232 C,-T [FORWARD] SWITCH #USER-T @ ,-T 2 ALLOT ; ONLY FORTH ALSO META ALSO DEFINITIONS FORTH VARIABLE VOC-LINK-T META FORWARD_REL: : VOCABULARY ( -- ) RECREATE 232 C,-T \ CALL instruction to DOVOC [FORWARD] HERE-T #TTHREADS 0 DO 0 ,-T LOOP HERE-T VOC-LINK-T @ ,-T VOC-LINK-T ! CONSTANT DOES> @ CONTEXT-T ! ; : IMMEDIATE ( -- ) WIDTH @ IF ( Headers present? ) 64 ( Precedence Bit ) LAST-T @ CSET-Y THEN ; FORWARD: <(;USES)> FORTH VARIABLE STATE-T META T: ;USES ( -- ) [FORWARD] <(;USES)> IN-META ASSEMBLER !CSP STATE-T OFF T; T: [COMPILE] 'T EXECUTE T; FORWARD: <(IS)> T: IS [FORWARD] <(IS)> T; : IS 'T ( CR HERE COUNT TYPE TAB OVER H. ) >BODY @ >BODY-T !-T ; T: ALIGN T; T: EVEN T; : .SYMBOLS ( -- ) TARGET CONTEXT @ HERE #TTHREADS 2* CMOVE CR BEGIN HERE 4 LARGEST DUP WHILE DUP L>NAME DUP Y@ 31 AND 2+ ?LINE ." / " DUP .ID NAME> >BODY @ U. Y@ SWAP ! KEY? IF EXIT THEN REPEAT 2DROP IN-META ; : .UNRESOLVED ( -- ) FORWARD CONTEXT @ HERE #THREADS 2* CMOVE BEGIN HERE #THREADS LARGEST DUP WHILE ?CR DUP L>NAME NAME> >BODY RESOLVED? 0= IF >ATTRIB4 DUP L>NAME .ID >NORM THEN Y@ SWAP ! REPEAT 2DROP IN-META ; : FIND-UNRESOLVED ( -- cfa f ) 'F DUP >BODY RESOLVED? ; DECIMAL : RESOLVE ( taddr cfa -- ) >BODY 2DUP TRUE OVER 2+ ! @ BEGIN DUP WHILE 2DUP @-T -ROT SWAP DUP 1- C@-T 232 = \ IF PRECEEDED BY CALL IF DUP 2+ ROT SWAP - SWAP \ SWITCH TO RELATIVE THEN !-T REPEAT 2DROP ! ; : RESOLVES ( taddr -- ) FIND-UNRESOLVED \ #OUT @ 60 > IF CR THEN HERE COUNT TYPE SPACE IF CR >NAME .ID ." Already Resolved" DROP ELSE RESOLVE THEN ; : :RESOLVE ( taddr cfa -- ) >BODY 2DUP TRUE OVER 2+ ! @ BEGIN DUP WHILE 2DUP @-X -ROT SWAP !-X REPEAT 2DROP ! ; : :RESOLVES ( taddr -- ) FIND-UNRESOLVED IF CR >NAME .ID ." Already Resolved" DROP ELSE :RESOLVE THEN ; : H: [COMPILE] : ; H: ' 'T >BODY @ ; H: , ,-T ; H: C, C,-T ; H: X, ,-X ; H: XC, C,-X ; H: HERE HERE-T ; H: XHERE ( HERE-X ) TRUE ABORT" Used HERE-X" ; H: ALLOT ALLOT-T ; H: DEFINITIONS DEFINITIONS CONTEXT-T @ CURRENT-T ! ; ONLY FORTH DEFINITIONS ALSO .( Meta Compiler Loaded ) CR .ELAPSED CR FLOAD KERNEL1.SEQ FLOAD VIDEO.SEQ FLOAD KERNEL2.SEQ FLOAD VIDEO2.SEQ FLOAD KERNEL3.SEQ FLOAD EQUCOLON.SEQ FLOAD HANDLES.SEQ FLOAD SEQREAD.SEQ FLOAD DEFAULT.SEQ FLOAD KERNEL4.SEQ CAPS ON 8 TABSIZE ! \ RESTORE TABS 70 RMARGIN ! \ RESTORE RIGHT MARGIN #OUT @ #LINE @ \ Save where we are on screen. ?PAGE \ NEW PAGE PRINTING OFF \ NO PRINTING ANY MORE 2- AT CR \ Go back there.