\ The Rest is Silence 5 /15/88************************************************************* ************************************************************* *** *** *** Please direct all questions, comments, and *** *** miscellaneous personal abuse to: *** *** *** *** Gary Bergstrom *** *** 191 Miles Rd. *** *** Chagrin Fall, Ohio *** *** 44022 *** *** *** ************************************************************* ************************************************************* \ Target System Setup 1JUL87GEBONLY FORTH ' NLOAD IS LOAD META ALSO FORTH 256 DP-T ! 100 ' TARGET-ORIGIN >BODY ! IN-META 2 92 THRU ( System Source Screens ) CR .( Unresolved references: ) CR .UNRESOLVED CR .( Statistics: ) CR .( First Target Address: ) 256 THERE target-origin - DROP U. CR .( Last Target Address: ) HERE-T THERE DROP U. CR CR META >BODY-T 256 THERE >HEAD-T HERE-T 32768 + ONLY FORTH ALSO DOS LSAVE KERNEL.COM FORTH CR .( Now return to the DOS and type: ) CR .( KERNEL EXTEND.SCR <CR> ) CR .( OK <CR> ) \ Declare the Forward References and Version # 5 /15/88: ]] COMPILER ; : [[ R> DROP ; FORTH IMMEDIATE META FORWARD: DEFINITIONS FORWARD: [ \ Boot up Vectors and NEXT Interpreter 27JAN86GEBASSEMBLER LABEL ORIGIN $8100 #) JMP \ jump to cold start: will be patched $8100 #) JMP \ jump to warm start: will be patched LABEL >NEXT AX LODS AX JMP \ H: NEXT META ASSEMBLER >NEXT #) JMP ; H: NEXT META ASSEMBLER AX LODS AX JMP ; ( also change CPU8086.BLK scr# 17 ) >HEAD-T HERE-T DUP 100 + CURRENT-T ! >BODY-T ( harmless ) VOCABULARY FORTH FORTH DEFINITIONS \ ************************************** DANGER BELOW ! ***** >HEAD-T 0 OVER 2+ !-T ( link ) >BODY-T 2+ HERE-T 6 - !-T ( thread ) IN-META ( number 17 is dependent on CFA size ! ) \ Run Time Code for Defining Words 4 /22/89ASSEMBLER LABEL NEST -2 # RP ADD IP 0 [RP] MOV IP POP NEXT META CODE EXIT ( -- ) RP SP XCHG IP POP RP SP XCHG NEXT END-CODE CODE UNNEST RP SP XCHG IP POP RP SP XCHG NEXT END-CODE LABEL DODOES IP DI MOV IP POP RP SP XCHG DI PUSH 0 [RP] BX XCHG RP SP XCHG NEXT LABEL DOCREATE DI POP BX PUSH DI BX MOV NEXT META \ Run Time Code for Defining Words 23JAN86GEBVARIABLE UP LABEL DOCONSTANT DI POP BX PUSH 0 [DI] BX MOV NEXT END-CODE LABEL DOUSER-VARIABLE DI POP BX PUSH 0 [DI] BX MOV UP #) BX ADD NEXT END-CODE LABEL DODEFER DI POP 0 [DI] JMP END-CODE LABEL DOUSER-DEFER DI POP 0 [DI] DI MOV UP #) DI ADD 0 [DI] JMP END-CODE CODE (LIT) ( -- n) BX PUSH AX LODS AX BX MOV NEXT END-CODE CODE (') ( -- n) BX PUSH AX LODS AX BX MOV NEXT END-CODE CODE (ASCII) ( - n) BX PUSH AX LODS AX BX MOV NEXT END-CODE \ Meta Defining Words 22JAN86GEBT: 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 ,JSR [[ ASSEMBLER DOCONSTANT ]] LITERAL ,HERE-T DUP ,-T CONSTANT ; \ Identify numbers and forward References 27JAN86GEB FORWARD: <(;CODE)> T: DOES> ( -- ) [FORWARD] <(;CODE)> HERE-T ( DOES-OP ) 232 C,-T [[ ASSEMBLER DODOES ]] LITERAL HERE 2+ - ,-T T; : NUMERIC ( -- ) [FORTH] HERE [META] NUMBER DPL @ 1+ IF [[ TRANSITION ]] DLITERAL [META] ELSE DROP [[ TRANSITION ]] LITERAL [META] THEN ; : UNDEFINED ( -- ) HERE-T 0 ,-T IN-FORWARD [FORTH] CREATE [META] TRANSITION [FORTH] , FALSE , [META] DOES> FORWARD-CODE ; \ Meta Compiler Compiling Loop 22JAN86GEB[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 -- ) >BODY-T HERE 1 AND 0= IF 0 C,-T THEN TARGET-CREATE ,JSR [[ ASSEMBLER NEST ]] LITERAL ,HERE-T ] ; \ Run Time Code for Control Structures 3 /27/89CODE BRANCH (S -- ) LABEL BRAN1 0 [IP] IP MOV NEXT END-CODE CODE ?BRANCH (S f -- ) BX BX OR BX POP BRAN1 JE 2 # IP ADD NEXT END-CODE 0 c,-t ( this speeds up looping as of 3/27/89 ) ( must change if kernel is changed ) LABEL LOOPEXIT 6 # RP ADD 2 # IP ADD NEXT END-CODE \ Meta Compiler Branching Words 5 /15/88T: BEGIN ?<MARK T; T: AGAIN [TARGET] BRANCH ?<RESOLVE T; T: UNTIL [TARGET] ?BRANCH ?<RESOLVE T; T: IF [TARGET] ?BRANCH ?>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 01JUL87GEBCODE (LOOP) 0 [RP] INC LOOPEXIT JO 0 [IP] IP MOV NEXT END-CODE CODE (+LOOP) (S n -- ) BX 0 [RP] ADD BX POP LOOPEXIT JO 0 [IP] IP MOV NEXT END-CODE HEX CODE (DO) (S l i -- ) DX POP LABEL PDO RP SP XCHG AX LODS AX PUSH 8000 # DX ADD DX PUSH DX BX SUB BX PUSH RP SP XCHG BX POP NEXT END-CODE CODE (?DO) (S l i -- ) DX POP DX BX CMP PDO JNE 0 [IP] IP MOV BX POP NEXT END-CODE DECIMAL CODE BOUNDS (S adr len -- lim first ) AX POP AX BX ADD BX PUSH AX BX MOV NEXT END-CODE \ Meta compiler Branching & Looping 5 /15/88T: ?DO [TARGET] (?DO) ?>MARK T; T: DO [TARGET] (DO) ?>MARK T; T: LOOP [TARGET] (LOOP) 2DUP 2+ ?<RESOLVE ?>RESOLVE T; T: +LOOP [TARGET] (+LOOP) 2DUP 2+ ?<RESOLVE ?>RESOLVE T; \ Execution Control 23jan86gebASSEMBLER >NEXT META CONSTANT >NEXT CODE EXECUTE (S cfa -- ) BX AX MOV BX POP AX JMP END-CODE CODE PERFORM (S addr-of-cfa -- ) 0 [BX] AX MOV BX POP AX JMP END-CODE CODE GO (S addr -- ) BX AX MOV BX POP AX JMP END-CODE HEX CODE NOOP E9 C,-T 0 ,-T NEXT END-CODE CODE PAUSE E9 C,-T 0 ,-T NEXT END-CODE DECIMAL \ Execution Control 4 /6 /88CODE I ( -- n ) BX PUSH 0 [RP] BX MOV 2 [RP] BX ADD NEXT END-CODE CODE J ( -- n ) BX PUSH 6 [RP] BX MOV 8 [RP] BX ADD NEXT END-CODE DECIMAL CODE (LEAVE) ( -- ) LABEL PLEAVE 4 [RP] IP MOV 6 # RP ADD NEXT END-CODE CODE (?LEAVE) ( f -- ) BX BX OR BX POP PLEAVE JNE NEXT END-CODE T: LEAVE [TARGET] (LEAVE) T; T: ?LEAVE [TARGET] (?LEAVE) T; \ 16 and 8 bit Memory Operations 1JUL87GEBCODE @ (S addr -- n ) 0 [BX] BX MOV NEXT END-CODE CODE ! (S n addr -- ) 0 [BX] POP BX POP NEXT END-CODE CODE C@ (S addr -- char ) 0 [BX] BX MOV BH BH SUB NEXT END-CODE CODE C! (S char addr -- ) AX POP AL 0 [BX] MOV BX POP NEXT END-CODE CODE 2@ (S addr -- d ) 2 [BX] PUSH 0 [BX] BX MOV NEXT END-CODE CODE 2! (S d addr -- ) 0 [BX] POP 2 [BX] POP BX POP NEXT END-CODE CODE +! (S n addr -- ) AX POP AX 0 [BX] ADD BX POP NEXT END-CODE \ Block Move Memory Operations 22JAN86GEBCODE CMOVE (S from to count -- ) CLD IP DX MOV DS AX MOV AX ES MOV BX CX MOV DI POP IP POP REP BYTE MOVS DX IP MOV BX POP NEXT END-CODE CODE CMOVE> (S from to count -- ) STD IP DX MOV DS AX MOV AX ES MOV BX CX MOV CX DEC DI POP IP POP CX DI ADD CX IP ADD CX INC REP BYTE MOVS DX IP MOV CLD BX POP NEXT END-CODE CODE FILL ( start-adr count char -- ) CLD DS AX MOV AX ES MOV BX AX MOV CX POP DI POP REP AL STOS BX POP NEXT END-CODE \ NOTE: These routines destroy ES \ 16 and 8 bit Long Memory Operations 5 /15/88CODE L@ (S adr seg -- n ) BX ES MOV BX POP ES: 0 [BX] PUSH BX POP NEXT END-CODE CODE L! (S n adr seg -- ) BX ES MOV BX POP ES: 0 [BX] POP BX POP NEXT END-CODE CODE LC@ (S adr seg -- char ) BX ES MOV BX POP ES: 0 [BX] BL MOV BH BH XOR NEXT END-CODE CODE LC! (S char adr seg -- ) BX ES MOV BX POP AX POP AL ES: 0 [BX] MOV BX POP NEXT END-CODE CODE LCMOVE ( from fromseg to toseg len -- ) BX CX MOV SI BX MOV DS DX MOV ES POP DI POP DS POP SI POP CLD REP BYTE MOVS DX DS MOV BX SI MOV BX POP NEXT END-CODE CODE CSEG ( -- codeseg ) BX PUSH CS BX MOV NEXT END-CODE \ 16 bit Stack Operations 22JAN86GEBCODE SP@ (S -- n ) BX PUSH SP BX MOV NEXT END-CODE CODE SP! (S n -- ) BX SP MOV BX POP NEXT END-CODE CODE RP@ (S -- addr ) BX PUSH RP BX MOV NEXT END-CODE CODE RP! (S n -- ) BX RP MOV BX POP NEXT END-CODE CODE R> (S -- n ) BX PUSH 0 [RP] BX MOV RP INC RP INC NEXT END-CODE CODE >R (S n -- ) RP DEC RP DEC BX 0 [RP] MOV BX POP NEXT END-CODE CODE R@ (S -- n ) BX PUSH 0 [RP] BX MOV NEXT END-CODE \ 16 bit Stack Operations 23jan86gebCODE DROP (S n1 -- ) BX POP NEXT END-CODE CODE DUP (S n1 -- n1 n1 ) BX PUSH NEXT END-CODE CODE SWAP (S n1 n2 -- n2 n1 ) SP DI MOV 0 [DI] BX XCHG NEXT END-CODE CODE OVER (S n1 n2 -- n1 n2 n1 ) SP DI MOV BX PUSH 0 [DI] BX MOV NEXT END-CODE CODE PICK (S nm ... n2 n1 k -- nm ... n2 n1 nk ) BX SHL SP BX ADD 0 [BX] BX MOV NEXT END-CODE : ROLL (S n1 n2 .. nk n -- wierd ) >R R@ PICK SP@ DUP 2+ R> 1+ 2* CMOVE> DROP ; \ 16 bit Stack Operations 22JAN86GEBCODE TUCK (S n1 n2 -- n2 n1 n2 ) AX POP BX PUSH AX PUSH NEXT END-CODE CODE NIP (S n1 n2 -- n2 ) AX POP NEXT END-CODE CODE ROT (S n1 n2 n3 --- n2 n3 n1 ) DX POP AX POP DX PUSH BX PUSH AX BX MOV NEXT END-CODE CODE -ROT (S n1 n2 n3 --- n3 n1 n2 ) AX POP DX POP BX PUSH DX PUSH AX BX MOV NEXT END-CODE CODE FLIP (S n1 -- n2 ) BH BL XCHG NEXT END-CODE CODE ?DUP (S n -- [n] n ) BX BX OR 0<> IF BX PUSH THEN NEXT END-CODE \ 16 bit Logical Operations 22JAN86GEBCODE AND (S n1 n2 -- n3 ) AX POP AX BX AND NEXT END-CODE CODE OR (S n1 n2 -- n3 ) AX POP AX BX OR NEXT END-CODE CODE XOR (S n1 n2 -- n3 ) AX POP AX BX XOR NEXT END-CODE CODE NOT (S n -- n' ) BX NOT NEXT END-CODE -1 CONSTANT TRUE 0 CONSTANT FALSE \ Logical Operations 27JAN86GEBCODE CSET (S b addr -- ) AX POP AL 0 [BX] OR BX POP NEXT END-CODE CODE LCSET ( b addr seg -- ) ES DX MOV BX ES MOV BX POP AX POP AL ES: 0 [BX] OR BX POP DX ES MOV NEXT END-CODE CODE CRESET (S b addr -- ) AX POP AX NOT AL 0 [BX] AND BX POP NEXT END-CODE CODE CTOGGLE (S b addr -- ) AX POP AL 0 [BX] XOR BX POP NEXT END-CODE CODE ON (S addr -- ) TRUE # 0 [BX] MOV BX POP NEXT END-CODE CODE OFF (S addr -- ) FALSE # 0 [BX] MOV BX POP NEXT END-CODE \ 16 bit Arithmetic Operations 22JAN86GEBCODE + (S n1 n2 -- sum ) AX POP AX BX ADD NEXT END-CODE CODE NEGATE (S n -- n' ) BX NEG NEXT END-CODE CODE - (S n1 n2 -- n1-n2 ) AX POP AX BX SUB BX NEG NEXT END-CODE CODE ABS (S n -- n ) BX BX OR 0< IF BX NEG THEN NEXT END-CODE CODE 0 (S -- 0 ) BX PUSH BX BX SUB NEXT END-CODE 1 CONSTANT 1 2 CONSTANT 2 3 CONSTANT 3 \ 16 bit Arithmetic Operations 09MAY86GEBCODE 2* (S n -- 2*n ) BX SHL NEXT END-CODE CODE 2/ (S n -- n/2 ) BX SAR NEXT END-CODE CODE U2/ (S u -- u/2 ) BX SHR NEXT END-CODE CODE 8* (S n -- 8*n ) BX SHL BX SHL BX SHL NEXT END-CODE CODE 1+ BX INC NEXT END-CODE CODE 2+ 2 # BX ADD NEXT END-CODE CODE 1- BX DEC NEXT END-CODE CODE 2- 2 # BX SUB NEXT END-CODE \ 16 bit Arithmetic Operations Unsigned Multiply 09JUL86GEBCODE UM* (S n1 n2 -- d ) AX POP BX MUL AX PUSH DX BX MOV NEXT END-CODE CODE * (S n1 n2 -- n1*n2 ) AX POP BX MUL AX BX MOV NEXT END-CODE \ 16 bit Arithmetic Operations Unsigned Divide 22JAN86GEBCODE UM/MOD (S d1 n1 -- Remainder Quotient ) DX POP AX POP BX DX CMP U>= ( divide by zero? ) IF -1 # BX MOV BX PUSH NEXT THEN BX DIV DX PUSH AX BX MOV NEXT END-CODE \ 16 bit Comparison Operations 22JAN86GEBASSEMBLER LABEL YES TRUE # BX MOV NEXT CODE 0= (S n -- f ) BX BX OR YES JE FALSE # BX MOV NEXT END-CODE CODE 0< (S n -- f ) BX BX OR YES JS FALSE # BX MOV NEXT END-CODE CODE 0> (S n -- f ) BX BX OR YES JG FALSE # BX MOV NEXT END-CODE CODE 0<> (S n -- f ) BX BX OR YES JNE FALSE # BX MOV NEXT END-CODE CODE = (S n1 n2 -- f ) AX POP AX BX CMP YES JE FALSE # BX MOV NEXT END-CODE CODE <> (S n1 n2 -- f ) AX POP AX BX CMP YES JNE FALSE # BX MOV NEXT END-CODE : ?NEGATE (S n1 n2 -- n3 ) 0< IF NEGATE THEN ; \ 16 bit Comparison Operations 22JAN86GEBASSEMBLER LABEL YES TRUE # BX MOV NEXT CODE U< (S n1 n2 -- f ) AX POP BX AX CMP YES JB FALSE # BX MOV NEXT END-CODE CODE U> (S n1 n2 -- f ) AX POP AX BX CMP YES JB FALSE # BX MOV NEXT END-CODE CODE < (S n1 n2 -- f ) AX POP BX AX CMP YES JL FALSE # BX MOV NEXT END-CODE CODE > (S n1 n2 -- f ) AX POP BX AX CMP YES JG FALSE # BX MOV NEXT END-CODE \ 16 bit Comparison Operations 7 /31/89( MIN AND MAX USED 0< INSTEAD OF < !!! ) CODE MIN (S n1 n2 -- n3 ) DX POP BX DX CMP < IF DX BX XCHG THEN NEXT END-CODE CODE MAX (S n1 n2 -- n3 ) DX POP DX BX CMP < IF DX BX XCHG THEN NEXT END-CODE CODE BETWEEN (S n1 min max -- f ) DX POP CX POP AX AX SUB CX BX CMP 0< IF BX BX XOR NEXT THEN DX CX CMP 0< IF BX BX XOR NEXT THEN -1 # BX MOV NEXT END-CODE : WITHIN (S n1 min max -- f ) 1- BETWEEN ; \ 32 bit Memory and Stack Operations 22JAN86GEBCODE 2DROP (S d -- ) BX POP BX POP NEXT END-CODE CODE 2DUP (S d -- d d ) AX POP AX PUSH BX PUSH AX PUSH NEXT END-CODE CODE 2SWAP (S d1 d2 -- d2 d1 ) CX POP AX POP DX POP CX PUSH BX PUSH DX PUSH AX BX MOV NEXT END-CODE CODE 2OVER (S d1 d2 -- d1 d2 d1 ) BX PUSH RP SP XCHG 6 [RP] AX MOV 4 [RP] BX MOV RP SP XCHG AX PUSH NEXT END-CODE CODE 3DUP (S a b c -- a b c a b c ) AX POP DX POP DX PUSH AX PUSH BX PUSH DX PUSH AX PUSH NEXT END-CODE : 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 1JUL87GEBCODE D+ (S d1 d2 -- dsum ) CX POP AX POP DX POP CX DX ADD AX BX ADC DX PUSH NEXT END-CODE CODE D- (S d1 d2 -- dsum ) CX POP AX POP DX POP CX DX SUB BX AX SBB AX BX MOV DX PUSH NEXT END-CODE CODE DNEGATE (S d# -- d#' ) ( 11SEP86GEB ) AX AX SUB SP DI MOV 0 [DI] NEG BX AX SBB AX BX MOV NEXT END-CODE CODE S>D (S n -- d ) BX AX MOV CWD AX PUSH DX BX MOV NEXT END-CODE CODE DABS (S d# -- d# ) BX BX OR ' DNEGATE JS NEXT END-CODE \ 32 bit Arithmetic Operations 27JAN86GEBCODE D2* (S d -- d*2 ) DX POP DX SHL BX RCL DX PUSH NEXT END-CODE CODE D2/ (S d -- d/2 ) DX POP BX SAR DX RCR DX PUSH NEXT END-CODE : ?DNEGATE (S d1 n -- d2 ) 0< IF DNEGATE THEN ; \ 32 bit Comparison Operations 09OCT86GEB: 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 ) D- 0< NIP ; : 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 04NOV86GEBCODE *D AX POP BX IMUL AX PUSH DX BX MOV NEXT END-CODE CODE M/MOD DX POP AX POP BX CX MOV BX IDIV CX BX MOV DX CX XOR 0< IF BX DX ADD AX DEC THEN AX BX MOV DX PUSH NEXT END-CODE : MU/MOD (S d# n1 -- rem d#quot ) >R 0 R@ UM/MOD R> SWAP >R UM/MOD R> ; \ 16 bit multiply and divide 7 /13/88: /MOD (S n1 n2 -- rem quot ) >R S>D R> M/MOD ; CODE / (S n1 n2 -- quot ) AX POP CWD BX IDIV DX DX OR 0< IF AX DEC THEN AX BX MOV NEXT END-CODE : MOD (S n1 n2 -- rem ) /MOD DROP ; : */MOD (S n1 n2 n3 -- rem quot ) >R *D R> M/MOD ; CODE */ (S n1 n2 n3 -- n1*n2/n3 ) AX POP CX POP CX IMUL BX IDIV ( DX DX OR 0< ????? ) ( IF AX DEC THEN ) AX BX MOV NEXT END-CODE CODE >> ( n1 n2 -- n1*n2**-n2) BX CX MOV AX POP AX CL SHR AX BX MOV NEXT END-CODE CODE << ( n1 n2 -- n1*n2**n2) BX CX MOV AX POP AX CL SHL AX BX MOV NEXT END-CODE : SHIFT ( n1 n2 -- n1*n2**+-n2) DUP 0< IF NEGATE >> ELSE << THEN ; \ Task Dependant USER Variables 5 /15/88USER 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 #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 IN-FILE ( POINTS TO FCB OF CURRENTLY OPEN FILE ) VARIABLE PRINTING ( TO ALLOW PRINT SPOOLING ) VARIABLE DP-BODY ( MUST BE IN USER VARS ) \ System VARIABLEs 27JAN86GEBDEFER TYPE META 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 ) 8 CONSTANT #VOCS ( THE NUMBER OF VOCABULARIES TO SEARCH ) VARIABLE CONTEXT ( VOCABULARY SEARCHED FIRST ) HERE THERE #VOCS 2* DUP ALLOT ERASE-T \ System Variables 5 /15/88VARIABLE '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 ) VARIABLE DP-HEAD 0 CONSTANT HEAD-SEG DEFER DP DEFER DP-SEG \ Devices Strings 22JAN86GEB 32 CONSTANT BL 8 CONSTANT BS 7 CONSTANT BELL : ERASE (S addr len -- ) 0 FILL ; : BLANK (S addr len -- ) BL FILL ; CODE COUNT (S addr -- addr+1 len ) AX AX SUB 0 [BX] AL MOV BX INC BX PUSH AX BX MOV NEXT END-CODE CODE LENGTH (S addr -- addr+2 len ) 0 [BX] AX MOV BX INC BX INC BX PUSH AX BX MOV NEXT END-CODE : MOVE ( from to len -- ) -ROT 2DUP U< IF ROT CMOVE> ELSE ROT CMOVE THEN ; : PAD ( -- addr ) 'WORD 80 + ; VARIABLE CAPS \ Devices Strings 28jan86gebASSEMBLER LABEL >UPPER ASCII a # AL CMP 0>= IF ASCII z 1+ # AL CMP 0< IF 32 # AL SUB THEN THEN RET CODE UPC (S char -- char' ) BX AX MOV >UPPER #) CALL AX BX MOV NEXT END-CODE CODE UPPER (S addr len -- ) CX POP BX CX XCHG BEGIN CX CX OR 0<> WHILE 0 [BX] AL MOV >UPPER #) CALL AL 0 [BX] MOV BX INC CX DEC REPEAT BX POP NEXT END-CODE : HERE (S -- addr ) DP @ ; : LHERE ( -- addr seg ) DP @ DP-SEG ; : -TRAILING (S addr len -- addr len' ) DUP 0 DO 2DUP + 1- C@ BL <> ?LEAVE 1- LOOP ; \ Devices Strings 27JAN86GEBLABEL NOMORE DX SI MOV CX BX MOV NEXT CODE COMP (S addr1 addr2 len -- -1 | 0 | 1 ) CLD SI DX MOV BX CX MOV DI POP SI POP NOMORE JCXZ DS AX MOV AX ES MOV REPZ BYTE CMPS NOMORE JE LABEL MISMATCH 0< IF -1 # BX MOV ELSE 1 # BX MOV THEN DX SI MOV NEXT END-CODE CODE CAPS-COMP (S addr1 addr2 len -- -1 | 0 | 1 ) SI DX MOV BX CX MOV DI POP SI POP BEGIN NOMORE JCXZ 0 [SI] AL MOV >UPPER #) CALL SI INC AL AH MOV 0 [DI] AL MOV >UPPER #) CALL DI INC AL AH CMP MISMATCH JNE CX DEC AGAIN END-CODE : COMPARE (S addr1 addr2 len -- -1 | 0 | 1 ) CAPS @ IF CAPS-COMP ELSE COMP THEN ; \ Devices Terminal Input and Outpu 5 /15/88DEFER KEY? DEFER KEY DEFER CR : SPACE (S -- ) BL EMIT ; : SPACES (S n -- ) 0 MAX 0 ?DO SPACE LOOP ; : BACKSPACES (S n -- ) 0 ?DO BS EMIT LOOP ; \ Devices System Dependent Control Characters 5 /15/88VARIABLE LAST-KEY : BS-IN (S n c -- 0 | n-1 ) DUP IF 1- BS ELSE BELL THEN EMIT ; : (DEL-IN) (S n c -- 0 | n-1 ) DUP IF 1- BS EMIT SPACE BS ELSE BELL THEN EMIT ; : BACK-UP (S n c -- 0 ) DUP BACKSPACES DUP SPACES BACKSPACES 0 ; : RES-IN (S c -- ) FORTH TRUE ABORT" Reset" ; : P-IN (S c -- ) PRINTING @ NOT PRINTING ! ; \ Devices Terminal Input 27JAN86GEB: CR-IN (S m a n -- m a m ) SPAN ! OVER BL EMIT ; : (CHAR) (S a n char -- a n+1 ) LAST-KEY @ 3DUP EMIT + C! 1+ ; DEFER CHAR DEFER DEL-IN VARIABLE CC VARIABLE CC2 CREATE CC-FORTH ] CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR DEL-IN CHAR CHAR CHAR CHAR CR-IN CHAR CHAR P-IN CHAR RES-IN CHAR CHAR BACK-UP CHAR CHAR BACK-UP CHAR CHAR CHAR CHAR CHAR CHAR CHAR [ \ MORE KEY CASE ] CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR [ \ MORE KEY CASE ] CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR [ \ MORE KEY CASE ] CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR CHAR [ \ ALL 256 CHARACTERS : HOT.KEY ( n -- addr ) DUP 127 > SWAP 2* 255 AND SWAP IF CC2 ELSE CC THEN @ + ; \ Devices Terminal Input 5 /15/88: EXPECT ( adr len -- ) DUP SPAN ! SWAP 0 ( len adr 0 ) BEGIN 2 PICK OVER - ( len adr #so-far #left ) WHILE KEY DUP LAST-KEY ! 2* DUP 254 > IF 255 AND CC2 ELSE CC THEN @ + PERFORM REPEAT 2DROP DROP ; : TIB ( -- adr ) 'TIB @ ; : QUERY ( -- ) SPAN @ >R TIB 80 EXPECT SPAN @ #TIB ! BLK OFF >IN OFF R> SPAN ! ; \ Devices BLOCK I/O 5 /15/88 4 CONSTANT #BUFFERS 1024 CONSTANT B/BUF VARIABLE DISK-ERROR -2 CONSTANT LIMIT #BUFFERS 1+ 8 * 2+ CONSTANT >SIZE LIMIT B/BUF #BUFFERS * - CONSTANT FIRST FIRST >SIZE - CONSTANT INIT-R0 : >BUFFERS ( -- adr ) FIRST >SIZE - ; : >END ( -- adr ) FIRST 2- ; : BUFFER# ( n -- adr ) 8* >BUFFERS + ; : >UPDATE ( -- adr ) 1 BUFFER# 6 + ; \ Devices BLOCK I/O 5 /15/88DEFER READ-BLOCK ( buffer-header -- ) DEFER WRITE-BLOCK ( buffer-header -- ) VOCABULARY DOS \ INCLUDE IO.SCR FROM IO.SCR OK 1 VIEW#-T ! FORTH DEFINITIONS \ Devices BLOCK I/O 5 /15/88FORTH DEFINITIONS : LATEST? ( n file -- file n | a f ) DISK-ERROR OFF SWAP OFFSET @ + 2DUP 1 BUFFER# 2@ D= IF 2DROP 1 BUFFER# 4 + @ FALSE R> DROP THEN ; : ABSENT? ( n file -- a f ) LATEST? FALSE #BUFFERS 1+ 2 DO DROP 2DUP I BUFFER# 2@ D= IF 2DROP I LEAVE ELSE FALSE THEN LOOP ?DUP IF BUFFER# DUP >BUFFERS 8 CMOVE >R >BUFFERS DUP 8 + OVER R> SWAP - CMOVE> 1 BUFFER# 4 + @ FALSE ELSE >BUFFERS 2! TRUE THEN ; \ Devices BLOCK I/O 5 /15/88: UPDATE ( -- ) >UPDATE ON ; : DISCARD ( -- ) 1 >UPDATE ! ; : MISSING ( -- ) >END 2- @ 0< IF >END 2- OFF >END 8 - WRITE-BLOCK THEN >END 4 - @ >BUFFERS 4 + ! ( buffer ) 1 >BUFFERS 6 + ! >BUFFERS DUP 8 + #BUFFERS 8* CMOVE> ; : (BUFFER) ( n file -- a ) PAUSE ABSENT? IF MISSING 1 BUFFER# 4 + @ THEN ; : BUFFER ( n -- a ) FILE @ (BUFFER) ; : (BLOCK) ( n file -- a ) (BUFFER) >UPDATE @ 0> IF 1 BUFFER# DUP READ-BLOCK 6 + OFF THEN ; : BLOCK ( n -- a ) FILE @ (BLOCK) ; : IN-BLOCK ( n -- a ) IN-FILE @ (BLOCK) ; \ Devices BLOCK I/O 5 /15/88: EMPTY-BUFFERS ( -- ) FIRST LIMIT OVER - ERASE >BUFFERS #BUFFERS 1+ 8* ERASE FIRST 1 BUFFER# #BUFFERS 0 DO DUP ON 4 + 2DUP ! SWAP B/BUF + SWAP 4 + LOOP 2DROP ; : SAVE-BUFFERS ( -- ) 1 BUFFER# #BUFFERS 0 DO DUP @ 1+ IF DUP 6 + @ 0< IF DUP WRITE-BLOCK DUP 6 + OFF THEN 8 + THEN LOOP DROP ; : FLUSH ( -- ) SAVE-BUFFERS EMPTY-BUFFERS ; \ Devices BLOCK I/O 6 /21/88: ?ENOUGH ( nnn - ) DEPTH 1- > ABORT" Not enough parameters" ; : (LOAD) ( n -- ) 1 ?ENOUGH FILE @ >R BLK @ >R >IN @ >R >IN OFF BLK ! IN-FILE @ FILE ! INTERPRET R> >IN ! R> BLK ! R> !FILES ; DEFER LOAD \ Interactive Layer Number Input 20feb86GEBASSEMBLER LABEL FAIL BX BX SUB NEXT CODE DIGIT (S char base -- n f ) AX POP AX PUSH ASCII 0 # AL SUB FAIL JB 9 # AL CMP > IF 17 # AL CMP FAIL JB 7 # AL SUB THEN BL AL CMP FAIL JAE DX POP AX PUSH TRUE # BX MOV NEXT END-CODE : 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> ; : HEX 16 BASE ! ; \ Interactive Layer Number Input 20feb86geb: (NUMBER?) (S adr -- d flag ) BASE @ >R 36 ( $) OVER 1+ C@ = IF HEX 1+ THEN 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 = R> BASE ! ; : 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 20feb86geb: 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 ; : DECIMAL (S -- ) 10 BASE ! ; : OCTAL (S -- ) 8 BASE ! ; : BINARY 2 BASE ! ; \ Interactive Layer Number Output 5 /15/88: (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 27JAN86GEBLABEL DONE ASSEMBLER CX BX MOV NEXT CODE SKIP (S addr len char -- addr' len' ) BX AX MOV CX POP DONE JCXZ DI POP DS DX MOV DX ES MOV REPZ BYTE SCAS 0<> IF CX INC DI DEC THEN DI PUSH CX BX MOV NEXT END-CODE CODE SCAN (S addr len char -- addr' len' ) BX AX MOV CX POP DONE JCXZ DI POP DS DX MOV DX ES MOV CX BX MOV REP BYTE SCAS 0= IF CX INC DI DEC THEN DI PUSH CX BX MOV NEXT END-CODE \ Interactive Layer Parsing 04NOV86GEBCODE /STRING (S addr len n -- addr' len' ) AX POP DX POP AX BX CMP U< IF BX DX ADD BX AX SUB AX BX MOV ELSE AX DX ADD BX BX XOR THEN DX PUSH NEXT END-CODE : PLACE (S str-addr len to -- ) 3DUP 1+ SWAP MOVE C! DROP ; : (SOURCE) (S -- addr len ) BLK @ ?DUP IF BLOCK B/BUF ELSE TIB #TIB @ THEN ; DEFER SOURCE : PARSE-WORD (S char -- addr len ) >R SOURCE TUCK >IN @ /STRING R@ SKIP OVER SWAP R> SCAN >R OVER - ROT R> DUP 0<> + - >IN ! ; : PARSE (S char -- addr len ) >R SOURCE >IN @ /STRING OVER SWAP R> SCAN >R OVER - DUP R> 0<> - >IN +! ; \ Interactive Layer Parsing 19Feb86geb: 'WORD (S -- adr ) DP-BODY @ ; : WORD (S char -- addr ) PARSE-WORD 'WORD PLACE 'WORD BL OVER COUNT + C! ( Stick Blank at end ) ; : >TYPE (S adr len -- ) TUCK PAD SWAP CMOVE PAD SWAP TYPE ; : .( (S -- ) ASCII ) PARSE >TYPE ; IMMEDIATE : ( (S -- ) ASCII ) PARSE 2DROP ; IMMEDIATE : \S (S -- ) END? ON ; IMMEDIATE \ Interactive Layer Dictionary 1 /19/89: DONE? (S n -- f ) STATE @ <> END? @ OR END? OFF ; : FORTH-83 (S -- ) FORTH DEFINITIONS CAPS OFF ; 250 CONSTANT VERSION ( release,version,user version ) : .VERSION VERSION 0 <# # ASCII . HOLD # ASCII . HOLD # #> TYPE SPACE ; : C,HEAD ( c -- ) DP-HEAD @ HEAD-SEG LC! 1 DP-HEAD +! ; : ,HEAD ( n -- ) DP-HEAD @ HEAD-SEG L! 2 DP-HEAD +! ; : ,BODY ( n -- ) DP-BODY @ CSEG L! 2 DP-BODY +! ; : C,BODY ( n -- ) DP-BODY @ CSEG LC! 2 DP-BODY +! ; #TTHREADS CONSTANT #THREADS \ Interactive Layer Dictionary 2 /23/88: N>LINK ( nfa -- lfa ) 2- ; : L>NAME ( lfa -- nfa ) 2+ ; : BODY> ( pfa -- cfa ) 3 - ; : 'NAME> ( nfa --addr:seg) 1+ DUP HEAD-SEG LC@ + 1+ HEAD-SEG ; : NAME> ( nfa -- cfa ) 'NAME> L@ ; : LINK> ( lfa -- cfa ) L>NAME NAME> ; : >BODY ( cfa -- pfa ) 3 + ; : >NAME ( cfa -- nfa ) 2- @ ; : >LINK ( cfa -- lfa ) >NAME N>LINK ; : >VIEW ( cfa -- vfa ) >LINK 2- ; : VIEW> ( vfa -- cfa ) 2+ LINK> ; : !>HEAD ( n addr -- ) HEAD-SEG L! ; : @<HEAD ( addr -- n ) HEAD-SEG L@ ; : ,NAME ( addr len -- ) DUP C,HEAD ( put name in head ) 0 ?DO COUNT C,HEAD LOOP DROP ; \ Interactive Layer Dictionary 2 /24/88CODE HASH (S str-addr voc-ptr -- thread ) DI POP 1 [DI] AL MOV ' #THREADS >BODY #) DX MOV DX DEC DX AX AND AX SHL AX BX ADD NEXT END-CODE CODE (FIND) (S here alf -- cfa flag | here false ) CLD BX BX OR 0= IF NEXT THEN AX POP SI PUSH AX SI MOV ' HEAD-SEG >BODY #) ES MOV CS CX MOV CX DS MOV 0 [SI] DX MOV AX INC BEGIN ES: 3 [BX] DX CMP 0= IF AX SI MOV 4 [BX] DI LEA DL CL MOV ch ch xor REPZ BYTE CMPS 0= IF SI POP ES: 0 [DI] PUSH ES: 2 [BX] AL MOV 64 # AL AND 0<> IF 1 # BX MOV ELSE -1 # BX MOV THEN CS DX MOV DX ES MOV NEXT THEN THEN ES: 0 [BX] BX MOV BX BX OR 0= UNTIL SI POP AX DEC AX PUSH CS DX MOV DX ES MOV NEXT END-CODE \ Interactive Layer Dictionary 2 /23/88: FIND (S addr -- cfa flag | addr false ) DUP C@ IF 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 ELSE DROP END? ON ['] NOOP 1 THEN ; : ?UPPERCASE (S adr -- adr ) CAPS @ IF DUP COUNT UPPER THEN ; : DEFINED (S -- here 0 | cfa [ -1 | 1 ] ) BL WORD ?UPPERCASE FIND ; \ Interactive Layer Interpreter 2 /23/88: ?STACK ( -- ) ( System dependant ) SP@ SP0 @ SWAP U< ABORT" Stack Underflow" SP@ PAD U< ABORT" Stack Overflow" ; DEFER STATUS ( -- ) : INTERPRET ( -- ) BEGIN BEGIN ?STACK STATE OFF DEFINED WHILE EXECUTE END? @ IF END? OFF EXIT THEN REPEAT DUP C@ WHILE NUMBER DOUBLE? NOT IF DROP THEN REPEAT DROP ; : [ ( -- ) INTERPRET ; IMMEDIATE : ] ( -- ) R> DROP ; \ Extensible Layer Compiler 5 /15/88: ALLOT ( n -- ) DP +! ; : ALLOT0 ( n -- ) HERE SWAP DUP ALLOT ERASE ; : , ( n -- ) LHERE L! 2 ALLOT ; : C, ( char -- ) LHERE LC! 1 ALLOT ; : ALIGN HERE 1 AND IF 0 C, THEN ; : EVEN DUP 1 AND + ; : COMPILE ( -- ) R> DUP 2+ >R @ , ; : IMMEDIATE ( -- ) 64 ( Precedence ) LAST @ HEAD-SEG LCSET ; : LITERAL ( n -- ) COMPILE (LIT) , ; IMMEDIATE : DLITERAL ( d# -- ) SWAP [COMPILE] LITERAL [COMPILE] LITERAL ; IMMEDIATE : ASCII ( -- n ) BL WORD 1+ C@ STATE @ IF COMPILE (ASCII) , THEN ; IMMEDIATE : CONTROL ( -- n ) BL WORD 1+ C@ 31 AND STATE @ IF COMPILE (ASCII) , THEN ; IMMEDIATE \ Extensible Layer Compiler 5 /15/88: CRASH ( -- ) TRUE ABORT" Uninitialized execution vector." ; : ?MISSING ( f -- ) IF 'WORD COUNT TYPE TRUE ABORT" ?" THEN ; : ' ( -- cfa ) DEFINED 0= ?MISSING ; : ['] ( -- ) ' COMPILE (') , ; IMMEDIATE : [COMPILE] ( -- ) ' , ; IMMEDIATE : (") ( -- adr len ) R> COUNT 2DUP + EVEN >R ; : (.") ( -- ) R> COUNT 2DUP + EVEN >R TYPE ; : (,") ( -- ) ASCII " PARSE TUCK 'WORD PLACE 1+ ALLOT ; : ," ( -- ) (,") ALIGN ; : ." ( -- ) COMPILE (.") ," ; IMMEDIATE : " ( -- ) COMPILE (") ," ; IMMEDIATE \ Interactive Layer Dictionary 5 /15/88VARIABLE FENCE : TRIM ( view-adr voc-adr -- ) #THREADS 0 DO 2DUP @ BEGIN 2DUP U> NOT WHILE HEAD-SEG L@ REPEAT NIP OVER ! 2+ LOOP 2DROP ; : (FORGET) ( vfaddr -- ) DUP VIEW> FENCE @ U< ABORT" Below fence" DUP VIEW> VOC-LINK @ BEGIN 2DUP U< WHILE @ REPEAT DUP VOC-LINK ! NIP BEGIN ?DUP WHILE 2DUP #THREADS 2* - TRIM @ REPEAT DUP DP-HEAD ! VIEW> 2- DP-BODY ! ; : FORGET ( -- ) BL WORD ?UPPERCASE DUP CURRENT @ HASH @ (FIND) 0= ?MISSING >VIEW (FORGET) ; ( 10/25/87 BUG: does not set LAST, so if followed by a :: ) ( definition, then a bogus thing will be restored ) \ Extensible Layer Compiler 5 /15/88DEFER WHERE DEFER ?ERROR : (?ERROR) ( 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") ( f -- ) R@ COUNT ROT ?ERROR R> COUNT + EVEN >R ; : ABORT" ( -- ) COMPILE (ABORT") ," ; IMMEDIATE : ABORT ( -- ) TRUE ABORT" " ; \ Extensible Layer Structures 5 /15/88: ?PAIRS ( n1 n2 -- ) <> ABORT" Conditionals Wrong" ; : ?CONDITION ( n -- ) NOT ABORT" Conditionals Wrong" ; : >MARK ( -- adr ) HERE 0 , ; : >RESOLVE ( adr -- ) HERE SWAP ! ; : <MARK ( -- adr ) HERE ; : <RESOLVE ( adr -- ) , ; : IF COMPILE ?BRANCH >MARK 1000 ; IMMEDIATE : THEN 1000 ?PAIRS >RESOLVE ; IMMEDIATE : ELSE COMPILE BRANCH >MARK 1000 2SWAP [COMPILE] THEN ; IMMEDIATE \ Extensible Layer Structures 5 /15/88: BEGIN <MARK 2000 ; IMMEDIATE : UNTIL COMPILE ?BRANCH 2000 ?PAIRS <RESOLVE ; IMMEDIATE : AGAIN COMPILE BRANCH 2000 ?PAIRS <RESOLVE ; IMMEDIATE : WHILE COMPILE ?BRANCH >MARK 2000 ; IMMEDIATE : REPEAT 2SWAP [COMPILE] AGAIN 2000 ?PAIRS >RESOLVE ; IMMEDIATE : DO COMPILE (DO) >MARK 3000 ; IMMEDIATE : ?DO COMPILE (?DO) >MARK 3000 ; IMMEDIATE : LOOP COMPILE (LOOP) 3000 ?PAIRS DUP 2+ <RESOLVE >RESOLVE ; IMMEDIATE : +LOOP COMPILE (+LOOP) 3000 ?PAIRS DUP 2+ <RESOLVE >RESOLVE ; IMMEDIATE : LEAVE COMPILE (LEAVE) ; IMMEDIATE : ?LEAVE COMPILE (?LEAVE) ; IMMEDIATE \ Extensible Layer Defining Words 20FEB86GEB: ,JSR (S -- ) 232 C, ; : ,VIEW (S -- ) BLK @ DUP IF VIEW# @ 256 * + THEN ,HEAD ; : "CREATE (S str -- ) COUNT PAD PLACE WARNING @ IF PAD FIND IF PAD COUNT TYPE ." isn't unique " THEN DROP THEN ,VIEW DP-HEAD @ >R PAD CURRENT @ HASH DUP @ ,HEAD R@ SWAP ! DP-HEAD @ ,BODY ( backlink ) R> 2+ LAST ! 128 C,HEAD PAD 2- COUNT ,NAME DP-BODY @ ,HEAD ,JSR [ [FORTH] ASSEMBLER DOCREATE META ] LITERAL HERE 2+ - ,BODY ; : MISALIGN ( -- ) HERE 1 AND 0= IF 0 C, THEN ; : CREATE (S -- ) BL WORD ?UPPERCASE "CREATE ; : !CSP ( -- ) SP@ CSP ! ; : ?CSP ( -- ) SP@ CSP @ <> ABORT" Stack Changed" ; \ Extensible Layer Defining Words 3 /16/89: HIDE ( --) LAST @ DUP N>LINK HEAD-SEG L@ SWAP 1+ HEAD-SEG L@ SP@ CURRENT @ HASH NIP ! ; : REVEAL (S -- ) LAST @ DUP N>LINK SWAP 1+ HEAD-SEG L@ SP@ CURRENT @ HASH NIP ! ; : !LAST (S addr -- ) LAST @ NAME> 1+ DUP >R 2+ - R> ! ; : (;USES) (S -- ) R> @ !LAST ; VOCABULARY ASSEMBLER : ;USES (S -- ) ?CSP COMPILE (;USES) REVEAL ASSEMBLER R> DROP ; IMMEDIATE : (;CODE) (S -- ) R> !LAST ; : ;CODE (S -- ) ?CSP COMPILE (;CODE) CONTEXT @ AVOC ! REVEAL ASSEMBLER R> DROP ; IMMEDIATE : DOES> (S -- ) COMPILE (;CODE) ,JSR [ [FORTH] ASSEMBLER DODOES META ] LITERAL HERE 2+ - , ; IMMEDIATE \ Extensible Layer Defining Words 5 /15/88: COMPILER ( -- ) BEGIN BEGIN ?STACK DEFINED DUP 0< IF DROP , ELSE 0= IF NUMBER DOUBLE? IF [COMPILE] DLITERAL ELSE DROP [COMPILE] LITERAL THEN ELSE STATE ON EXECUTE STATE OFF THEN THEN END? @ UNTIL END? OFF BLK @ ABORT" Unfinished compilation." CR QUERY AGAIN ; \ Extensible Layer Defining Words 15MAY86GEB: : ( -- ) MISALIGN CREATE HIDE !CSP CURRENT @ CONTEXT ! COMPILER ;USES NEST , : ; ( -- ) ?CSP COMPILE UNNEST REVEAL R> DROP ; IMMEDIATE : RECURSIVE (S -- ) REVEAL ; IMMEDIATE : CONSTANT ( n -- ) CREATE , ;USES DOCONSTANT , : VARIABLE ( -- ) CREATE 0 , ;USES DOCREATE , : DEFER CREATE ['] CRASH , ;USES DODEFER , VARIABLE #USER VOCABULARY USER : VOCABULARY (S -- ) CREATE #THREADS 0 DO 0 , LOOP HERE VOC-LINK @ , VOC-LINK ! DOES> CONTEXT ! ; CFA-RESOLVES <VOCABULARY> : DEFINITIONS ( -- ) CONTEXT @ CURRENT ! ; \ Extensible Layer Defining Words 22JAN86GEB: 2CONSTANT CREATE , , (S d# -- ) DOES> 2@ ; (S -- d# ) DROP : 2VARIABLE 0 0 2CONSTANT (S -- ) DOES> ; (S -- addr ) DROP VARIABLE AVOC : CODE (S -- ) CREATE HIDE -3 ALLOT CONTEXT @ AVOC ! ASSEMBLER ; ASSEMBLER DEFINITIONS : END-CODE AVOC @ CONTEXT ! REVEAL ; FORTH DEFINITIONS META IN-META \ Extensible Layer Defining Words 15MAY86GEB USER DEFINITIONS : ALLOT (S n -- ) #USER +! ; ' CREATE ( avoid recursion: leave address for , in CREATE ) : CREATE (S -- ) [ , ] #USER @ , ;USES DOUSER-VARIABLE , : VARIABLE (S -- ) CREATE 2 ALLOT ; : DEFER (S -- ) VARIABLE ;USES DOUSER-DEFER , FORTH DEFINITIONS META IN-META \ Extensible Layer ReDefining Words 28JAN86GEB: >IS (S cfa -- data-address ) DUP 1+ DUP @ + 2+ DUP [ [ASSEMBLER] DOUSER-VARIABLE META ] LITERAL = SWAP DUP [ [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 6 /21/88DEFER PROMPT : (OK) ." ok" ; : (QUIT) (S -- ) SP0 @ 2+ 'TIB ! BLK OFF ( [COMPILE] [ ) BEGIN RP0 @ RP! STATUS QUERY INTERPRET PROMPT AGAIN ; DEFER QUIT DEFER BOOT HEX DEFER WARM : (WARM) ( -- ) CR TRUE ABORT" Warm Start" ; : COLD ( -- ) BOOT SP0 @ SP! QUIT ; : SYS-COLD ( -- ) CSEG 800 + ['] HEAD-SEG >BODY ! COLD ; DECIMAL \ Initialization High Level 19FEB86GEB1 CONSTANT INITIAL : OK (S -- ) INITIAL LOAD ; : START (S -- ) EMPTY-BUFFERS DEFAULT ; DEFER BYE : (BYE) ( -- ) 0 0 BDOS ; \ Initialization Low Level 26JAN86GEB[FORTH] ASSEMBLER HERE ORIGIN 6 + - ORIGIN 4 + !-T ( WARM ENTRY ) ASSEMBLER ' WARM >BODY/T # IP MOV NEXT HERE ORIGIN 3 + - ORIGIN 1+ !-T ( COLD ENTRY ) ASSEMBLER CS AX MOV AX DS MOV AX SS MOV AX ES MOV 6 #) AX MOV 0 # AL MOV AX ' LIMIT >BODY/T #) MOV #BUFFERS B/BUF * # AX SUB AX ' FIRST >BODY/T #) MOV >SIZE # AX SUB AX RP MOV RP0 # BX MOV UP #) BX ADD RP 0 [BX] MOV 510 # AX SUB AX 'TIB #) MOV SP0 # BX MOV UP #) BX ADD AX 0 [BX] MOV AX SP MOV ' SYS-COLD >BODY/T # IP MOV NEXT IN-META \ Initialize User Variables 27JAN86GEBHERE UP !-T ( SET UP USER AREA ) 0 , ( TOS ) 0 , ( ENTRY ) 0 , ( LINK ) INIT-R0 512 - , ( SP0 ) INIT-R0 , ( RP0 ) 0 , ( #OUT ) 0 , ( #LINE ) 0 , ( OFFSET ) 10 , ( BASE ) 0 , ( HLD ) 0 , ( FILE ) 0 , ( IN-FILE ) FALSE , ( PRINTING ) 0 , ( DP ) ' DOS-TYPE , ( EMIT ) \ Resident Tools 4 /9 /89: DEPTH (S -- n ) SP@ SP0 @ SWAP - 2/ ; : .S (S -- ) DEPTH ?DUP IF 0 DO DEPTH I - 1- PICK 7 U.R SPACE KEY? ?LEAVE LOOP ELSE ." Empty " THEN ; : L>PAD ( addr seg len -- addr len ) >R PAD CSEG R> LCMOVE ; : NAME>PAD ( nfa -- ) 1+ HEAD-SEG 2DUP LC@ 1+ L>PAD ; : (.ID) ( nfa -- ) NAME>PAD PAD COUNT TYPE ; : .ID ( nfa -- ) (.ID) SPACE ; \ For Completeness 5 /15/88: RECURSE (S -- ) LAST @ NAME> , ; IMMEDIATE \ Resolve Forward References 23JAN86GEB ' (.") RESOLVES <(.")> ' (") RESOLVES <(")> ' (;CODE) RESOLVES <(;CODE)> ' (;USES) RESOLVES <(;USES)> ' (IS) RESOLVES <(IS)> ' (ABORT") RESOLVES <(ABORT")> [ASSEMBLER] DOCREATE META CFA-RESOLVES <VARIABLE> [ASSEMBLER] DOUSER-DEFER META CFA-RESOLVES <USER-DEFER> [ASSEMBLER] DOUSER-VARIABLE META CFA-RESOLVES <USER-VARIABLE> [ASSEMBLER] DODEFER META CFA-RESOLVES <DEFER> \ Resolve Forward References 5 /15/88' DEFINITIONS RESOLVES DEFINITIONS ' [ RESOLVES [ ' 2+ RESOLVES 2+ ' 1+ RESOLVES 1+ ' 2* RESOLVES 2* ' ?MISSING RESOLVES ?MISSING ' QUIT RESOLVES QUIT ' DEPTH RESOLVES DEPTH ' ABORT RESOLVES ABORT ' INTERPRET RESOLVES INTERPRET ' EMIT RESOLVES EMIT ' PLACE RESOLVES PLACE ' BYE RESOLVES BYE ' /STRING RESOLVES /STRING ' WORD RESOLVES WORD ' 'WORD RESOLVES 'WORD ' AVOC RESOLVES AVOC \ Initialize DEFER words 5 /15/88 ' (LOAD) IS LOAD ' (BYE) IS BYE ' (KEY?) IS KEY? ' (KEY) IS KEY ' CRLF IS CR ' FILE-READ IS READ-BLOCK ' FILE-WRITE IS WRITE-BLOCK ' NOOP IS WHERE ' CR IS STATUS ' (SOURCE) IS SOURCE ' (QUIT) IS QUIT ' START IS BOOT ' (WARM) IS WARM ' (NUMBER) IS NUMBER ' (CHAR) IS CHAR ' (DEL-IN) IS DEL-IN ' (?ERROR) IS ?ERROR ' DP-BODY IS DP ' CSEG IS DP-SEG ' (OK) IS PROMPT \ Initialize Variables 5 /15/88' FORTH >BODY/T CURRENT !-T ' FORTH >BODY/T CONTEXT !-T ' CC-FORTH >BODY/T CC !-T ' CC-FORTH >BODY/T 256 + CC2 !-T >BODY-T HERE-T DP-BODY UP @-T + !-T >HEAD-T HERE-T DP-HEAD >BODY-T !-T #USER-T @ #USER !-T ( INIT USER VAR COUNT ) TRUE 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 5 /15/88EXIT ******************************************************************* ****** Thus we have created a hopefully running ****** Forth system for the 8086. After this file ****** has been compiled, it is saved as a CMD file ****** called KERNEL86.CMD on the disk. To generate ****** a system you must now leave the Meta Compiler ****** and fire up KERNEL with the file EXTEND86.BLK ****** on the execute line. Be sure to prefix a B: ****** if necessary. ( KERNEL86 EXTEND86.BLK ) ****** Once you have fired it up, type START and it ****** will compile the applications. Good Luck. ****** *******************************************************************\ Target System Setup 19feb86geb Make Room for HOST definitions Load the Source Screens that define the System 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 Save the System as a DOS .COM file, ready to be executed \ Declare the Forward References 5 /15/88]] We will need the FORTH version of ] quite often. [[ The same is true for [[. DEFINIITONS To avoid finding DEFINITIONS in the ONLY vocabulary[ To avoid finding [ in the TRANSITION vocabulary \ Boot up Vectors and NEXT Interpreter 19feb86geb The first 8 bytes in the system are vectors to the Cold and Warmstart entries. You can freely jump to them in code anytime. >NEXT is where all the action is. It is the guts of the Forth Virtual Machine. It must advance the interpretive pointer held in the IP register pair and jump to what it points to. We define a few macros here to make our life a little easier later. Using NEXT as a macro allows us to put it inline later. Two versions of NEXT are supplied. The first is usually commented out since it is a jump to NEXT and slower. It has the advantage of allowing the debugger to work on all words. The second version is an in-line NEXT, faster but the debugger can't trap the next. \ Run Time Code for Defining Words 5 /15/88NEST The runtime code for : It pushs the current IP onto the return stack and sets the IP to point to the parameter field of the word being executed. EXIT Pop an entry off the return stack and place it into the Interpretive Pointer. Terminates a Hi Level definition. UNNEST Same as exit. Compiled by ; to help decompiling. DODOES The runtime portion of defining words. First it pushes the IP onto the return stack and then it pushes the BODY address of the word being executed onto the parameter stack. DOCREATE Leave a pointer to its own parameter field on the stack. This is also the runtime for variable. \ Run Time Code for Defining Words 5 /15/88UP Holds a pointer to the current USER area. ( multitasking ) DOCONSTANT The run time code for CONSTANT. It takes the contents of the parameter field and pushes it onto the stack.DOUSER-VARIABLE The run time code for USER variables. Places a pointer to the current version of this variable on the stack. Needed for multitasking. DO-DEFER run time code for deferred words DOUSER-DEFER run time code for user deferred words (LIT) The runtime code for literals. Pushes the following two bytes onto the parameter stack and moves the IP over them. It is compiled by the word LITERAL. (') run time code for ' same as (LIT) (ASCII) same as (LIT) and (') Multiple defs used so that SEE can work better \ Meta Defining Words 5 /15/88LITERAL Now that code field of (LIT) is known, define LITERAL DLITERAL Both LITERAL and DLITERAL are TRANSITION words, ie IMMEDIATE ASCII Compile the next character as a literal. ['] Compile the code field of the next word as a literal. CONSTANT Define a CONSTANT in the Target. We also save its value in META for use during interpretation. \ Identify numbers and forward References 5 /15/88<(;CODE)> Forward reference for code to patch code field. DOES> Compile the code field for (;CODE) and a CALL instruction to the run time for DOES, called DODOES. NUMERIC Make a number out of this word and compile it as either a single or double precision literal. NUMERIC is only called if the word is known to be a number. UNDEFINED Creates a forward reference "on the fly". The symbol is kept in the FORWARD vocabulary and it is initialized to unresolved. When executed it either compiles itself or links into a backwards pointing chain of forward references. \ Meta Compiler Compiling Loop 5 /15/88T-IN Needed to save a pointer into the input stream for later.] Start compiling into the TARGET system. Always search TRANSITION before TARGET for immediate words. If word is found, execute it. It must compile itself. If word is not found, convert it to a number if it is numeric, otherwise it is a forward reference. [ Sets STATE-T to false to exit the Meta Compiling loop above. ; Compile the code field of UNNEST and terminate compilation : Create a target word and set its code field to NEST. \ Run Time Code for Control Structures 5 /15/88BRANCH Performs an unconditional branch. Notice that we are using absolute addresses insead of relative ones. (fast) ?BRANCH Performs a conditional branch. If the top of the parameter stack in True, take the branch. If not, skip over the branch address which is inline. \ Meta Compiler Branching Words 5 /15/88These are the META versions of the structured conditionals found in FORTH. They must compile the correct run time branch instruction, and then Mark and Resolve either forward or backward branches. These are very analogous to the regular conditionals in Forth. Since they are in the TRANSITION vocabulary, which is searched before the TARGET vocabulary, they will be executed instead of the TARGET versions of these words which are defined much later. \ Run Time Code for Control Structures 01JUL87GEB(LOOP) the runtime procedure for LOOP. Branches back to the beginning of the loop if there are more iterations to do. Otherwise it exits. The loop counter is incremented. (+LOOP) Increment the loop counter by the value on the stack and decide whether or not to loop again. (DO) The runtime code compiled by DO. Pushes the inline address onto the return stack along with values needed by (LOOP). (?DO) The runtime code compiled by ?DO. The difference between ?DO and DO is that ?DO will not perform any iterations if the initial index is equal to the final index. BOUNDS Given address and length, make it ok for DO ... LOOP. \ Meta compiler Branching & Looping 5 /15/88These are again the TRANSITION versions of the immediate words for looping. They compile the correct run time code and then Mark and Resolve the various branches. \ Execution Control 5 /15/88>NEXT The address of the inner interpreter. EXECUTE the word whose code field is on the stack. Very useful for passing executable routines to procedures!!! PERFORM the word whose code field is stored at the address pointed to by the number on the stack. Same as @ EXECUTE GO Execute code at the given address. NOOP One of the most useful words in Forth. Does nothing. PAUSE Used by the Multitasker to switch tasks. \ Execution Control 5 /15/88I returns the current loop index. It now requires a little more calculation to compute it than in FIG Forth but the tradeoff is a much faster (LOOP). The loop index is stored on the Return Stack. J returns the loop index of the inner loop in nested DO .. LOOPs. (LEAVE) Does an immediate exit of a DO ... LOOP structure. Unlike FIG Forth which waits until the next LOOP is executed. (?LEAVE) Leaves if the flag on the stack is true. Continues if not. LEAVE I have to do this to be 83-Standard. ?LEAVE I have to do this to be consistent. Sad but true. \ 16 and 8 bit Memory Operations 5 /15/88@ Fetch a 16 bit value from addr. ! Store a 16 bit value at addr. C@ Fetch an 8 bit value from addr. C! Store an 8 bit value at addr. 2@ Fetch a 32 bit value at addr 2! Store a 32 bit value at addr +! Add a 16 bit value to addr \ Block Move Memory Operations 5 /15/88CMOVE Move a set of bytes from the from address to the to address. The number of bytes to be moved is count. The bytes are moved from low address to high address, so overlap is possible and in fact sometimes desired. CMOVE> The same as CMOVE above except that bytes are moved in the opposite direction, ie from high addresses to low addresses. FILL store the char a count number of bytes starting at addr \ 16 and 8 bit Long Memory Operations 5 /15/88L@ (S adr seg -- n ) fetch a 16 bit value from a far address L! (S n adr seg -- ) store a 16 bit value to a far address LC@ (S adr seg -- char ) fetch 8 bit from far away LC! (S char adr seg -- ) store 8 bit to far away LCMOVE ( from fromseg to toseg len -- ) move len bytes from one addr:seg to another addr:seg CSEG ( -- codeseg ) return the current codeseg 16 bit value \ 16 bit Stack Operations 5 /15/88SP@ Return the address of the next entry on the parameter stackSP! ( Warning, this is different from FIG Forth ) Sets the parameter stack pointer to the specified value. RP@ Return the address of the next entry on the return stack. RP! ( Warning, this is different from FIG Forth ) Sets the return stack pointer to the specified value. R> Pop top of return stack to parameter stack >R Pop top of parameter stack to return stack R@ Copy top of return stack to parameter stack \ 16 bit Stack Operations 5 /15/88DROP Throw away the top element of the stack. DUP Duplicate the top element of the stack. SWAP Exchange the top two elements on the stack. OVER Copy the second element to the top. PICK Push the kth element on the stack to the top of stack ROLL rotate the kth element on the stack to the top Note: these last two changed from the 79 to 83 standard !! \ 16 bit Stack Operations 5 /15/88TUCK Tuck the first element under the second one. NIP Drop the second element from the stack. ROT Rotate the top three element, bringing the third to the top. -ROT The inverse of ROT. Rotates the top element to third place. FLIP Exhange the hi and low halves of a word. ?DUP Duplicate the top of the stack if it is non-zero. \ 16 bit Logical Operations 5 /15/88AND Returns the bitwise AND of n1 and n2 on the stack. OR Returns the bitwise OR of n1 and n2 on the stack. XOR Returns the bitwise Exclusive Or of n1 and n2 on the stack. NOT Does a ones complement of the top. Equivalent to -1 XOR. TRUE FALSE Constants for clarity. \ Logical Operations 5 /15/88CSET Set the contents of addr so that the bits that are 1 in n are also 1 in addr. Equivalent to DUP C@ ROT OR SWAP C! LCSET Set a bit at a far address CRESET Set the contents of addr so the the bits that are 1 in n are zero in addr. Equivalent to DUP C@ ROT NOT AND SWAP C! CTOGGLE Flip the bits in addr by the value n. Equivalent to DUP C@ ROT XOR SWAP C! ON Set the contents of addr original value of TRUE OFF Set the contents of addr original value of FALSE Note that changing the contents of TRUE and FALSE does not affect these words. \ 16 bit Arithmetic Operations 5 /15/88+ Add the top two numbers on the stack and return the result. NEGATE Turn the number into its negative. A twos complement op. - Subtracts n2 from n1 leaving the result on the stack. ABS Return the absolute value of the 16 bit integer on the stack the following: DUP @ ROT + SWAP ! but much faster. 0 1 Frequently used constants 2 3 Are faster and more code efficient. \ 16 bit Arithmetic Operations 5 /15/882* Double the number on the Stack. 2/ Shift the number on the stack right one bit. Equivalent to division by 2 for positive numbers. U2/ 16 bit logical right shift. 8* Multiply the top of the stack by 8. 1+ Increment the top of the stack by one. 2+ Increment the top of the stack by two. 1- Decrement the top of the stack by one. 2- Decrement the top of the stack by two. \ 16 bit Arithmetic Operations Unsigned Multiply 5 /15/88You could write a whole book about multiplication and division, and in fact Knuth did. Suffice it to say that UM* is the basic multiplication primitive in Forth. It takes two unsigned 16 bitintegers and returns an unsigned 32 bit result. All other multiplication functions are derived from this primitive one. \ 16 bit Arithmetic Operations Unsigned Divide 5 /15/88UM/MOD This is the division primitive in Forth. All other division operations are derived from it. It takes a double number, d1, and divides by by a single number n1. It leaves a remainder and a quotient on the stack. For a clearer understanding of arithmetic consult Knuth Volume 2 on Seminumerical Algorithms. \ 16 bit Comparison Operations 5 /15/88YES Push a true onto the stack. A code saver. NO Push a flase onto the stack. A code saver. 0= Returns True if top is zero, False otherwise. 0< Returns true if top is negative, ie sign bit is on. 0> Returns true if top is positive. 0<> Returns true if the top is non-zero, False otherwise. = Returns true if the two elements on the stack are equal, <> Returns true if the two element are not equal, else false. ?NEGATE Negate the second element if the top is negative. \ 16 bit Comparison Operations 5 /15/88YES To make sure we are within 128 bytes U< Unsigned comparison of the top two elements. Be sure to use U< or U> whenever comparing addresses! U> Compare the top two elements on the stack as unsigned integers. True if n1 > n2 unsigned. < Compare the top two elements on the stack as signed integers and return true if n1 < n2. > Compare the top two elements on the stack as signed integers and return true if n1 > n2. \ 16 bit Comparison Operations 5 /15/88MIN Return the minimum of n1 and n2 MAX Return the maximum of n1 and n2 BETWEEN Return true if min <= n1 <= max, otherwise false. WITHIN Return true if min <= n1 < max, otherwise false. \ 32 bit Memory and Stack Operations 5 /15/882DROP Drop the top two elements of the stack. 2DUP Duplicate the top two elements of the stack. 2SWAP Swap the top two pairs of numbers on the stack. You can use this operator to swap two 32 bit integers and preserve their meaning as double numbers. 2OVER Copy the second pair of numbers over the top pair. Behaves like 2SWAP for 32 bit integers. 3DUP Duplicate the top three elements of the stack. 4DUP Duplicate the top four elements of the stack. 2ROT rotates top three double numbers. \ 32 bit Arithmetic Operations 5 /15/88D+ Add the two double precision numbers on the stack and return the result as a double precision number. D- Subtract the two double precision numbers on the stack DNEGATE Same as NEGATE except for double precision numbers. S>D Take a single precision number and make it double precision by extending the sign bit to the upper half. DABS Return the absolute value of the 32 bit integer on the stack \ 32 bit Arithmetic Operations 5 /15/88D2* 32 bit arithmetic left shift. Equivalent to multiply by 2. D2/ 32 bit arithmetic right shift. Equivalent to divide by 2. ?DNEGATE Negate the double number if the top is negative. \ 32 bit Comparison Operations 5 /15/88D0= Compare the top double number to zero. True if d = 0 D= Compare the top two double numbers. True if d1 = d2 DU< Performs unsigned comparison of two double numbers. D< Compare the top two double numbers. True if d1 < d2 D> Compare the top two double numbers. True if d1 > d2 DMIN Return the lesser of the top two double numbers. DMAX Return the greater of the the top two double numbers. \ Mixed Mode Arithmetic 5 /15/88This does all the arithmetic you could possibly want and even more. I can never remember exactly what the order of the arguments is for any of these, except maybe * / and MOD, so I suggest you just try it when you are in doubt. That is one of the nice things about having an interpreter around, you can ask it questions anytime and it will tell you the answer. *D multiplys two singles and leaves a double. M/MOD divides a double by a single, leaving a single quotient and a single remainder. Division is floored. MU/MOD divides a double by a single, leaving a double quotient and a single remainder. Division is floored. \ 16 bit multiply and divide 5 /15/88 */ is a particularly useful operator, as it allows you to do accurate arithmetic on fractional quantities. Think of it as multiplying n1 by the fraction n2/n3. The intermediate result is kept to full accuracy. Notice that this is not the same as * followed by /. See Starting Forth for more examples. >> shift a number to the right n2 bits << shift a number to the left n2 bits SHIFT given a number and signed shift n2 call << or >> \ Task Dependant USER Variables 19feb86geb TOS Saved during Task switching. ENTRY Jumped to during multitasking. LINK Points to next task in the circular queue SP0 Empty parameter stack for this task. RP0 Empty return stack for this task. #OUT Number of characters sent since last CR. #LINE Number of CR's sent since last page. OFFSET Added to all block references. BASE The current numeric base for number input output. HLD Points to a converted character during numeric output. FILE Allows printing of one file while editing another. IN-FILE Points to file which is loaded and copied from. PRINTING indicates whether printing is enabled. DP-BODY pointer to here for bodys \ System VARIABLEs 19feb86gebTYPE sends a string to the output device. return from user to meta definitions SCR Holds the screen number last listed or edited. PRIOR Points to the last vocabulary that was searched. DPL The decimal point location for number input. WARNING Checked by WARN for duplicate warnings. R# The cursor position during editing. HLD Points to a converted character during numeric output. LAST Points to the name of the most recently CREATEd word. CSP Used for compile time error checking. CURRENT New words are added to the CURRENT vocabulary. #VOCS The number of elements in the search order array. CONTEXT The array specifying the search order. \ System Variables 5 /15/88'TIB Points to characters entered by user. WIDTH Number of characters to keep in name field. VOC-LINK Points to the most recently defined vocabulary. BLK If non-zero, the block number we are interpreting. >IN Number of characters interpreted so far. SPAN Number of characters input by EXPECT. #TIB Used by WORD, when interpreting from the terminal. END? True if input stream exhausted, else false. DP-HEAD dictionary pointer for head segment HEAD-SEG segment pointer for heads DP and DP-SEG are both defered in this system \ Devices Strings 5 /15/88BL BS BELL Names for BLank, BackSpace, and BELL ERASE Fill the string with zeros BLANK Fill the string with blanks COUNT Given the address on the stack, returns the address plus one and the byte at that address. Useful for strings. LENGTH Given the address on the stack, returns the address plus two and the two byte contents of the address. MOVE Move the specified bytes without overlapping. PAD is at HERE + 80 CAPS a variable that controls the automatic conversion of words to upper case \ Devices Strings 5 /15/88>UPPER Convert the Char in A to upper Case UPC convert a character to upper case UPPER Take the string at the specified address and convert it to upper case. It converts thr staring in place, so be sure to make a copy of the original if you need to use it later HERE Return the address of the top of the dictionary LHERE Top of dictionary in ADDR:SEG form -TRAILING Return the address and length of the given string ignoring trailing blanks. \ Devices Strings 5 /15/88COMP This performs a string compare. If the two strings are equal, then COMPARE returns 0. If the two strings differ, then COMPARE returns -1 or +1. -1 is returned if string 1 is less than string 2. +1 is returned if string 1 is greater than string 2. All comparisons are relative to ASCII order. The code on this screen handles the case when upper/lower case is deemed significant. Thus lower case a does not match upper case A. \ Devices Terminal Input and Outpu 5 /15/88KEY? * KEY * System defered words for input/output CR * SPACE emit a space SPACES emit n spaces BACKSPACES emit n backspaces \ Devices System Dependent Control Characters 5 /15/88LAST-KEY A place to save the last key typed BS-IN If at beginning of line, beep, otherwise back up 1. (DEL-IN) If at beginning of line, beep, otherwise back up and erase 1.BACK-UP Wipe out the current line by overwriting it with spaces. RES-IN Reset the system to a relatively clean state. P-IN Toggle the printer on or off \ Devices Terminal Input 5 /15/88CR-IN Finish input and remember the number of chars in SPAN (CHAR) Process an ordinary character by appending it to the buffer. CHAR is usually (CHAR). Executed for most characters. DEL-IN is usually (DEL-IN). Executed for delete characters. CC Points to current control character table. CC2 Handle each control character as a special case. This generates an execution array which is indexed into by EXPECT to do the right thing when it receives a control character. This version has all 256 characters vectored. \ Devices Terminal Input 5 /15/88EXPECT Get a string from the terminal and place it in the buffer provided. Performs a certain amount of line editing. Saves the number of characters input in the Variable SPAN. Processes control characters per the array pointed to by CC. TIB Leaves address of text input buffer. QUERY Get more input from the user and place it at TIB. \ Devices BLOCK I/O 5 /15/88#BUFFERS number of buffers in the system B/BUF bytes per buffer DISK-ERROR temp storage for error number LIMIT limit end $FFFE >SIZE constant size of buffer header block FIRST location of first INIT-R0 start of return stack >BUFFERS ( -- adr ) get buffer header area >END ( -- adr ) get end of buffer header area BUFFER# ( n -- adr ) go to buffer # >UPDATE ( -- adr ) update area for buffer \ Devices BLOCK I/O 5 /15/88DEFER READ-BLOCK DEFER WRITE-BLOCK defered read/write words load IO.SCR and reset VIEW# \ Devices BLOCK I/O 5 /15/88 LATEST? For increased performance we first check to see if the block we want is the very first one in the list. If it is return the buffer address and false, and exit from the word that called us, namely ABSENT?. Otherwise we return as though nothing had happened. ABSENT? Search through the block/buffer list for a match. If it is found, bring the block packet to the top of the list and return a false flag and the address of the buffer. If the block is not found, return true, indicating it is absent, and the second parameter is garbage. \ Devices BLOCK I/O 5 /15/88UPDATE Mark the most recently used buffer as modified. DISCARD Mark the most recently used buffer as unread. MISSING Writes the least recently used buffer to disk if it was modified, and moves all of the buffer pointers down by one, making the first one available for the new block. It then assigns the newly available buffer to the new block. (BUFFER) assigns a buffer to the specified block in the given file. No disk read is performed. Leaves the buffer address. BUFFER assigns a buffer to the specified block. No disk read is performed. Leaves the buffer address. (BLOCK) Leaves the address of a buffer containing the given block in the given file. Reads the disk if necessary. BLOCK Leaves the address of a buffer containing the given block. Reads the disk if necessary. IN-BLOCK like BLOCK, but for the IN-FILE. \ Devices BLOCK I/O 5 /15/88EMPTY-BUFFERS First wipe out the data in the buffers. Next initialize the buffer pointers to point to the right addresses in memory and set all of the update flags to unmodified. SAVE-BUFFERS Write back all of the updated buffers to disk, and mark them as unmodified. Use this whenever you are worried about crashing or losing data. FLUSH Save and empties the buffers. Used for changing disks. \ Devices BLOCK I/O 5 /15/88(LOAD) Load the screen number that is on the stack. The input stream is diverted from the terminal to the disk. LOAD Interpret a screen as if it were type in . \ Interactive Layer Number Input 20feb86gebDIGIT Returns a flag indicating whether or not the character is a valid digit in the given base. If so, returns converted value and true, otherwise returns char and false. DOUBLE? Returns non-zero if period was encountered. CONVERT Starting with the unsigned double number ud1 and the string at adr1, convert the string to a number in the current base. Leave result and address of unconvertable digit on stack. HEX Set base convertion to hexadecimal \ Interactive Layer Number Input 20feb86geb(NUMBER?) Given a string containing at least one digit, convert it to a number. NUMBER? Convert the count delimited string at addr to a double number. NUMBER? takes into account a leading minus sign, and stores a pointer to the last delimiter in DPL. The string must end with a blank. Leaves a true flag if successful. (NUMBER) Convert the count delimited string at addr to a double number. (NUMBER) takes into account a leading minus sign, and stores a pointer to the last period in DPL. Note the string must end with a blank or an error message is issued. NUMBER Convert a string to a number. Normally (NUMBER) \ Interactive Layer Number Output 20feb86gebHOLD Save the char for numeric output later. <# Start numeric conversion. #> Terminate numeric conversion. SIGN If n1 is negative insert a minus sign into the string. # Convert a single digit in the current base. #S Convert a number until it is finished. DECIMAL All subsequent numeric IO will be in Decimal. OCTAL All subsequent numeric IO will be in Octal. BINARY All subsequent numeric IO will be in Binary. \ Interactive Layer Number Output 5 /15/88(U.) Convert an unsigned 16 bit number to a string. U. Output as an unsigned single number with trailing space. U.R Output as an unsigned single number right justified. (.) Convert a signed 16 bit number to a string. . Output as a signed single number with a trailing space. .R Output as a signed single number right justified. (UD.) Convert an unsigned double number to a string. UD. Output as an unsigned double number with a trailing spaceUD.R Output as an unsigned double number right justified. (D.) Convert a signed double number to a string. D. Output as a signed double number with a trailing space. D.R Output as a signed double number right justified. \ Interactive Layer Parsing 5 /15/88SKIP Given the address and length of a string, and a character to look for, run through the string while we continue to find the character. Leave the address of the mismatch and the length of the remaining string. SCAN Given the address and length of a string, and a character to look for, run through the string until we find the character. Leave the address of the match and the length of the remaining string. \ Interactive Layer Parsing 5 /15/88/STRING Index into the string by n. Returns addr+n and len-n. PLACE Move the characters at from to to with a preceding length byte of len. (SOURCE) Returns the string to be scanned. This is the default value of the deferred word SOURCE. SOURCE Return a string from the current input stream. PARSE-WORD Scan the input stream until char is encountered. Skip over leading chars. Update >IN pointer. Leaves the address and length of the enclosed string. PARSE Scan the input stream until char is encountered. Update >IN pointer. Leaves the address and length of the enclosed string. \ Interactive Layer Parsing 5 /15/88'WORD Leaves the same address as WORD. In this system, 'WORD is the same as HERE. WORD Parse the input stream for char and return a count delimited string at here. Note there is always a blank following it. >TYPE TYPE for multitasking systems. .( Type the following string on the terminal. ( The Forth Comment Character. The input stream is skipped until a ) is encountered. \S comment to end of screen. \ Interactive Layer Dictionary 5 /15/88DONE? True if the input stream is exhaused or state doesn't match FORTH-83 Let's hope so. .VERSION Identify the system. C,HEAD comma a byte to the head space ,HEAD comma a word to the head space ,BODY comma a word to the code or body space C,BODY comma a byte to the code or body space \ Interactive Layer Dictionary 5 /15/88N>LINK Go from name field to link field. L>NAME Go from link field to name field. BODY> Go from body to code field. NAME> Go from name field to code field. LINK> Go from link field to code field. >BODY Go from code field to body. >NAME Go from code field to name field. >LINK Go from code field to link field. >VIEW Go from code field to view field. VIEW> Go from view field to code field. !>HEAD Store 16 bit number to addr in head space @<HEAD Fetch 16 bit number from addr in head space ,NAME Comma name to head space #THREADS The number of seperate linked lists per vocabulary. \ Interactive Layer Dictionary 5 /15/88HASH Given a string address and a pointer to a set of vocabulary chains, returns the actual thread. Uses the first character of the string to determine which thread. (FIND) Does a search of the dictionary based on a pointer to a vocabulary thread and a string. If it finds the string in the chain, it returns a pointer to the CFA field inside the header. This field contains the code field address of the body. If it was an immediate word the flag returned is a 1. If it is non-immediate the flag returned is a -1. If the name was not found, the string address is returned along with a flag of zero. Note that links point to links, and are absolute addresses. \ Interactive Layer Dictionary 5 /15/88FIND Run through the vocabulary list searching for the name whose address is supplied on the stack. If the name is found, return the code field address of the name and a non-zero flag. The flag is -1 if the word is non-immediate and 1 if it is immediate. If the name is not found, the string address is returned along with a false flag. ?UPPERCASE Convert the given string to upper case if CAPS is true. DEFINED Look up the next word in the input stream. Return true if it exists, otherwise false. Maybe ignore case. \ Interactive Layer Interpreter 5 /15/88?STACK Check for parameter stack underflow or overflow and issue appropriate error message if detected. STATUS Indicate the current status of the system. INTERPRET The Forth Interpret Loop. If the next word is defined, execute it, otherwise convert it to a number and push it onto the stack. [ Alias for interpret ] End interpreting \ Extensible Layer Compiler 5 /15/88ALLOT Allocate more space in the dictionary ALLOT0 Allocate nulled space in the dictionary , Set the contents of the dictionary value on the stack C, Same as , except uses an 8 bit value ALIGN Used to force even addresses. EVEN Makes the top of the stack an EVEN number. COMPILE Compile the following word when this def. executes IMMEDIATE Mark the last Header as an Immediate word. LITERAL Compile the single integer from the stack as a literal DLITERAL Compile the double integer from the stack as a literal. ASCII Compile the next character in the input stream as a literal Ascii integer. CONTROL Compile the next character in the input stream as a literal Ascii Control Character. \ Extensible Layer Compiler 5 /15/88CRASH Default routine called by execution vectors. ?MISSING Tell user the word does not exist. ' Return the code field address of the next word ['] Like ' only used while compiling [COMPILE] Force compilation of an immediate word (") Return the address and length of the inline string (.") Type the inline string. Skip over it. ," Add the following text till a " to the dictionary. ." Compile the string to be typed out later. " Compile the string, return pointer later. \ Interactive Layer Dictionary 5 /15/88FENCE Limit address for forgetting. TRIM (S fadr voc-adr -- ) Change the 4 hash pointers in a vocabulary so that they are all less than a specified value, fadr. (FORGET) (S code-adr relative-link-adr -- ) Forgets part of the dictionary. Both the code address and the header address are specified, and may be independant. (FORGET) resets all of the links and releases the space. FORGET (S -- ) Forget all of the code and headers before the next word. \ Extensible Layer Compiler 5 /15/88WHERE Locates the screen and position following an error. ?ERROR Maybe indicate an error. Change this to alter ABORT" (?ERROR) Default for ?ERROR. Conditionally execute WHERE and type message. (ABORT") The Runtime code compiled by ABORT". Uses ERROR, and updates return stack. ABORT" If the flag is true, issue an error message and quit. ABORT Stop the system and indicate an error. \ Extensible Layer Structures 5 /15/88?PAIRS Simple compile time error checking. >MARK Set up for a Forward Branch >RESOLVE Resolve a Forward Branch <MARK Set up for a Backwards Branch <RESOLVE Resolve a Backwards Branch LEAVE and ?LEAVE could be non-immediate in this system, but the 83 standard specifies an immediate LEAVE, so they both are for uniformity. \ Extensible Layer Structures 5 /15/88These are the compiling words needed to properly compile the Forth Conditional Structures. Each of them is immediate and they must compile their runtime routines along with whatever addresses they need. A modest amount of error checking is done. \ Extensible Layer Defining Words 5 /15/88,JSR commas in a jsr byte ,VIEW Calculate and compile the VIEW field of the header. "CREATE Use the string at str to make a header, and initialize the code field. First we lay down the view field. Next we lay down an empty link field. We set up LAST so that it points to our name field, and check for duplicates. Next we link ourselves into the correct thread and delimit the name field bits. Finally lay down the code field. MISALIGN Force the dictionary to be at an odd address. Faster 286 execution. CREATE Make a header for the next word in the input stream. !CSP Save the current stack level for error checking. ?CSP Issue error message if stack has changed. \ Extensible Layer Defining Words 5 /15/88HIDE Removes the Last definition from the Dictionary REVEAL Replaces the Last definition in the Dictionary (;USES) Set the code field to the contents of following cellASSEMBLER Define the vocabulary to be filled later. ;USES Similar to the traditional ;CODE except used when run time code has been previously defined. (;CODE) Set the code field to the address of the following. ;CODE Used for defining the run time portion of a defining word in low level code. DOES> Specifies the run time of a defining word in high level Forth. \ Extensible Layer Defining Words 5 /15/88COMPILER The Compiling Loop. Looks at the next word in the input stream and either executes it or compiles it depending upon whether or not it is immediate. If the word is not in the dictionary, it converts it to a number, either single or double precision depending on whether or not any punctuation was present. Continues until input stream is empty or state changes. : Defines a colon definition. The definition is hidden until it is completed, or the user desires recursion. The runtime for : adds a nesting level. ; Terminates a colon definition. Compiles the runtime code to remove a nesting level, and changes STATE so that compilation will terminate. \ Extensible Layer Defining Words 5 /15/88RECURSIVE Allow the current definition to be self referencing CONSTANT A defining word that creates constants. At runtime the value of the constant is placed on the stack. VARIABLE A defining word to create variables. At runtime the address of the variable is placed on the stack. DEFER Defining word for execution vectors. These are initially set to display an error message. They are initialized with IS. #USER Count of how many user variables are allocated USER Vocabulary that holds task versions of defining words VOCABULARY Defines a new Forth vocabulary. VOC-LINK is a chain in temporal order and used by FORGET. At runtime a vocabulary changes the search order by setting CONTEXT. DEFINITIONS Subsequent definitions will be placed into CURRENT.\ Extensible Layer Defining Words 5 /15/882CONSTANT Create a double number constant. This is defined for completeness, but never used, so the code field is discarded.2VARIABLE Create a double length variable. This is defined for completeness, but never used, so the code field is discarded. as appropriate. AVOC A variable that hold the old CONTEXT vocabulary CODE is the defining word for FORTH assembler definitions. It saves the context vocabulary and hides the name. END-CODE terminates a code definition and restores vocs. \ Extensible Layer Defining Words 5 /15/88 ALLOT Allocate some space in the user area for a task. When used with CREATE, you can define arrays this way. CREATE Define a word that returns the address of the next available user memory location. VARIABLE Define a task type variable. This is similar to the old FIG version of USER. DEFER Defines an execution vector that is task local. \ Extensible Layer ReDefining Words 5 /15/88>IS Maps a code field into a data field. If the word is in the USER class of words, then the data address must be calculated relative to the current user pointer. Otherwise it is just the parameter field. (IS) The code compiled by IS. Sets the following DEFERred word to the address on the parameter stack. IS Depending on STATE, either sets the following DEFERred word immediatly or compiles the setting for later. \ Initialization High Level 5 /15/88PROMPT defered definition for FORTH prompt (OK) Usual execution word for PROMPT QUIT The main loop in Forth. Gets more input from the terminal and Interprets it. Responds with OK if healthy. BOOT The very first high level word executed during cold startWARM Performs a warm start, jumped to by vector at hex 104 COLD The high level cold start code. For ordinary forth, BOOT should initialize and pass control to QUIT. \ Initialization High Level 19FEB86GEBINITIAL The screen number to load for an application. OK Loads in an application from the INITIAL screen START Used to compile from a file after meta compilation has finished. BYE Returns control to DOS. \ Initialization Low Level 5 /15/88 WARM Initialize the warm start entry point in low memory and jump immediately into hi level COLD Initialize the cold start entry point in low memory Then calculate how much space is consumed by CP/M and round it down to an even HEX boundary for safety. We then patch FIRST and LIMIT with this value and calculate the locations of the return stack and the Terminal Input buffer. We also set up the initial parameter stack and finally call the Hi Level COLD start routine. \ Initialize User Variables 5 /15/88Finally we must initialize the user variables that were defined earlier. User variables are relocatable, and sit on the top of the dictionary in whatever task they occur in. They must be laid down in the exact same order as their definitions. \ Resident Tools 5 /15/88DEPTH Returns the number of items on the parameter stack .S Displays the contents of the parameter stack non destructively. Very useful when debugging. L>PAD move a string at addr:seg of length len to pad (.ID) .ID without a trailing space .ID Display the variable length name whose name field address is on the stack. If it is shorter than its count, it is padded with underscores. Only valid Ascii is typed. These words are in the reference word sets, 5 /15/88and are only include for completeness. We prefer to use RECURSIVE rather than RECURSE. ( See RECURSIVE ) \ Resolve Forward References 5 /15/88We must resolve the forward references that were required in the Meta Compiler. These are all run time code which wasn't known at the time the meta compiling version was defined. Theseare all either defining words or special case immediate words. \ Resolve Forward References 5 /15/88These are forward references that were generated in the course of compiling the system source. Most of these are here because (DO) (?DO) and ROLL are written in high level and are defined very early in the system. While forward references should be avoided when possible, they should not be shunned as a matter of dogma. Since the meta compiler makes it easy to create and resolve forward references, why not take advantage of it when you need to. \ Initialize DEFERred words 5 /15/88In order to run, we must initialize all of the defferred words that were defined to something meaningful. Deferred words are also known as execution vectors. The most important execution vectors in the system are listed here. You can certainly createyour own with the defining word DEFER. Be sure you initialize them however, or else you will surely crash. \ Initialize Variables 5 /15/88Initialize the CURRENT vocabulary to point to FORTH Initialize the CONTEXT vocabulary to point to FORTH Initialize the Threads in the Forth vocabulary The value of DP-BODY is only now know, so we must init it here The rest of the variables that are initialize are ordinary variables, which are resident in the dictionary, and must be correct upon cold boot. You can change some of these depending on how you want your system to come up initially. For example if you do not normally want to ignore case, set CAPS to FALSE instead of true. \ The Rest is Silence 26Sep83map*************************************************************
