\ KERNEL3.SEQ More kernel stuff FILES DEFINITIONS VARIABLE KERNEL3.SEQ FORTH DEFINITIONS : >TYPE ( adr len -- ) TUCK PAD SWAP CMOVE PAD SWAP TYPE ; : .( ( -- ) ASCII ) PARSE >TYPE ; IMMEDIATE : ( ( -- ) ASCII ) PARSE 2DROP ; IMMEDIATE CODE TRAVERSE ( addr direction -- addr' ) POP CX POP BX ADD BX, CX PUSH ES MOV ES, YSEG BEGIN MOV ES: AL, 0 [BX] AND AL, # 128 0= WHILE ADD BX, CX REPEAT POP ES PUSH BX NEXT END-CODE CODE DONE? ( n -- f ) POP AX CMP AX, STATE 0<> IF MOV END? # 0 WORD MOV AX, # -1 1PUSH THEN PUSH END? MOV END? # 0 WORD NEXT END-CODE \ : DONE? ( n -- f ) \ STATE @ <> END? @ OR END? OFF ; HEX : CNHASH ( CFA-YA ) 0FE00 AND FLIP ; DECIMAL : CNSRCH ( CFA YA MAXYA - NFA failf ) SWAP 2+ 2+ BEGIN 2DUP U> WHILE ( cfa mxy nfa ) DUP YC@ 31 AND + 1+ DUP Y@ 3 PICK = IF -ROT 2DROP 1- -1 TRAVERSE FALSE EXIT THEN 6 + REPEAT 2DROP TRUE ; : N>LINK 2- ; : L>NAME 2+ ; : BODY> 3 - ; : NAME> 1 TRAVERSE 1+ Y@ ; : LINK> L>NAME NAME> ; : >BODY 3 + ; HERE-Y 4 + \ Step from view field to name field : NO-NAME ; : >NAME ( cfa - nfa ) DUP CNHASH DUP Y@ SWAP 2+ Y@ ( cfa sya mxya ) CNSRCH IF DROP (LIT) [ ROT ,-X ] THEN ; : >LINK >NAME N>LINK ; : >VIEW >LINK 2- ; : VIEW> 2+ LINK> ; CODE HASH ( str-addr voc-ptr -- thread ) POP CX POP BX MOV AL, 0 [BX] ADD AL, 1 [BX] AND AX, # #THREADS 1- SHL AX, # 1 ADD AX, CX 1PUSH END-CODE CODE (FIND) ( here alf -- cfa flag | here false ) POP BX OR BX, BX 0= IF SUB AX, AX 1PUSH THEN POP CX PUSH ES MOV ES, YSEG MOV DI, CX BEGIN MOV ES: AX, 2 [BX] XOR AX, 0 [DI] AND AX, # ( 63 ) $7F3F 0= IF MOV DX, BX ADD BX, # 2 BEGIN INC BX INC DI MOV ES: AL, 0 [BX] XOR AL, 0 [DI] 0<> UNTIL AND AL, # 127 0= IF MOV ES: CX, 1 [BX] \ pick up CFA MOV BX, DX MOV ES: AL, 2 [BX] AND AL, # 64 0<> IF MOV AX, # 1 ELSE MOV AX, # -1 THEN POP ES PUSH CX 1PUSH THEN MOV BX, DX MOV DI, CX THEN MOV ES: BX, 0 [BX] OR BX, BX 0= UNTIL POP ES PUSH CX SUB AX, AX 1PUSH END-CODE CODE DROP.CONTEXT.I2*+@DUP ( A1 --- N1 ) POP AX MOV AX, 0 [RP] ADD AX, 2 [RP] SHL AX, # 1 MOV BX, # CONTEXT ADD BX, AX PUSH 0 [BX] PUSH 0 [BX] NEXT END-CODE \ DUP PRIOR @ OVER PRIOR ! = CODE PRIOR.CHECK ( N1 --- N1 F1 ) POP AX PUSH AX MOV BX, PRIOR MOV PRIOR AX CMP BX, AX 0<> IF MOV AX, # FALSE 1PUSH THEN MOV AX, # TRUE 1PUSH END-CODE CODE OVER.SWAP.HASH.@ POP AX POP BX PUSH BX MOV BX, 0 [BX] ADD BL, BH AND BX, # #THREADS 1- SHL BX, # 1 ADD BX, AX MOV AX, 0 [BX] 1PUSH END-CODE : FIND ( addr -- cfa flag | addr false ) DUP C@ IF PRIOR OFF FALSE #VOCS 0 DO DROP.CONTEXT.I2*+@DUP IF PRIOR.CHECK IF DROP FALSE ELSE OVER.SWAP.HASH.@ (FIND) DUP ?LEAVE THEN THEN LOOP ELSE DROP END? ON ['] NOOP 1 THEN ; : DEFINED ( -- here 0 | cfa [ -1 | 1 ] ) BL WORD ?UPPERCASE FIND ; : STACKUNDER ( --- ) TRUE ABORT" Stack Underflow" ; : STACKOVER ( --- ) TRUE ABORT" Stack Overflow" ; : WARNOVER ( --- ) CR ." Running out of CODE memory! " ; CODE (?STACK) ( --- ) MOV CX, SP MOV BX, UP MOV BX, SP0 [BX] CMP BX, CX U< IF MOV AX, # ' STACKUNDER JMP AX THEN MOV BX, UP MOV BX, DP [BX] ADD BX, # 80 CMP CX, BX U< IF MOV AX, # ' STACKOVER JMP AX THEN ADD BX, # 200 CMP CX, BX U< IF MOV AX, # ' WARNOVER JMP AX THEN NEXT END-CODE \ : (?STACK) ( -- ) \ SP@ SP0 @ OVER U< ABORT" Stack Underflow" \ PAD 2DUP U< ABORT" Stack Overflow" \ 200 + U< \ IF CR ." Running out of CODE memory! " \ THEN ; DEFER ?STACK ' (?STACK) IS ?STACK : INTERP ( -- ) BEGIN ?STACK DEFINED IF EXECUTE ELSE NUMBER DOUBLE? NOT IF DROP THEN THEN FALSE DONE? UNTIL ; DEFER STATUS ( -- ) DEFER INTERPRET ' INTERP IS INTERPRET : PRINT ( --- ) PRINTING ON INTERPRET PRINTING OFF ; : ALLOT ( n -- ) DP +! ; CODE , ( N --- ) MOV BX, UP MOV AX, DP [BX] MOV CX, # 2 ADD DP [BX], CX MOV BX, AX POP CX MOV 0 [BX], CX NEXT END-CODE CODE C, ( N --- ) MOV BX, UP MOV AX, DP [BX] INC DP [BX] WORD MOV BX, AX POP CX MOV 0 [BX], CL NEXT END-CODE : PARAGRAPH ( OFFSET --- PARAGRAPH-INC ) 15 + U16/ ; : ALIGN ( HERE 1 AND IF BL C, THEN ) ; IMMEDIATE : EVEN ( DUP 1 AND + ) ; IMMEDIATE : COMPILE ( -- ) 2R@SWAP R> 2+ >R @L X, ; : CCOMPILE ( -- ) 2R@SWAP R> 2+ >R @L , ; : IMMEDIATE ( -- ) 64 ( Precedence bit ) LAST @ YCSET ; : LITERAL ( n -- ) COMPILE (LIT) X, ; IMMEDIATE : DLITERAL ( d# -- ) SWAP [COMPILE] LITERAL [COMPILE] LITERAL ; IMMEDIATE : ASCII ( -- n ) BL WORD 1+ C@ STATE @ IF [COMPILE] LITERAL THEN ; IMMEDIATE : CONTROL ( -- n ) BL WORD 1+ C@ 31 AND STATE @ IF [COMPILE] LITERAL THEN ; IMMEDIATE : CRASH ( -- ) 2R@SWAP 2- @L >NAME CR .ID TRUE ABORT" <- is an Uninitialized execution vector." ; : ?MISSING ( f -- ) IF 'WORD COUNT TYPE TRUE ABORT" <- huh?, I'm confused! " THEN ; : ' ( -- cfa ) DEFINED 0= ?MISSING ; : ['] ( -- ) ' [COMPILE] LITERAL ; IMMEDIATE : [COMPILE] ( -- ) ' X, ; IMMEDIATE VARIABLE "BUF 80 ALLOT : XEVEN ( XDP --- XDP_EVEN ) DUP 1 AND + ; : XALIGN ( --- ) XHERE NIP 1 AND XDP +! ; : X>"BUF ( --- "BUF ) 2R> 2R@SWAP 2DUP C@L 1+ DUP XEVEN R> + >R ?CS: "BUF ROT CMOVEL 2>R "BUF ; : (") ( -- addr len ) 2R@SWAP @L COUNT R> 2+ >R ; : (X") ( -- addr len ) X>"BUF COUNT ; : (.") ( -- ) 2R@SWAP 2DUP C@L >R 1+ R@ EXTYPE R> 1+ XEVEN R> + >R ; : ," ( --- ) ASCII " PARSE TUCK 'WORD PLACE 1+ ALLOT ; : X," ( -- ) ASCII " PARSE 'WORD PLACE ?CS: 'WORD DUP C@ 1+ >R XHERE R@ CMOVEL R> XEVEN XDP +! ; : ." ( -- ) COMPILE (.") X," ; IMMEDIATE : " ( -- ) COMPILE (") HERE X, ," ; IMMEDIATE : "" ( -- ) COMPILE (X") X," ; IMMEDIATE : ">$ ( A1 -- A2 ) DROP 1- ; VARIABLE FENCE : TRIM ( faddr voc-addr -- ) #THREADS 0 DO 2DUP @ BEGIN 2DUP U> NOT WHILE Y@ REPEAT NIP OVER ! 2+ LOOP 2DROP ; : (FRGET) ( code-addr view-addr -- ) DUP FENCE @ U< ABORT" Below fence" ( ca va ) OVER VOC-LINK @ BEGIN 2DUP U< WHILE @ REPEAT DUP VOC-LINK ! ( ca va ca pt ) NIP BEGIN DUP WHILE 2DUP #THREADS 2* - TRIM @ REPEAT DROP YDP ! DUP 1+ @ OVER >BODY + (LIT) TRIM DUP 1+ @ SWAP >BODY + = \ If it's a : def IF DUP >BODY @ XSEG @ + XDPSEG ! \ Set back XHERE too! XDP OFF THEN DP ! ; DEFER WHERE DEFER ?ERROR : (?ERROR) ( adr len f -- ) IF 2>R SP0 @ SP! PRINTING OFF 2R> SPACE TYPE SPACE QUIT ELSE 2DROP THEN ; : (ABORT") ( f -- ) X>"BUF COUNT ROT ?ERROR ; : ABORT" ( -- ) COMPILE (ABORT") X," ; IMMEDIATE : ABORT ( -- ) TRUE ABORT" " ; : FORGET ( -- ) BL WORD ?UPPERCASE DUP CURRENT @ HASH @ (FIND) 0= ?MISSING DUP >VIEW (FRGET) ; : ?CONDITION ( f -- ) NOT ABORT" Conditionals Wrong" ; : >MARK ( -- addr ) XHERE NIP 0 X, ; : >RESOLVE ( addr -- ) XHERE -ROT SWAP !L ; : MARK ( -- f addr ) TRUE >MARK ; : ?>RESOLVE ( 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 ?UNTIL ?RESOLVE ; IMMEDIATE : IF COMPILE ?BRANCH ?>MARK ; IMMEDIATE : ELSE COMPILE BRANCH ?>MARK 2SWAP ?>RESOLVE ; IMMEDIATE : WHILE COMPILE ?WHILE ?>MARK ; IMMEDIATE : ,VIEW ( -- ) LOADLINE @ Y, ; : "HEADER ( STR --- ) #HEADSEGS YHERE U16/ 6 + < ABORT" Out of HEAD memory!" #LISTSEGS XHERE DROP XSEG @ - 6 + < ABORT" Out of LIST memory!" WARNING @ IF DUP FIND NIP IF DUP CR COUNT TYPE ." isn't unique " THEN THEN ( str ) ALIGN YHERE 2- Y@ CNHASH HERE CNHASH <> IF YHERE HERE CNHASH DUP Y@ ROT MIN SWAP Y! ( >NAME hash entry ) THEN ,VIEW YHERE OVER CURRENT @ HASH DUP @ Y, ( link ) ! ( current ) YHERE LAST ! ( remember nfa ) YHERE ?CS: ROT DUP C@ WIDTH @ MIN 1+ >R ( yh cs str ) YHERE YS: R@ CMOVEL ( copy str ) R> YDP +! ALIGN ( nam ) 128 SWAP YCSET 128 YHERE 1- YCSET ( delimiter Bits ) HERE Y, ( CFA in header ) YHERE HERE CNHASH 2+ Y! ( valid stopper in next n hash entry) ; : ,CALL 232 C, 0 HERE 2+ - , ; \ Compiles addr 0000 !!!! : ,JUMP 233 C, 0 HERE 2+ - , ; :
( | name --- ) BL WORD ?UPPERCASE "HEADER ; DEFER HEADER '
IS HEADER : CREATE ( | name -- ) HEADER ,CALL ;USES >NEXT ,-X : !CSP ( -- ) SP@ CSP ! ; : ?CSP ( -- ) SP@ CSP @ <> ABORT" Stack Changed" ; : HIDE ( -- ) LAST @ DUP N>LINK Y@ SWAP CURRENT @ YHASH ! ; : REVEAL ( -- ) LAST @ DUP N>LINK SWAP CURRENT @ YHASH ! ; : (;USES) ( -- ) 2R> SWAP @L LAST @ NAME> DUP >R 3 + - R> 1+ ! ; : (;CODE) ( -- ) 2R> SWAP @L LAST @ NAME> DUP >R 232 ( CALL ) R@ C! \ Make a CALL not JUMP 3 + - R> 1+ ! ; : DOES> ( -- ) COMPILE (;CODE) HERE X, 232 ( CALL ) C, [ [FORTH] ASSEMBLER DODOES META ] LITERAL HERE 2+ - , XHERE PARAGRAPH + DUP XDPSEG ! XSEG @ - , XDP OFF ; IMMEDIATE VOCABULARY ASSEMBLER DEFER SETASSEM \ Setup for assembly stuff to follow ' NOOP IS SETASSEM : [ ( -- ) STATE OFF ; IMMEDIATE : ;USES ( -- ) ?CSP COMPILE (;USES) [COMPILE] [ REVEAL ASSEMBLER ; IMMEDIATE : ;CODE ( -- ) ?CSP COMPILE (;CODE) HERE X, [COMPILE] [ REVEAL SETASSEM ; IMMEDIATE : (]) ( -- ) STATE ON BEGIN ?STACK DEFINED DUP IF 0> IF EXECUTE ELSE X, THEN ELSE DROP NUMBER DOUBLE? IF [COMPILE] DLITERAL ELSE DROP [COMPILE] LITERAL THEN THEN TRUE DONE? UNTIL ; DEFER ] ' (]) IS ] : MAKEDUMMY ( NAME --- ) HEADER ,JUMP XHERE PARAGRAPH + \ absolute paragraph of new def DUP XDPSEG ! \ set new XHERE segment XSEG @ - , \ compile relative paragraph of def XDP OFF COMPILE UNNEST ;USES NEST ,-X : ANEW ( NAME --- ) >IN @ >R DEFINED NIP R@ >IN ! IF FORGET THEN R> >IN ! MAKEDUMMY ; \ Add if needed : : ( -- ) !CSP CURRENT @ CONTEXT ! HEADER ,JUMP XHERE PARAGRAPH + DUP XDPSEG ! XSEG @ - , XDP OFF HIDE ] ;USES NEST ,-X : ; ( -- ) STATE @ 0= ABORT" Not Compiling!" ?CSP COMPILE UNNEST REVEAL [COMPILE] [ ; IMMEDIATE : RECURSIVE ( -- ) REVEAL ; IMMEDIATE : CONSTANT ( n -- ) CREATE , ;USES DOCONSTANT ,-X : VARIABLE ( -- ) CREATE 0 , ;USES >NEXT ,-X \ not really needed, but pretty. : DEFER ( -- ) CREATE ['] CRASH , ;USES DODEFER ,-X DODEFER RESOLVES : VOCABULARY ( -- ) CREATE #THREADS 0 DO 0 , LOOP HERE VOC-LINK @ , VOC-LINK ! DOES> CONTEXT ! ; RESOLVES : DEFINITIONS ( -- ) CONTEXT @ CURRENT ! ; : 2CONSTANT CREATE , , ( d# -- ) DOES> 2@ ; ( -- d# ) DROP : 2VARIABLE 0 0 2CONSTANT ( -- ) DOES> ; ( -- addr ) DROP : ( -- ) STATE @ IF ] STATE @ NOT IF INTERPRET THEN ELSE INTERPRET THEN ; DEFER RUN ' IS RUN