\ The Rest is Silence 26Sep83map************************************************************* ************************************************************* *** *** *** Please direct all questions, comments, and *** *** miscellaneous personal abuse to: *** *** *** *** Henry Laxen or Michael Perry *** *** 1259 Cornell Avenue 1125 Bancroft Way *** *** Berkeley, California Berkeley, California *** *** 94706 94702 *** *** *** *** (415) 525-8582 (415) 644-3421 *** *** *** ************************************************************* ************************************************************* \ Load Screen for Pre-Compile 12Oct83mapONLY FORTH ALSO DEFINITIONS 100 CONSTANT VERSION ( release,version,user version ) : NLOAD CR .S (LOAD) ; ' NLOAD IS LOAD 3 21 THRU ( The Meta Compiler ) ONLY FORTH DEFINITIONS ALSO CR .( Meta Compiler Loaded ) --> \ Target System Setup 26Sep83mapONLY FORTH ' NLOAD IS LOAD META ALSO FORTH 256 DP-T ! HERE 12000 + ' TARGET-ORIGIN >BODY ! IN-META 24 113 THRU ( System Source Screens ) CR .( Unresolved references: ) CR .UNRESOLVED CR .( Statistics: ) CR .( Last Host Address: ) [FORTH] HERE U. CR .( First Target Code Address: ) META 256 THERE U. CR .( Last Target Code Address: ) META HERE-T THERE U. CR CR META 256 THERE HERE-T CP/M SAVE KERNEL.COM CR .( Now return to CP/M and type: ) CR .( KERNEL EXTEND80.BLK ) CR .( START ) \ Vocabulary Helpers 07SEP83HHLONLY FORTH ALSO VOCABULARY META META ALSO META DEFINITIONS VARIABLE DP-T : [FORTH] FORTH ; IMMEDIATE : [META] META ; IMMEDIATE : SWITCH (S -- ) NOOP ( Context ) NOOP ( Current ) DOES> DUP @ CONTEXT @ SWAP CONTEXT ! OVER ! 2+ DUP @ CURRENT @ SWAP CURRENT ! SWAP ! ; SWITCH ( Redefine itself ) \ Memory Access Words 15OCT82HHL0 CONSTANT TARGET-ORIGIN : THERE (S taddr -- addr ) TARGET-ORIGIN + ; : C@-T (S taddr -- char ) THERE C@ ; : @-T (S taddr -- n ) THERE @ ; : C!-T (S char taddr -- ) THERE C! ; : !-T (S n taddr -- ) THERE ! ; : HERE-T (S -- taddr ) DP-T @ ; : ALLOT-T (S n -- ) DP-T +! ; : C,-T (S char -- ) HERE-T C!-T 1 ALLOT-T ; : ,-T (S n -- ) HERE-T !-T 2 ALLOT-T ; : S,-T (S addr len -- ) 0 ?DO DUP C@ C,-T 1+ LOOP DROP ; \ Define Symbol Table Vocabularies 07SEP83HHLVOCABULARY TARGET VOCABULARY TRANSITION VOCABULARY FORWARD VOCABULARY USER ONLY DEFINITIONS FORTH ALSO META ALSO : META META ; : TARGET TARGET ; : TRANSITION TRANSITION ; : ASSEMBLER ASSEMBLER ; : FORWARD FORWARD ; : USER USER ; ONLY FORTH ALSO META ALSO DEFINITIONS \ 8080 Meta Assembler 01AUG83HHL: ?>MARK (S -- f addr ) TRUE HERE-T 0 ,-T ; : ?>RESOLVE (S f addr -- ) HERE-T SWAP !-T ?CONDITION ; : ?MARK ASSEMBLER IS ?>MARK META ' ?>RESOLVE ASSEMBLER IS ?>RESOLVE META ' ? FORWARD-CODE ; \ Create Headers in Target Image 16Oct83mapVARIABLE WIDTH 31 WIDTH ! VARIABLE LAST-T VARIABLE CONTEXT-T VARIABLE CURRENT-T : HASH (S str-addr voc-addr -- thread ) SWAP 1+ C@ #THREADS 1- AND 2* + ; : HEADER (S -- ) BL WORD C@ 1+ WIDTH @ MIN ?DUP IF ALIGN BLK @ 4096 + ,-T ( Lay down view field ) HERE CURRENT-T @ HASH DUP @-T ,-T HERE-T 2- SWAP !-T HERE-T HERE ROT S,-T ALIGN DUP LAST-T ! 128 SWAP THERE CSET 128 HERE-T 1- THERE CSET THEN ; \ Meta Compiler Create Target Image 06Oct83map: TARGET-CREATE (S -- ) >IN @ HEADER >IN ! IN-TARGET CREATE IN-META HERE-T , 1 C, DOES> MAKE-CODE ; : RECREATE (S -- ) >IN @ TARGET-CREATE >IN ! ; : CODE TARGET-CREATE HERE-T 2+ ,-T ASSEMBLER !CSP ; ASSEMBLER ALSO DEFINITIONS : C; IN-META ?CSP ; META IN-META \ Force compilation of target & forward words 07SEP83HHL: 'T (S -- cfa ) CONTEXT @ TARGET DEFINED ROT CONTEXT ! 0= ?MISSING ; : [TARGET] (S -- ) 'T , ; IMMEDIATE : 'F (S -- cfa ) CONTEXT @ FORWARD DEFINED ROT CONTEXT ! 0= ?MISSING ; : [FORWARD] (S -- ) 'F , ; IMMEDIATE \ Meta Compiler Branching & Defining Words 07SEP83HHL: T: (S -- ) SWITCH TRANSITION DEFINITIONS CREATE SWITCH ] DOES> >R ; : T; (S -- ) SWITCH TRANSITION DEFINITIONS [COMPILE] ; SWITCH ; IMMEDIATE : DIGIT? (S CHAR -- F ) BASE @ DIGIT NIP ; : PUNCT? (S CHAR -- F ) ASCII . OVER = SWAP ASCII - OVER = SWAP ASCII / OVER = SWAP DROP OR OR ; : NUMERIC? (S 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 ; \ Meta Compiler Transition Words 04MAR83HHLT: ( [COMPILE] ( T; T: (S [COMPILE] (S T; T: \ [COMPILE] \ T; : STRING,-T (S -- ) ASCII " WORD DUP C@ 1+ S,-T ; FORWARD: <(.")> T: ." [FORWARD] <(.")> STRING,-T T; FORWARD: <(")> T: " [FORWARD] <(")> STRING,-T T; FORWARD: <(ABORT")> T: ABORT" [FORWARD] <(ABORT")> STRING,-T T; \ Meta Compiler Defining Words 06SEP83HHLFORWARD: : CREATE RECREATE [FORWARD] HERE-T CONSTANT ; : VARIABLE (S -- ) CREATE 0 ,-T ; FORWARD: : DEFER (S -- ) TARGET-CREATE [FORWARD] 0 ,-T ; \ Meta Compiler Defining Words 07SEP83HHLFORTH VARIABLE #USER-T META ALSO USER DEFINITIONS : ALLOT (S n -- ) #USER-T +! ; FORWARD: : VARIABLE (S -- ) SWITCH RECREATE [FORWARD] #USER-T @ DUP ,-T 2 ALLOT META DEFINITIONS CONSTANT SWITCH ; FORWARD: : DEFER (S -- ) SWITCH TARGET-CREATE [FORWARD] SWITCH #USER-T @ ,-T 2 ALLOT ; ONLY FORTH ALSO META ALSO DEFINITIONS \ Meta Compiler Transition Words 16Oct83mapFORTH VARIABLE VOC-LINK-T META FORWARD: : VOCABULARY (S -- ) RECREATE [FORWARD] HERE-T #THREADS 0 DO 0 ,-T LOOP ( THREADS ) HERE-T VOC-LINK-T @ ,-T VOC-LINK-T ! CONSTANT DOES> @ CONTEXT-T ! ; : IMMEDIATE (S -- ) WIDTH @ IF ( Headers present? ) 64 ( Precedence Bit ) LAST-T @ THERE CTOGGLE THEN ; \ Meta Compiler Transition Words 06SEP83HHLFORWARD: <(;USES)> FORTH VARIABLE STATE-T META T: ;USES (S -- ) [FORWARD] <(;USES)> IN-META ASSEMBLER !CSP STATE-T OFF T; T: [COMPILE] 'T EXECUTE T; FORWARD: <(IS)> T: IS [FORWARD] <(IS)> T; : IS 'T >BODY @ >BODY !-T ; T: ALIGN T; T: EVEN T; \ Display an unformatted Symbol Table 26Sep83map: .SYMBOLS (S -- ) TARGET CONTEXT @ HERE #THREADS 2* CMOVE BEGIN HERE 4 LARGEST DUP WHILE ?CR ." [[ " DUP .ID DUP NAME> >BODY @ U. ." ]] " N>LINK @ SWAP ! KEY? IF EXIT THEN REPEAT 2DROP IN-META ; \ Meta Compiler Resolve Forward References 26Sep83map: .UNRESOLVED (S -- ) FORWARD CONTEXT @ HERE #THREADS 2* CMOVE BEGIN HERE #THREADS LARGEST DUP WHILE ?CR DUP L>NAME NAME> >BODY RESOLVED? 0= IF DUP L>NAME .ID THEN @ SWAP ! REPEAT 2DROP IN-META ; : FIND-UNRESOLVED (S -- cfa f ) 'F DUP >BODY RESOLVED? ; : RESOLVE (S taddr cfa -- ) >BODY 2DUP 1 OVER 2+ C! @ BEGIN DUP WHILE 2DUP @-T -ROT SWAP !-T REPEAT 2DROP ! ; : RESOLVES (S taddr -- ) FIND-UNRESOLVED IF >NAME .ID ." Already Resolved" DROP ELSE RESOLVE THEN ; \ Interpretive words for Meta 07SEP83HHL: H: [COMPILE] : ; H: ' 'T >BODY @ ; H: , ,-T ; H: C, C,-T ; H: HERE HERE-T ; H: ALLOT ALLOT-T ; H: DEFINITIONS DEFINITIONS CONTEXT-T @ CURRENT-T ! ; \ Declare the Forward References and Version # 29Sep83map: ]] ] ; : [[ [COMPILE] [ ; FORTH IMMEDIATE META FORWARD: DEFINITIONS FORWARD: [ \ Boot up Vectors and NEXT Interpreter 28AUG83HHLASSEMBLER LABEL ORIGIN NOP -1 JMP ( Low Level COLD Entry point ) NOP -1 JMP ( Low Level WARM Entry point ) LABEL DPUSH D PUSH LABEL HPUSH H PUSH LABEL >NEXT IP LDAX IP INX A L MOV IP LDAX IP INX A H MOV LABEL >NEXT1 M E MOV H INX M D MOV XCHG PCHL FORTH ASSEMBLER DEFINITIONS META H: NEXT >NEXT JMP ; H: IP>HL B H MOV C L MOV ; IN-META HERE-T DUP 100 + CURRENT-T ! ( harmless ) VOCABULARY FORTH FORTH DEFINITIONS 0 OVER 2+ !-T ( link ) DUP 2+ SWAP 16 + !-T ( thread ) IN-META \ Run Time Code for Defining Words 28AUG83HHLVARIABLE RP ( Not enough registers on an 8080 ) ASSEMBLER LABEL NEST RP LHLD H DCX B M MOV H DCX C M MOV RP SHLD D INX E C MOV D B MOV NEXT CODE EXIT (S -- ) RP LHLD M C MOV H INX M B MOV H INX RP SHLD NEXT C; CODE UNNEST ' EXIT @-T ' UNNEST !-T C; ASSEMBLER LABEL DODOES RP LHLD H DCX B M MOV H DCX C M MOV RP SHLD B POP D INX D PUSH NEXT LABEL DOCREATE D INX D PUSH NEXT \ Run Time Code for Defining Words 09MAR83HHLVARIABLE UP ASSEMBLER LABEL @USER ( in: DE out: DE uses: HL ) UP LHLD D DAD M E MOV H INX M D MOV RET LABEL !USER ( in: DE=off HL=value out: none ) H PUSH UP LHLD D DAD D POP E M MOV H INX D M MOV RET LABEL DOCONSTANT D INX XCHG M E MOV H INX M D MOV D PUSH NEXT LABEL DOUSER-VARIABLE D INX XCHG M E MOV H INX M D MOV UP LHLD D DAD H PUSH NEXT CODE (LIT) (S -- n ) IP LDAX IP INX A L MOV IP LDAX IP INX A H MOV HPUSH JMP C; \ Meta Defining Words 07SEP83HHLT: LITERAL (S n -- ) [TARGET] (LIT) ,-T T; T: DLITERAL (S d -- ) [TARGET] (LIT) ,-T [TARGET] (LIT) ,-T T; T: ASCII (S -- ) [COMPILE] ASCII [[ TRANSITION ]] LITERAL [META] T; T: ['] (S -- ) 'T >BODY @ [[ TRANSITION ]] LITERAL [META] T; : CONSTANT (S n -- ) RECREATE [[ ASSEMBLER DOCONSTANT ]] LITERAL ,-T DUP ,-T CONSTANT ; \ Identify numbers and forward References 28AUG83HHLFORWARD: <(;CODE)> T: DOES> (S -- ) [FORWARD] <(;CODE)> HERE-T DOES-OP C,-T [[ ASSEMBLER DODOES ]] LITERAL ,-T T; : NUMERIC (S -- ) [FORTH] HERE [META] NUMBER DPL @ 1+ IF [[ TRANSITION ]] DLITERAL [META] ELSE DROP [[ TRANSITION ]] LITERAL [META] THEN ; : UNDEFINED (S -- ) HERE-T 0 ,-T IN-FORWARD [FORTH] CREATE [META] TRANSITION [FORTH] , 0 C, [META] DOES> FORWARD-CODE ; \ Meta Compiler Compiling Loop 04MAR83HHL[FORTH] VARIABLE T-IN META : ] (S -- ) STATE-T ON IN-TRANSITION BEGIN >IN @ T-IN ! DEFINED IF EXECUTE ELSE COUNT NUMERIC? IF NUMERIC ELSE T-IN @ >IN ! UNDEFINED THEN THEN STATE-T @ 0= UNTIL ; T: [ (S -- ) IN-META STATE-T OFF T; T: ; (S -- ) [TARGET] UNNEST [[ TRANSITION ]] [ T; : : (S -- ) TARGET-CREATE [[ ASSEMBLER NEST ]] LITERAL ,-T ] ; \ Run Time Code for Control Structures 04MAR83HHLCODE BRANCH (S -- ) IP>HL M C MOV H INX M B MOV NEXT C; CODE ?BRANCH (S f -- ) H POP L A MOV H ORA ' BRANCH @-T JZ IP INX IP INX NEXT C; \ Meta Compiler Branching Words 01AUG83HHLT: BEGIN ?MARK T; T: THEN ?>RESOLVE T; T: ELSE [TARGET] BRANCH ?>MARK 2SWAP ?>RESOLVE T; T: WHILE [[ TRANSITION ]] IF T; T: REPEAT 2SWAP [[ TRANSITION ]] AGAIN THEN T; \ Run Time Code for Control Structures 07JUL83HHLASSEMBLER LABEL LOOP-EXIT RP LHLD 6 D LXI D DAD RP SHLD IP INX IP INX NEXT CODE (LOOP) (S -- ) RP LHLD M INR 0= IF H INX M INR LOOP-EXIT JZ THEN ' BRANCH @-T JMP C; LABEL LOOP-BRANCH XCHG RP LHLD E M MOV H INX D M MOV ' BRANCH @-T JMP CODE (+LOOP) (S n -- ) RP LHLD M E MOV H INX M D MOV H POP H A MOV A ORA 0< NOT IF D DAD LOOP-EXIT JC LOOP-BRANCH JMP THEN D DAD LOOP-BRANCH JC LOOP-EXIT JMP C; \ Run Time Code for Control Structures 02MAR83HHL: (DO) (S n1 n2 -- ) R> DUP @ >R 2+ -ROT SWAP DUP >R - >R >R ; : (?DO) (S n1 n2 -- ) 2DUP = IF 2DROP R> @ >R ELSE R> DUP @ >R 2+ -ROT SWAP DUP >R - >R >R THEN ; : BOUNDS (S adr len -- lim first ) OVER + SWAP ; \ Meta compiler Branching & Looping 01AUG83HHLT: ?DO [TARGET] (?DO) ?>MARK T; T: DO [TARGET] (DO) ?>MARK T; T: LOOP [TARGET] (LOOP) 2DUP 2+ ?RESOLVE T; T: +LOOP [TARGET] (+LOOP) 2DUP 2+ ?RESOLVE T; \ Execution Control 07SEP83HHLASSEMBLER >NEXT META CONSTANT >NEXT CODE EXECUTE (S cfa -- ) H POP >NEXT1 JMP C; CODE PERFORM (S addr-of-cfa -- ) H POP M E MOV H INX M D MOV XCHG >NEXT1 JMP C; LABEL DODEFER (S -- ) D INX XCHG ' PERFORM @-T 1+ JMP LABEL DOUSER-DEFER D INX XCHG M E MOV H INX M D MOV @USER CALL XCHG >NEXT1 JMP CODE GO (S addr -- ) RET C; CODE NOOP NEXT C; CODE PAUSE NEXT C; \ Execution Control 01Oct83mapCODE I (S -- n ) RP LHLD M E MOV H INX M D MOV H INX M A MOV H INX M H MOV A L MOV D DAD HPUSH JMP C; CODE J (S -- n ) RP LHLD 6 D LXI D DAD ' I @-T 3 + JMP C; CODE (LEAVE) (S -- ) RP LHLD H INX H INX H INX H INX M C MOV H INX M B MOV H INX RP SHLD NEXT C; CODE (?LEAVE) (S f -- ) H POP H A MOV L ORA ' (LEAVE) @-T JNZ NEXT C; T: LEAVE [TARGET] (LEAVE) T; T: ?LEAVE [TARGET] (?LEAVE) T; \ 16 and 8 bit Memory Operations 24FEB83HHLCODE @ (S addr -- n ) H POP M E MOV H INX M D MOV D PUSH NEXT C; CODE ! (S n addr -- ) H POP D POP E M MOV H INX D M MOV NEXT C; CODE C@ (S addr -- char ) H POP M L MOV 0 H MVI HPUSH JMP C; CODE C! (S char addr -- ) H POP D POP E M MOV NEXT C; \ Block Move Memory Operations 24FEB83HHLCODE CMOVE (S from to count -- ) IP>HL B POP D POP XTHL ( STACK=IP BC=len DE=to HL=from ) BEGIN B A MOV C ORA 0= NOT WHILE M A MOV H INX D STAX D INX B DCX REPEAT B POP NEXT C; CODE CMOVE> (S from to count -- ) IP>HL B POP D POP XTHL ( STACK=IP BC=len DE=to HL=from ) B DAD H DCX XCHG B DAD H DCX XCHG BEGIN B A MOV C ORA 0= NOT WHILE M A MOV H DCX D STAX D DCX B DCX REPEAT B POP NEXT C; \ 16 bit Stack Operations 24FEB83HHLCODE SP@ (S -- n ) 0 H LXI SP DAD HPUSH JMP C; CODE SP! (S n -- ) H POP SPHL NEXT C; CODE RP@ (S -- addr ) RP LHLD HPUSH JMP C; CODE RP! (S n -- ) H POP RP SHLD NEXT C; \ 16 bit Stack Operations 24FEB83HHLCODE DROP (S n1 -- ) H POP NEXT C; CODE DUP (S n1 -- n1 n1 ) H POP H PUSH HPUSH JMP C; CODE SWAP (S n1 n2 -- n2 n1 ) H POP XTHL HPUSH JMP C; CODE OVER (S n1 n2 -- n1 n2 n1 ) D POP H POP H PUSH DPUSH JMP C; \ 16 bit Stack Operations 11MAR83HHLCODE TUCK (S n1 n2 -- n2 n1 n2 ) H POP D POP H PUSH DPUSH JMP C; CODE NIP (S n1 n2 -- n2 ) H POP D POP HPUSH JMP C; CODE ROT (S n1 n2 n3 --- n2 n3 n1 ) D POP H POP XTHL DPUSH JMP C; CODE -ROT (S n1 n2 n3 --- n3 n1 n2 ) H POP D POP XTHL XCHG DPUSH JMP C; CODE FLIP (S n -- n ) D POP E H MOV D L MOV HPUSH JMP C; : ?DUP (S n -- [n] n ) DUP IF DUP THEN ; \ 16 bit Stack Operations 24FEB83HHLCODE R> (S -- n ) RP LHLD M E MOV H INX M D MOV H INX RP SHLD D PUSH NEXT C; CODE >R (S n -- ) D POP RP LHLD H DCX H DCX RP SHLD E M MOV H INX D M MOV NEXT C; CODE R@ RP LHLD M E MOV H INX M D MOV D PUSH NEXT C; CODE PICK (S nm ... n2 n1 k -- nm ... n2 n1 nk ) H POP H DAD SP DAD M E MOV H INX M D MOV D PUSH NEXT C; : ROLL (S n1 n2 .. nk n -- wierd ) >R R@ PICK SP@ DUP 2+ R> 1+ 2* CMOVE> DROP ; \ 16 bit Logical Operations 24FEB83HHLCODE AND (S n1 n2 -- n3 ) D POP H POP E A MOV L ANA A L MOV D A MOV H ANA A H MOV HPUSH JMP C; CODE OR (S n1 n2 -- n3 ) D POP H POP E A MOV L ORA A L MOV D A MOV H ORA A H MOV HPUSH JMP C; CODE XOR (S n1 n2 -- n3 ) D POP H POP E A MOV L XRA A L MOV D A MOV H XRA A H MOV HPUSH JMP C; CODE NOT (S n -- n' ) H POP L A MOV CMA A L MOV H A MOV CMA A H MOV HPUSH JMP C; -1 CONSTANT TRUE 0 CONSTANT FALSE ASSEMBLER LABEL YES TRUE H LXI HPUSH JMP LABEL NO FALSE H LXI HPUSH JMP \ Logical Operations 16Oct83mapCODE CSET (S b addr -- ) H POP D POP M A MOV E ORA A M MOV NEXT C; CODE CRESET (S b addr -- ) H POP D POP E A MOV CMA A E MOV M A MOV E ANA A M MOV NEXT C; CODE CTOGGLE (S b addr -- ) H POP D POP M A MOV E XRA A M MOV NEXT C; CODE ON (S addr -- ) TRUE H LXI XTHL H PUSH ' ! @-T JMP C; CODE OFF (S addr -- ) FALSE H LXI XTHL H PUSH ' ! @-T JMP C; \ 16 bit Arithmetic Operations 26Sep83mapCODE + (S n1 n2 -- sum ) D POP H POP D DAD HPUSH JMP C; CODE NEGATE (S n -- n' ) H POP H DCX H PUSH ' NOT @-T JMP C; CODE - (S n1 n2 -- n1-n2 ) D POP H POP D A MOV CMA A D MOV E A MOV CMA A E MOV D INX D DAD HPUSH JMP C; CODE ABS (S n -- n ) H POP H PUSH H A MOV A ORA ' NEGATE @-T JM NEXT C; CODE +! (S n addr -- ) H POP D POP M A MOV E ADD A M MOV H INX M A MOV D ADC A M MOV NEXT C; 0 CONSTANT 0 1 CONSTANT 1 2 CONSTANT 2 3 CONSTANT 3 \ 16 bit Arithmetic Operations 26Sep83mapCODE 2* (S n -- 2*n ) H POP H DAD HPUSH JMP C; CODE 2/ (S n -- n/2 ) H POP H A MOV RLC RRC RAR A H MOV L A MOV RAR A L MOV HPUSH JMP C; CODE U2/ (S u -- u/2 ) H POP A ORA H A MOV RAR A H MOV L A MOV RAR A L MOV HPUSH JMP C; CODE 8* (S n -- 8*n ) H POP H DAD H DAD H DAD HPUSH JMP C; CODE 1+ H POP H INX HPUSH JMP C; CODE 2+ H POP H INX H INX HPUSH JMP C; CODE 1- H POP H DCX HPUSH JMP C; CODE 2- H POP H DCX H DCX HPUSH JMP C; \ 16 bit Arithmetic Operations Unsigned Multiply 26Sep83map ASSEMBLER LABEL MPYX 0 H LXI ( 0=Partial Product ) 4 C MVI ( Loop Counter ) BEGIN H DAD ( Shift AHL left by 24 bits ) RAL CS IF D DAD 0 ACI THEN H DAD RAL CS IF D DAD 0 ACI THEN C DCR 0= UNTIL RET CODE UM* (S n1 n2 -- d ) D POP H POP B PUSH H B MOV L A MOV MPYX CALL H PUSH A H MOV B A MOV H B MOV MPYX CALL D POP D C MOV B DAD 0 ACI L D MOV H L MOV A H MOV B POP DPUSH JMP C; : U*D (S n1 n2 -- d ) UM* ; \ 16 bit Arithmetic Operations Division subroutines 25FEB83HHLASSEMBLER LABEL USL0 A E MOV H A MOV C SUB A H MOV E A MOV B SBB CS IF H A MOV C ADD A H MOV E A MOV D DCR RZ LABEL USLA H DAD RAL USL0 JNC A E MOV H A MOV C SUB A H MOV E A MOV B SBB THEN L INR D DCR USLA JNZ RET LABEL USBAD -1 H LXI B POP H PUSH HPUSH JMP \ 16 bit Arithmetic Operations Unsigned Divide 25FEB83HHLCODE UM/MOD (S d1 n1 -- Remainder Quotient ) IP>HL B POP D POP XTHL XCHG ( HLDE = Numerator BC = Denominator ) L A MOV C SUB H A MOV B SBB USBAD JNC H A MOV L H MOV D L MOV 8 D MVI D PUSH USLA CALL D POP H PUSH E L MOV USLA CALL A D MOV H E MOV B POP C H MOV B POP D PUSH HPUSH JMP C; \ 16 bit Comparison Operations 24FEB83HHLCODE 0= (S n -- f ) H POP L A MOV H ORA YES JZ NO JMP C; CODE 0< (S n -- f ) H POP H DAD YES JC NO JMP C; CODE 0> (S n -- f ) H POP H A MOV A ORA NO JM L ORA YES JNZ NO JMP C; CODE 0<> (S n -- f ) H POP L A MOV H ORA YES JNZ NO JMP C; CODE = (S n1 n2 -- f ) H POP D POP L A MOV E CMP NO JNZ H A MOV D CMP NO JNZ YES JMP C; : <> (S n1 n2 -- f ) = NOT ; : ?NEGATE (S n1 n2 -- n3 ) 0< IF NEGATE THEN ; \ 16 bit Comparison Operations 27SEP83MAPCODE U< (S n1 n2 -- f ) H POP D POP LABEL U<1 H A MOV LABEL U<2 D CMP NO JC YES JNZ L A MOV E CMP NO JC YES JNZ NO JMP C; CODE U> (S n1 n2 -- f ) D POP H POP U<1 JMP C; CODE < (S n1 n2 -- f ) H POP D POP LABEL <1 D A MOV 128 XRI A D MOV H A MOV 128 XRI U<2 JMP C; CODE > (S n1 n2 -- f ) D POP H POP <1 JMP C; : MIN (S n1 n2 -- n3 ) 2DUP > IF SWAP THEN DROP ; : MAX (S n1 n2 -- n3 ) 2DUP < IF SWAP THEN DROP ; : BETWEEN (S n1 min max -- f ) >R OVER > SWAP R> > OR NOT ; : WITHIN (S n1 min max -- f ) 1- BETWEEN ; \ 32 bit Memory Operations 09MAR83HHLCODE 2@ (S addr -- d ) H POP 2 D LXI D DAD M E MOV H INX M D MOV D PUSH -3 D LXI D DAD M E MOV H INX M D MOV D PUSH NEXT C; CODE 2! (S d addr -- ) H POP D POP E M MOV H INX D M MOV H INX D POP E M MOV H INX D M MOV NEXT C; \ 32 bit Memory and Stack Operations 26Sep83mapCODE 2DROP (S d -- ) H POP H POP NEXT C; CODE 2DUP (S d -- d d ) H POP D POP D PUSH H PUSH DPUSH JMP C; CODE 2SWAP (S d1 d2 -- d2 d1 ) H POP D POP XTHL H PUSH 5 H LXI SP DAD M A MOV D M MOV A D MOV H DCX M A MOV E M MOV A E MOV H POP DPUSH JMP C; CODE 2OVER (S d2 d2 -- d1 d2 d1 ) 7 H LXI SP DAD M D MOV H DCX M E MOV D PUSH H DCX M D MOV H DCX M E MOV D PUSH NEXT C; : 3DUP (S a b c -- a b c a b c ) DUP 2OVER ROT ; : 4DUP (S a b c d -- a b c d a b c d ) 2OVER 2OVER ; : 2ROT (S a b c d e f --- c d e f a b ) 5 ROLL 5 ROLL ; \ 32 bit Arithmetic Operations 24FEB83HHLCODE D+ (S d1 d2 -- dsum ) 6 H LXI SP DAD M E MOV C M MOV H INX M D MOV B M MOV B POP H POP D DAD XCHG H POP L A MOV C ADC A L MOV H A MOV B ADC A H MOV B POP DPUSH JMP C; CODE DNEGATE (S d# -- d#' ) H POP D POP A SUB E SUB A E MOV 0 A MVI D SBB A D MOV 0 A MVI L SBB A L MOV 0 A MVI H SBB A H MOV DPUSH JMP C; CODE S>D (S n -- d ) D POP 0 H LXI D A MOV 128 ANI 0= NOT IF H DCX THEN DPUSH JMP C; CODE DABS (S d# -- d# ) H POP H PUSH H A MOV A ORA ' DNEGATE @-T JM NEXT C; \ 32 bit Arithmetic Operations 26Sep83mapCODE D2/ (S d -- d/2 ) H POP D POP H A MOV RLC RRC RAR A H MOV L A MOV RAR A L MOV D A MOV RAR A D MOV E A MOV RAR A E MOV DPUSH JMP C; : D- (S d1 d2 -- d3 ) DNEGATE D+ ; : ?DNEGATE (S d1 n -- d2 ) 0< IF DNEGATE THEN ; \ 32 bit Comparison Operations 05Oct83map: D0= (S d -- f ) OR 0= ; : D= (S d1 d2 -- f ) D- D0= ; : DU< (S ud1 ud2 -- f ) ROT SWAP 2DUP U< IF 2DROP 2DROP TRUE ELSE <> IF 2DROP FALSE ELSE U< THEN THEN ; : D< (S d1 d2 -- f ) 2 PICK OVER = IF DU< ELSE NIP ROT DROP < THEN ; : D> (S d1 d2 -- f ) 2SWAP D< ; : DMIN (S d1 d2 -- d3 ) 4DUP D> IF 2SWAP THEN 2DROP ; : DMAX (S d1 d2 -- d3 ) 4DUP D< IF 2SWAP THEN 2DROP ; \ Mixed Mode Arithmetic 01Oct83map: *D (S n1 n2 -- d# ) 2DUP XOR >R ABS SWAP ABS UM* R> ?DNEGATE ; : M/MOD (S d# n1 -- rem quot ) ?DUP IF DUP >R 2DUP XOR >R >R DABS R@ ABS UM/MOD SWAP R> ?NEGATE SWAP R> 0< IF NEGATE OVER IF 1- R@ ROT - SWAP THEN THEN R> DROP THEN ; : MU/MOD (S d# n1 -- rem d#quot ) >R 0 R@ UM/MOD R> SWAP >R UM/MOD R> ; \ 16 bit multiply and divide 27Sep83map: * (S n1 n2 -- n3 ) UM* DROP ; : /MOD (S n1 n2 -- rem quot ) >R S>D R> M/MOD ; : / (S n1 n2 -- quot ) /MOD NIP ; : MOD (S n1 n2 -- rem ) /MOD DROP ; : */MOD (S n1 n2 n3 -- rem quot ) >R *D R> M/MOD ; : */ (S n1 n2 n3 -- n1*n2/n3 ) */MOD NIP ; \ Task Dependant USER Variables 16Oct83mapUSER DEFINITIONS VARIABLE TOS ( TOP OF STACK ) VARIABLE ENTRY ( ENTRY POINT, CONTAINS MACHINE CODE ) VARIABLE LINK ( LINK TO NEXT TASK ) VARIABLE SP0 ( INITIAL PARAMETER STACK ) VARIABLE RP0 ( INITIAL RETURN STACK ) VARIABLE DP ( DICTIONARY POINTER ) VARIABLE #OUT ( NUMBER OF CHARACTERS EMITTED ) VARIABLE #LINE ( THE NUMBER OF LINES SENT SO FAR ) VARIABLE OFFSET ( RELATIVE TO ABSOLUTE DISK BLOCK 0 ) VARIABLE BASE ( FOR NUMERIC INPUT AND OUTPUT ) VARIABLE HLD ( POINTS TO LAST CHARACTER HELD IN PAD ) VARIABLE FILE ( POINTS TO FCB OF CURRENTLY OPEN FILE ) VARIABLE PRINTING ( TRUE WHEN PRINTING. EMIT MAY IGNORE ) DEFER EMIT ( TO ALLOW PRINT SPOOLING ) \ System VARIABLEs 16Oct83mapMETA DEFINITIONS VARIABLE SCR ( SCREEN LAST LISTED OR EDITED ) VARIABLE PRIOR ( USED FOR DICTIONARY SEARCHES ) VARIABLE STATE ( COMPILATION OR INTERPRETATION ) VARIABLE WARNING ( GIVE USER DUPLICATE WARNINGS IF ON ) VARIABLE DPL ( NUMERIC INPUT PUNCTUATION ) VARIABLE R# ( EDITING CURSOR POSITION ) VARIABLE LAST ( POINTS TO NFA OF LATEST DEFINITION ) VARIABLE CSP ( HOLDS STACK POINTER FOR ERROR CHECKING ) VARIABLE CURRENT ( VOCABULARY WHICH GETS DEFINITIONS ) 5 CONSTANT #VOCS ( THE NUMBER OF VOCABULARIES TO SEARCH ) VARIABLE CONTEXT ( VOCABULARY SEARCHED FIRST ) 0 , 0 , 0 , 0 , 0 , \ System Variables 29Sep83mapVARIABLE 'TIB ( ADDRESS OF TERMINAL INPUT BUFFER ) VARIABLE WIDTH ( WIDTH OF NAME FIELD ) VARIABLE VOC-LINK ( POINTS TO NEWEST VOCABULARY ) VARIABLE BLK ( BLOCK NUMBER TO INTERPRET ) VARIABLE >IN ( OFFSET INTO INPUT STREAM ) VARIABLE SPAN ( NUMBER OF CHARACTERS EXPECTED ) VARIABLE #TIB ( NUMBER OF CHARACTERS TO INTERPRET ) VARIABLE END? ( TRUE IF INPUT STREAM EXHAUSTED ) \ Devices Strings 02AUG83HHL 32 CONSTANT BL 8 CONSTANT BS 7 CONSTANT BELL VARIABLE CAPS CODE FILL ( start-addr count char -- ) IP>HL D POP B POP XTHL XCHG BEGIN B A MOV C ORA 0= NOT WHILE L A MOV D STAX D INX B DCX REPEAT B POP NEXT C; : ERASE (S addr len -- ) 0 FILL ; : BLANK (S addr len -- ) BL FILL ; CODE COUNT (S addr -- addr+1 len ) H POP M E MOV 0 D MVI H INX XCHG DPUSH JMP C; CODE LENGTH (S addr -- addr+2 len ) H POP M E MOV H INX M D MOV ' COUNT @-T 4 + JMP C; : MOVE ( from to len -- ) -ROT 2DUP U< IF ROT CMOVE> ELSE ROT CMOVE THEN ; \ Devices Strings 07SEP83HHLASSEMBLER LABEL >UPPER ASCII a CPI RC ASCII z 1+ CPI RNC BL SUI RET CODE UPPER (S addr len -- ) D POP H POP BEGIN D A MOV E ORA 0= NOT WHILE M A MOV >UPPER CALL A M MOV H INX D DCX REPEAT NEXT C; : HERE (S -- addr ) DP @ ; : PAD (S -- addr ) HERE 80 + ; : -TRAILING (S addr len -- addr len' ) DUP 0 DO 2DUP + 1- C@ BL <> ?LEAVE 1- LOOP ; \ Devices Strings 26Sep83mapCODE COMP (S addr1 addr2 len -- -1 | 0 | 1 ) C L MOV B H MOV B POP D POP XTHL ( Stack=IP BC=len DE=addr2 HL=addr1 ) BEGIN B A MOV C ORA 0= NOT WHILE M A MOV XCHG M CMP XCHG 0= IF D INX H INX B DCX ELSE 0< IF 1 H LXI ELSE -1 H LXI THEN B POP HPUSH JMP THEN REPEAT 0 H LXI B POP HPUSH JMP C; \ Devices Strings 26Sep83mapCODE CAPS-COMP (S addr1 addr2 len -- -1 | 0 | 1 ) C L MOV B H MOV B POP D POP XTHL ( Stack=IP BC=len DE=addr2 HL=addr1 ) BEGIN B A MOV C ORA 0= NOT WHILE M A MOV >UPPER CALL B PUSH A C MOV XCHG M A MOV >UPPER CALL C CMP B POP XCHG 0= IF D INX H INX B DCX ELSE 0< IF 1 H LXI ELSE -1 H LXI THEN B POP HPUSH JMP THEN REPEAT 0 H LXI B POP HPUSH JMP C; : COMPARE (S addr1 addr2 len -- -1 | 0 | 1 ) CAPS @ IF CAPS-COMP ELSE COMP THEN ; \ Devices Terminal IO via CP/M BIOS 26Oct83TedCODE BDOS (S n fun -- m ) H POP D POP B PUSH L C MOV 5 CALL 0 H MVI A L MOV B POP HPUSH JMP C; CODE BIOS (S parm func# -- ret ) 1 LHLD D POP D DCX D DAD D DAD D DAD D POP B PUSH D B MOV E C MOV HERE 5 + D LXI D PUSH PCHL 0 H MVI A L MOV B POP HPUSH JMP C; : (KEY?) (S -- f ) 0 2 BIOS 0<> ; : (KEY) (S -- char ) BEGIN PAUSE (KEY?) UNTIL 0 3 BIOS ; : (EMIT) (S char -- ) PAUSE 4 BIOS DROP 1 #OUT +! ; : (PRINT) (S char -- ) BEGIN PAUSE 0 15 NIP UNTIL 5 BIOS DROP 1 #OUT +! ; \ Devices Terminal Input and Output 27Sep83mapDEFER KEY? DEFER KEY DEFER CR : (PEMIT) (S char -- ) DUP (EMIT) (PRINT) -1 #OUT +! ; : CRLF (S -- ) 13 EMIT 10 EMIT #OUT OFF 1 #LINE +! ; : TYPE (S addr len -- ) 0 ?DO COUNT EMIT LOOP DROP ; : SPACE (S -- ) BL EMIT ; : SPACES (S n -- ) 0 MAX 0 ?DO SPACE LOOP ; : BACKSPACES (S n -- ) 0 ?DO BS EMIT LOOP ; : BEEP (S -- ) BELL EMIT ; \ Devices System Dependent Control Characters 05Oct83map: BS-IN (S n c -- 0 | n-1 ) DROP DUP IF 1- BS ELSE BELL THEN EMIT ; : (DEL-IN) (S n c -- 0 | n-1 ) DROP DUP IF 1- BS EMIT SPACE BS ELSE BELL THEN EMIT ; : BACK-UP (S n c -- 0 ) DROP DUP BACKSPACES DUP SPACES BACKSPACES 0 ; : RES-IN (S c -- ) FORTH TRUE ABORT" Reset" ; : P-IN (S c -- ) DROP ['] EMIT >IS DUP @ ['] (EMIT) = IF ['] (PEMIT) ELSE ['] (EMIT) THEN SWAP ! ; \ Devices Terminal Input 02OCT83MAP: CR-IN (S m a n c -- m a m ) DROP SPAN ! OVER BL EMIT ; : (CHAR) (S a n char -- a n+1 ) 3DUP EMIT + C! 1+ ; DEFER CHAR DEFER DEL-IN VARIABLE CC CREATE CC1 ] CHAR CHAR CHAR RES-IN CHAR CHAR CHAR CHAR BS-IN CHAR CHAR CHAR CHAR CR-IN CHAR CHAR P-IN CHAR CHAR CHAR CHAR BACK-UP CHAR CHAR BACK-UP CHAR CHAR CHAR CHAR CHAR CHAR CHAR [ \ Devices Terminal Input 29Sep83map: EXPECT (S adr len -- ) DUP SPAN ! SWAP 0 ( len adr 0 ) BEGIN 2 PICK OVER - ( len adr #so-far #left ) WHILE KEY DUP BL < IF DUP 2* CC @ + PERFORM ELSE DUP 127 = IF DEL-IN ELSE CHAR THEN THEN REPEAT 2DROP DROP ; : TIB (S -- adr ) 'TIB @ ; : QUERY (S -- ) TIB 80 EXPECT SPAN @ #TIB ! BLK OFF >IN OFF ; \ Devices BLOCK I/O 27Sep83map 0 CONSTANT FIRST ( Patched by COLD ) 0 CONSTANT LIMIT ( Patched by COLD ) 4 CONSTANT #BUFFERS 1024 CONSTANT B/BUF 128 CONSTANT B/REC 8 CONSTANT REC/BLK 41 CONSTANT B/FCB VARIABLE DISK-ERROR #BUFFERS 1+ 8 * 2+ CONSTANT >SIZE : >BUFFERS (S -- adr ) FIRST >SIZE - ; : >END (S -- adr ) FIRST 2- ; : BUFFER# (S n -- adr ) 8* >BUFFERS + ; \ Devices BLOCK I/O 02OCT83MAPCREATE FCB1 B/FCB ALLOT : CLR-FCB (S -- ) FILE @ DUP B/FCB ERASE 1+ 11 BLANK ; : RECORD# (S -- addr ) FILE @ 33 + ; : MAXREC# (S -- addr ) FILE @ 38 + ; : CAPACITY (S -- n ) MAXREC# @ 1+ 0 8 UM/MOD NIP ; VARIABLE BADREC# : IN-FILE? (S -- ) MAXREC# @ RECORD# @ U< DUP BADREC# ! ABORT" Out of Range" ; : VIEW# (S -- addr ) FILE @ 40 + ; : SET-DRIVE (S drive -- ) 14 BDOS DROP ; : SET-DMA (S address -- ) 26 BDOS DROP ; : REC-READ (S -- ) IN-FILE? FILE @ 33 BDOS DISK-ERROR ! ; : REC-WRITE (S -- ) IN-FILE? FILE @ 34 BDOS DISK-ERROR ! ; \ Devices BLOCK I/O 29Sep83mapDEFER READ-BLOCK (S buffer-header -- ) DEFER WRITE-BLOCK (S buffer-header -- ) : SET-IO (S buf-header -- buffer rec/blk 0 ) DUP @ REC/BLK * RECORD# ! 4 + @ ( buf-addr ) REC/BLK 0 ; : FILE-READ (S buffer-header -- ) SET-IO DO DUP SET-DMA B/REC + REC-READ 1 RECORD# +! LOOP DROP ; : FILE-WRITE (S buffer-header -- ) FILE @ SWAP DUP 2+ @ FILE ! SET-IO DO DUP SET-DMA B/REC + REC-WRITE 1 RECORD# +! LOOP DROP FILE ! ; : FILE-IO (S -- ) ['] FILE-READ IS READ-BLOCK ['] FILE-WRITE IS WRITE-BLOCK ; \ Devices BLOCK I/O 11SEP83HHL: LATEST? (S n -- n | a f ) OFFSET @ + DUP FILE @ SWAP 1 BUFFER# 2@ D= IF DROP 1 BUFFER# 4 + @ FALSE R> DROP THEN ; : ABSENT? (S n -- a f ) LATEST? DUP >BUFFERS ! TRUE SWAP 1 BUFFER# #BUFFERS 0 DO 2DUP @ = IF DUP 2+ @ FILE @ = IF DUP >BUFFERS 8 CMOVE DUP >BUFFERS DUP 8 + ROT >BUFFERS - CMOVE> DROP 2DROP FALSE DUP 1 BUFFER# LEAVE THEN THEN 8 + LOOP 4 + @ NIP SWAP ; \ Devices BLOCK I/O 29Sep83map: UPDATE (S -- ) 1 BUFFER# 6 + ON ; : DISCARD (S -- ) 1 BUFFER# 6 + OFF ; : MISSING (S -- ) >END 2- @ IF >END 8 - WRITE-BLOCK >END 2- OFF THEN FILE @ >BUFFERS 2+ ! >END 4 - @ >BUFFERS 4 + ! ( buffer ) >BUFFERS 6 + OFF >BUFFERS DUP 8 + #BUFFERS 8* CMOVE> ; : BUFFER (S n -- a ) PAUSE ABSENT? IF DROP MISSING 1 BUFFER# 4 + @ THEN ; : BLOCK (S n -- a ) PAUSE ABSENT? IF DROP MISSING 1 BUFFER# DUP READ-BLOCK 4 + @ THEN ; \ Devices BLOCK I/O 29Sep83map: EMPTY-BUFFERS (S -- ) FIRST LIMIT OVER - ERASE >BUFFERS #BUFFERS 1+ 8* ERASE FIRST 1 BUFFER# #BUFFERS 0 DO -1 OVER ! 4 + 2DUP ! SWAP B/BUF + SWAP 4 + LOOP 2DROP ; : SAVE-BUFFERS (S -- ) 1 BUFFER# #BUFFERS 0 DO DUP @ 1+ IF DUP 6 + @ IF DUP WRITE-BLOCK DUP 6 + OFF THEN 8 + THEN LOOP DROP ; : FLUSH (S -- ) SAVE-BUFFERS 0 BLOCK DROP EMPTY-BUFFERS ; \ Devices BLOCK I/O 27Sep83map: FILE-SIZE (S -- n ) FILE @ 35 BDOS DROP RECORD# @ ; : CPM-ERR? (S -- f ) 255 = ; : OPEN-FILE (S -- ) FILE @ 15 BDOS CPM-ERR? ABORT" Can't open file" FILE-SIZE 1- MAXREC# ! ; : MORE (S n -- ) 8* MAXREC# +! ; 92 CONSTANT CPM-FCB : DEFAULT (S -- ) FCB1 FILE ! CLR-FCB CPM-FCB 1+ C@ BL <> IF CPM-FCB FCB1 12 CMOVE OPEN-FILE THEN ; : (LOAD) (S n -- ) BLK @ >R >IN @ >R >IN OFF BLK ! RUN R> >IN ! R> BLK ! ; DEFER LOAD \ Interactive Layer Number Input 06Oct83mapCODE DIGIT (S char base -- n f ) H POP D POP D PUSH E A MOV ASCII 0 SUI NO JM 10 CPI 0< NOT IF 7 SUI 10 CPI NO JM THEN L CMP NO JP A E MOV H POP D PUSH YES JMP C; : DOUBLE? (S -- f ) DPL @ 1+ 0<> ; : CONVERT (S +d1 adr1 -- +d2 adr2 ) BEGIN 1+ DUP >R C@ BASE @ DIGIT WHILE SWAP BASE @ UM* DROP ROT BASE @ UM* D+ DOUBLE? IF 1 DPL +! THEN R> REPEAT DROP R> ; \ Interactive Layer Number Input 06Oct83map: (NUMBER?) (S adr -- d flag ) 0 0 ROT DUP 1+ C@ ASCII - = DUP >R - -1 DPL ! BEGIN CONVERT DUP C@ ASCII , ASCII / BETWEEN WHILE 0 DPL ! REPEAT -ROT R> IF DNEGATE THEN ROT C@ BL = ; : NUMBER? (S adr -- d flag ) FALSE OVER COUNT BOUNDS ?DO I C@ BASE @ DIGIT NIP IF DROP TRUE LEAVE THEN LOOP IF (NUMBER?) ELSE DROP 0 0 FALSE THEN ; : (NUMBER) (S adr -- d# ) NUMBER? NOT ?MISSING ; DEFER NUMBER \ Interactive Layer Number Output 26sep83map: HOLD (S char -- ) -1 HLD +! HLD @ C! ; : <# (S -- ) PAD HLD ! ; : #> (S d# -- addr len ) 2DROP HLD @ PAD OVER - ; : SIGN (S n1 -- ) 0< IF ASCII - HOLD THEN ; : # (S -- ) BASE @ MU/MOD ROT 9 OVER < IF 7 + THEN ASCII 0 + HOLD ; : #S (S -- ) BEGIN # 2DUP OR 0= UNTIL ; : HEX (S -- ) 16 BASE ! ; : DECIMAL (S -- ) 10 BASE ! ; \ Interactive Layer Number Output 24FEB83HHL: (U.) (S u -- a l ) 0 <# #S #> ; : U. (S u -- ) (U.) TYPE SPACE ; : U.R (S u l -- ) >R (U.) R> OVER - SPACES TYPE ; : (.) (S n -- a l ) DUP ABS 0 <# #S ROT SIGN #> ; : . (S n -- ) (.) TYPE SPACE ; : .R (S n l -- ) >R (.) R> OVER - SPACES TYPE ; : (UD.) (S ud -- a l ) <# #S #> ; : UD. (S ud -- ) (UD.) TYPE SPACE ; : UD.R (S ud l -- ) >R (UD.) R> OVER - SPACES TYPE ; : (D.) (S d -- a l ) TUCK DABS <# #S ROT SIGN #> ; : D. (S d -- ) (D.) TYPE SPACE ; : D.R (S d l -- ) >R (D.) R> OVER - SPACES TYPE ; \ Interactive Layer Parsing 30Sep83mapLABEL $DONE B POP H PUSH D PUSH NEXT C; CODE SKIP (S addr len char -- addr' len' ) IP>HL B POP D POP XTHL ( C=char DE=length HL=addr ) BEGIN D A MOV E ORA 0<> WHILE M A MOV C CMP $DONE JNZ H INX D DCX REPEAT $DONE JMP C; CODE SCAN (S addr len char -- addr' len' ) IP>HL B POP D POP XTHL ( C=char DE=length HL=addr ) BEGIN D A MOV E ORA 0<> WHILE M A MOV C CMP $DONE JZ H INX D DCX REPEAT $DONE JMP C; \ Interactive Layer Parsing 01Oct83map: /STRING (S addr len n -- addr' len' ) OVER MIN ROT OVER + -ROT - ; : PLACE (S str-addr len to -- ) 2DUP C! 1+ SWAP MOVE ; : (SOURCE) (S -- addr len ) BLK @ ?DUP IF BLOCK B/BUF ELSE TIB #TIB @ THEN ; DEFER SOURCE : PARSE-WORD (S char -- addr len ) >R SOURCE >IN @ /STRING OVER SWAP R@ SKIP OVER SWAP R> SCAN DROP 2DUP SWAP - >R ROT - 1+ >IN +! R> ; : PARSE (S char -- addr len ) >R SOURCE >IN @ /STRING OVER SWAP R> SCAN DROP OVER - DUP 1+ >IN +! ; \ Interactive Layer Parsing 01OCT83MAP: 'WORD (S -- adr ) HERE ; : WORD (S char -- addr ) PARSE-WORD 'WORD PLACE 'WORD DUP COUNT + BL SWAP C! ( Stick Blank at end ) ; : .( (S -- ) ASCII ) PARSE TYPE ; IMMEDIATE : ( (S -- ) ASCII ) PARSE 2DROP ; IMMEDIATE \ Interactive Layer Dictionary 16Oct83map: X (S -- ) END? ON ; HEX 80 LAST-T @ A0 OVER 1+ C!-T C!-T DECIMAL IMMEDIATE CODE TRAVERSE (S addr direction -- addr' ) D POP H POP 127 A MVI BEGIN D DAD M CMP 0< UNTIL HPUSH JMP C; : DONE? (S n -- f ) STATE @ <> END? @ OR END? OFF ; : FORTH-83 (S -- ) ; : .VERSION (S -- ) [ VERSION ] LITERAL 0 <# # ASCII . HOLD # ASCII . HOLD # #> TYPE SPACE ; \ Interactive Layer Dictionary 27AUG83HHL: N>LINK 2- ; : L>NAME 2+ ; : BODY> 2- ; : NAME> 1 TRAVERSE 1+ ; : LINK> L>NAME NAME> ; : >BODY 2+ ; : >NAME 1- -1 TRAVERSE ; : >LINK >NAME N>LINK ; : >VIEW >LINK 2- ; : VIEW> 2+ LINK> ; \ Interactive Layer Dictionary 27AUG83HHLCODE HASH (S str-addr voc-ptr -- thread ) D POP H POP H INX M A MOV 3 ANI A L MOV 0 H MVI H DAD D DAD HPUSH JMP C; CODE (FIND) (S here nfa -- here false | cfa flag ) H POP H A MOV L ORA NO JZ BEGIN D POP D PUSH H PUSH H INX H INX D LDAX M XRA 63 ANI 0= IF BEGIN D INX H INX D LDAX M XRA A ADD 0= IF 2SWAP CS UNTIL H INX D POP XTHL XCHG H INX H INX M A MOV 64 ANI YES JZ 1 H LXI HPUSH JMP THEN THEN H POP M E MOV H INX M D MOV XCHG H A MOV L ORA 0= UNTIL NO JMP C; \ Interactive Layer Dictionary 11SEP83HHL4 CONSTANT #THREADS : FIND (S addr -- cfa flag | addr false ) PRIOR OFF FALSE #VOCS 0 DO DROP CONTEXT I 2* + @ DUP IF DUP PRIOR @ OVER PRIOR ! = IF DROP FALSE ELSE OVER SWAP HASH @ (FIND) DUP ?LEAVE THEN THEN LOOP ; : DEFINED (S -- here 0 | cfa [ -1 | 1 ] ) BL WORD CAPS @ IF DUP COUNT UPPER THEN FIND ; \ Interactive Layer Interpreter 27Sep83map: ?STACK (S -- ) ( System dependant ) SP@ SP0 @ SWAP U< ABORT" Stack Underflow" SP@ PAD U< ABORT" Stack Overflow" ; DEFER STATUS (S -- ) : INTERPRET (S -- ) BEGIN ?STACK DEFINED IF EXECUTE ELSE NUMBER DOUBLE? NOT IF DROP THEN THEN FALSE DONE? UNTIL ; \ Extensible Layer Compiler 23JUL83HHL: ALLOT (S n -- ) DP +! ; : , (S n -- ) HERE ! 2 ALLOT ; : C, (S char -- ) HERE C! 1 ALLOT ; : ALIGN ; IMMEDIATE ( HERE 1 AND IF BL C, THEN ) : EVEN ; IMMEDIATE ( DUP 1 AND + ) : COMPILE (S -- ) R> DUP 2+ >R @ , ; : IMMEDIATE (S -- ) 64 ( Precedence bit ) LAST @ CTOGGLE ; : LITERAL (S n -- ) COMPILE (LIT) , ; IMMEDIATE : DLITERAL (S d# -- ) SWAP [COMPILE] LITERAL [COMPILE] LITERAL ; IMMEDIATE : ASCII (S -- n ) BL WORD 1+ C@ STATE @ IF [COMPILE] LITERAL THEN ; IMMEDIATE : CONTROL (S -- n ) BL WORD 1+ C@ ASCII @ - STATE @ IF [COMPILE] LITERAL THEN ; IMMEDIATE \ Extensible Layer Compiler 08Oct83map: CRASH (S -- ) TRUE ABORT" Uninitialized execution vector." ; : ?MISSING (S f -- ) IF 'WORD COUNT TYPE TRUE ABORT" ?" THEN ; : ' (S -- cfa ) DEFINED 0= ?MISSING ; : ['] (S -- ) ' [COMPILE] LITERAL ; IMMEDIATE : [COMPILE] (S -- ) ' , ; IMMEDIATE : (") (S -- addr len ) R> COUNT 2DUP + EVEN >R ; : (.") (S -- ) R> COUNT 2DUP + EVEN >R TYPE ; : ," (S -- ) ASCII " PARSE TUCK 'WORD PLACE 1+ ALLOT ALIGN ; : ." (S -- ) COMPILE (.") ," ; IMMEDIATE : " (S -- ) COMPILE (") ," ; IMMEDIATE \ Interactive Layer Dictionary 01OCT83MAPVARIABLE FENCE : TRIM (S faddr voc-addr -- ) #THREADS 0 DO 2DUP @ BEGIN 2DUP U> NOT WHILE @ REPEAT NIP OVER ! 2+ LOOP 2DROP ; : (FORGET) (S addr -- ) DUP FENCE @ U< ABORT" Below fence" DUP VOC-LINK @ BEGIN 2DUP U< WHILE @ REPEAT DUP VOC-LINK ! NIP BEGIN DUP WHILE 2DUP #THREADS 2* - TRIM @ REPEAT DROP DP ! ; : FORGET (S -- ) BL WORD CAPS @ IF DUP COUNT UPPER THEN CURRENT @ OVER SWAP HASH @ (FIND) 0= ?MISSING >VIEW (FORGET) ; \ Extensible Layer Compiler 16Oct83mapDEFER WHERE DEFER ?ERROR : (?ERROR) (S adr len f -- ) IF >R >R SP0 @ SP! PRINTING OFF BLK @ IF >IN @ BLK @ WHERE THEN R> R> SPACE TYPE SPACE QUIT ELSE 2DROP THEN ; : (ABORT") (S f -- ) R@ COUNT ROT ?ERROR R> COUNT + EVEN >R ; : ABORT" (S -- ) COMPILE (ABORT") ," ; IMMEDIATE : ABORT (S -- ) SP0 @ SP! QUIT ; \ Extensible Layer Structures 01Oct83map: ?CONDITION (S f -- ) NOT ABORT" Conditionals Wrong" ; : >MARK (S -- addr ) HERE 0 , ; : >RESOLVE (S addr -- ) HERE SWAP ! ; : MARK (S -- f addr ) TRUE >MARK ; : ?>RESOLVE (S f addr -- ) SWAP ?CONDITION >RESOLVE ; : ?RESOLVE ; IMMEDIATE : DO COMPILE (DO) ?>MARK ; IMMEDIATE : ?DO COMPILE (?DO) ?>MARK ; IMMEDIATE : LOOP COMPILE (LOOP) 2DUP 2+ ?RESOLVE ; IMMEDIATE : +LOOP COMPILE (+LOOP) 2DUP 2+ ?RESOLVE ; IMMEDIATE : UNTIL COMPILE ?BRANCH ?MARK ; IMMEDIATE : ELSE COMPILE BRANCH ?>MARK 2SWAP ?>RESOLVE ; IMMEDIATE : WHILE [COMPILE] IF ; IMMEDIATE \ Extensible Layer Defining Words 16Oct83map: ,VIEW (S -- ) VIEW# @ 4096 * BLK @ + , ; : HEADER (S -- ) ALIGN ,VIEW HERE 0 , ( Temp link field ) HERE LAST ! ( Remember nfa ) WARNING @ IF DEFINED IF HERE COUNT TYPE ." isn't unique " THEN DROP HERE ELSE BL WORD THEN CURRENT @ HASH DUP @ ( Stack: cfa lfa tha prev) HERE 2- ROT ! ( Stack: cfa lfa prev ) SWAP ! ( Resolve link field, Stack: cfa ) HERE DUP C@ WIDTH @ MIN 1+ ALLOT ALIGN 128 SWAP CSET 128 HERE 1- CSET ( Delimiter Bits ) ; : CREATE (S -- ) HEADER COMPILE [ [FORTH] ASSEMBLER DOCREATE , META ] ; \ Extensible Layer Defining Words 07SEP83HHL: !CSP (S -- ) SP@ CSP ! ; : ?CSP (S -- ) SP@ CSP @ <> ABORT" Stack Changed" ; : HIDE (S -- ) LAST @ DUP N>LINK @ SWAP CURRENT @ HASH ! ; : REVEAL (S -- ) LAST @ DUP N>LINK SWAP CURRENT @ HASH ! ; : (;USES) (S -- ) R> @ LAST @ NAME> ! ; VOCABULARY ASSEMBLER : ;USES (S -- ) ?CSP COMPILE (;USES) [COMPILE] [ REVEAL ASSEMBLER ; IMMEDIATE : (;CODE) (S -- ) R> LAST @ NAME> ! ; : ;CODE (S -- ) ?CSP COMPILE (;CODE) [COMPILE] [ REVEAL ASSEMBLER ; IMMEDIATE : DOES> (S -- ) COMPILE (;CODE) 205 ( CALL ) C, [ [FORTH] ASSEMBLER DODOES META ] LITERAL , ; IMMEDIATE \ Extensible Layer Defining Words 27Sep83map: [ (S -- ) STATE OFF ; IMMEDIATE : ] (S -- ) STATE ON BEGIN ?STACK DEFINED DUP IF 0> IF EXECUTE ELSE , THEN ELSE DROP NUMBER DOUBLE? IF [COMPILE] DLITERAL ELSE DROP [COMPILE] LITERAL THEN THEN TRUE DONE? UNTIL ; : : (S -- ) !CSP CURRENT @ CONTEXT ! CREATE HIDE ] ;USES NEST , : ; (S -- ) ?CSP COMPILE UNNEST REVEAL [COMPILE] [ ; IMMEDIATE \ Extensible Layer Defining Words 16Oct83map: RECURSIVE (S -- ) REVEAL ; IMMEDIATE : CONSTANT (S n -- ) CREATE , ;USES DOCONSTANT , : VARIABLE (S -- ) CREATE 0 , ;USES DOCREATE , : DEFER CREATE ['] CRASH , ;USES DODEFER , DODEFER RESOLVES : VOCABULARY (S -- ) CREATE ( Threads ) #THREADS 0 DO 0 , LOOP HERE VOC-LINK @ , VOC-LINK ! DOES> CONTEXT ! ; RESOLVES : DEFINITIONS (S -- ) CONTEXT @ CURRENT ! ; \ Extensible Layer Defining Words 06Oct83map: 2CONSTANT CREATE , , (S d# -- ) DOES> 2@ ; (S -- d# ) DROP : 2VARIABLE 0 0 2CONSTANT (S -- ) DOES> ; (S -- addr ) DROP VARIABLE AVOC : CODE (S -- ) CREATE HIDE HERE HERE 2- ! CONTEXT @ AVOC ! ASSEMBLER ; ASSEMBLER DEFINITIONS : END-CODE AVOC @ CONTEXT ! REVEAL ; FORTH DEFINITIONS META IN-META \ Extensible Layer Defining Words 07SEP83HHLVARIABLE #USER VOCABULARY USER USER DEFINITIONS : ALLOT (S n -- ) #USER +! ; : CREATE (S -- ) CREATE #USER @ , ;USES DOUSER-VARIABLE , : VARIABLE (S -- ) CREATE 2 ALLOT ; : DEFER (S -- ) VARIABLE ;USES DOUSER-DEFER , FORTH DEFINITIONS META IN-META \ Extensible Layer ReDefining Words 07SEP83HHL: >IS (S cfa -- data-address ) DUP @ DUP [ [FORTH] ASSEMBLER DOUSER-VARIABLE META ] LITERAL = SWAP DUP [ [FORTH] ASSEMBLER DOUSER-DEFER META ] LITERAL = SWAP DROP OR IF >BODY @ UP @ + ELSE >BODY THEN ; : (IS) (S cfa --- ) R@ @ >IS ! R> 2+ >R ; : IS (S cfa --- ) STATE @ IF COMPILE (IS) ELSE ' >IS ! THEN ; IMMEDIATE \ Initialization High Level 29Sep83map: RUN (S -- ) STATE @ IF ] STATE @ NOT IF INTERPRET THEN ELSE INTERPRET THEN ; : QUIT (S -- ) SP0 @ 'TIB ! BLK OFF [COMPILE] [ BEGIN RP0 @ RP! STATUS QUERY RUN STATE @ NOT IF ." ok" THEN AGAIN ; DEFER BOOT : WARM (S -- ) TRUE ABORT" Warm Start" ; : COLD (S -- ) BOOT QUIT ; \ Initialization High Level 06Oct83map1 CONSTANT INITIAL : OK (S -- ) INITIAL LOAD ; : START (S -- ) EMPTY-BUFFERS DEFAULT OK ; : BYE ( -- ) CR HERE 0 256 UM/MOD 1+ DECIMAL U. DROP ." Pages" 0 0 BDOS ; \ Initialization Low Level 29Sep83map[FORTH] ASSEMBLER HERE ORIGIN 6 + !-T ( WARM ENTRY POINT ) ' WARM H LXI >NEXT1 JMP HERE ORIGIN 2 + !-T ( COLD ENTRY POINT ) 6 LHLD 0 L MVI ' LIMIT 2+ SHLD #BUFFERS B/BUF * NEGATE D LXI D DAD ' FIRST 2+ SHLD >SIZE NEGATE D LXI D DAD RP SHLD H PUSH RP0 D LXI !USER CALL H POP 200 NEGATE D LXI D DAD ( Return Stack Size ) H PUSH 'TIB SHLD H POP H PUSH SP0 D LXI !USER CALL H POP SPHL ' COLD H LXI >NEXT1 JMP \ Initialize User Variables 16Oct83mapHERE UP !-T ( SET UP USER AREA ) 0 , ( TOS ) 0 , ( ENTRY ) 0 , ( LINK ) 0 , ( SP0 ) 0 , ( RP0 ) 0 , ( DP ) ( Must be patched later ) 0 , ( #OUT ) 0 , ( #LINE ) 0 , ( OFFSET ) 10 , ( BASE ) 0 , ( HLD ) 0 , ( FILE ) FALSE , ( PRINTING ) ' (EMIT) , ( EMIT ) \ Resident Tools 29Sep83map: DEPTH (S -- n ) SP@ SP0 @ SWAP - 2/ ; : .S (S -- ) DEPTH ?DUP IF 0 DO DEPTH I - 1- PICK 7 U.R SPACE LOOP ELSE ." Empty " THEN ; : .ID (S nfa -- ) DUP 1+ DUP C@ ROT C@ 31 AND 0 ?DO DUP 127 AND EMIT 128 AND IF ASCII _ 128 OR ELSE 1+ DUP C@ THEN LOOP 2DROP SPACE ; : DUMP (S addr len -- ) 0 DO CR DUP 6 .R SPACE 16 0 DO DUP C@ 3 .R 1+ LOOP 16 +LOOP DROP ; \ For Completeness 06Oct83map: RECURSE (S -- ) LAST @ NAME> , ; IMMEDIATE : OCTAL (S -- ) 8 BASE ! ; \ Resolve Forward References 07SEP83HHL ' (.") RESOLVES <(.")> ' (") RESOLVES <(")> ' (;CODE) RESOLVES <(;CODE)> ' (;USES) RESOLVES <(;USES)> ' (IS) RESOLVES <(IS)> ' (ABORT") RESOLVES <(ABORT")> [FORTH] ASSEMBLER DOCREATE META RESOLVES [FORTH] ASSEMBLER DOUSER-DEFER META RESOLVES [FORTH] ASSEMBLER DOUSER-VARIABLE META RESOLVES \ Resolve Forward References 13Oct83map' R> RESOLVES R> ' DUP RESOLVES DUP ' @ RESOLVES @ ' >R RESOLVES >R ' -ROT RESOLVES -ROT ' SWAP RESOLVES SWAP ' - RESOLVES - ' = RESOLVES = ' 2DROP RESOLVES 2DROP ' + RESOLVES + ' OVER RESOLVES OVER ' DEFINITIONS RESOLVES DEFINITIONS ' [ RESOLVES [ ' 2+ RESOLVES 2+ ' 1+ RESOLVES 1+ ' 2* RESOLVES 2* ' 2DUP RESOLVES 2DUP ' ?MISSING RESOLVES ?MISSING ' QUIT RESOLVES QUIT ' RUN RESOLVES RUN ' >IS RESOLVES >IS \ Initialize DEFER words 16Oct83map ' (LOAD) IS LOAD ' CRLF IS CR ' (KEY?) IS KEY? ' (KEY) IS KEY ' FILE-READ IS READ-BLOCK ' FILE-WRITE IS WRITE-BLOCK ' NOOP IS WHERE ' CR IS STATUS ' (?ERROR) IS ?ERROR ' (SOURCE) IS SOURCE ' NOOP IS BOOT ' (NUMBER) IS NUMBER ' (CHAR) IS CHAR ' (DEL-IN) IS DEL-IN \ Initialize Variables 01Oct83map' FORTH >BODY CURRENT !-T ' FORTH >BODY CONTEXT !-T ' CC1 >BODY CC !-T HERE-T DP UP @-T + !-T ( INIT USER DP ) #USER-T @ #USER !-T ( INIT USER VAR COUNT ) FALSE CAPS !-T ( SET TO RESPECT CASE ) TRUE WARNING !-T ( SET TO ISSUE WARNINGS ) 31 WIDTH !-T ( 31 CHARACTER NAMES ) VOC-LINK-T @ VOC-LINK !-T ( INIT VOC-LINK ) \ Further Instructions 27SEP83MAPEXIT ******************************************************************* ****** Thus we have created a hopefully running ****** Forth system for the 8080. After this file ****** has been compiled, it is saved as a COM file ****** called KERNEL.COM on the disk. To generate ****** a system you must now leave the Meta Compiler ****** and fire up KERNEL with the file EXTEND80.BLK ****** on the execute line. Be sure to prefix a B: ****** if necessary. ( KERNEL EXTEND80.BLK ) ****** Once you have fired it up, type START and it ****** will compile the applications. Good Luck. ****** ******************************************************************* \ Load Screen for Pre-Compile 10MAR83HHLMeta Compiling is a term to describe the process of regeneratinga Forth system by compiling itself. It is similar in idea to the ordinary notion of compiling in Forth, but has some important differences. First the code that is generated by the Meta Compiler is generally not immediately executable. This maybe for a variety of reasons, such as that the object code generated physically resides at a different address from where it must be to execute correctly. Also, it is possible through Meta Compilation to generate a Forth System for a totally different CPU than the one the Meta Compiler is running on. In such a case, the object code of course is not executable on the Host System. This Screen is the load screen for the Meta Compiler itself. The purpose of this section of the Meta Compiler is to compile Code Words correctly. \ Target System Setup 10MAR83HHL Make Room for HOST definitions Set up the address where Target Compiled Code begins Set up the address where the Target Headers begin Set up the HOST address where Target Image resides Load the Source Screens that define the System Save the System as a CP/M file, ready to be executed \ Vocabulary Helpers 07SEP83HHL META The Meta Compiler Environment, many redefintions DP-T The dictionary Pointer while meta compiling [FORTH] For convenience, an immediate version [META] For convenience, an immediate version SWITCH Exchange the saved values of CONTEXT and CURRENT with themselves. This should be used in pairs, and is only really meaningful in the second occurance. Its purpose is to save and restore the CONTEXT and CURRENT vocabularies. Following the first occurance you should invoke a vocabulary and perhaps DEFINITIONS. \ Memory Access Words 10MAR83HHLTARGET-ORIGIN The Offset where the Target Image resides THERE Map a Target address to a Host address C@-T Fetch a byte at the given Target address @-T Fetch a word at the given Target address C!-T Store a byte at the given Target address !-T Store a word at the given Target address HERE-T Target address of next available dictionary byteALLOT-T Allocate more space in the Target dictionary C,-T Add a byte to the Target dictionary ,-T Add a word to the Target dictionary S,-T Add a string to the Target dictionary \ Define Symbol Table Vocabularies 07SEP83HHLTARGET The symbol table for Target definitions TRANSITION Holds special case compiling words, like ." and [ FORWARD Holds all forward references, not neccessary but niceUSER Holds USER version of defining words We add all of the vocabulary names to the ONLY vocabulary so that they are always accessible. This is mainly a convienence during debugging, when something fails and we need to look at different words in various vocabularies to figure out what is going on. Now we are guaranteed that we can reference all of the vocabularies inside META without standing on our heads. \ 8080 Meta Assembler 02AUG83HHL?>MARK Set up for a forward branch. ?>RESOLVE Resolve a forward branch. ?