\ KERNEL4.SEQ Last part of the kernel file, finishes up the compile. \ Link this file into the FILELIST chain. FILES DEFINITIONS VARIABLE KERNEL4.SEQ FORTH DEFINITIONS META IN-META VARIABLE #USER VOCABULARY USER USER DEFINITIONS : ALLOT ( n -- ) #USER +! ; ' CREATE ( avoid recursion: leave address for ,-X in CREATE ) : CREATE ( -- ) [ ,-X ] \ compile addr of CREATE #USER @ , ;USES DOUSER-VARIABLE ,-X : VARIABLE ( -- ) CREATE 2 ALLOT ; : DEFER ( -- ) VARIABLE ;USES DOUSER-DEFER ,-X FORTH DEFINITIONS META IN-META : >IS ( cfa -- data-address ) DUP 1+ @ OVER >BODY + DUP [ [ASSEMBLER] DOUSER-VARIABLE META ] LITERAL = SWAP DUP [ [ASSEMBLER] DOUSER-DEFER META ] LITERAL = SWAP DROP OR IF >BODY @ UP @ + ELSE >BODY THEN ; : (IS) ( cfa --- ) 2R@SWAP @L >IS ! R> 2+ >R ; : IS ( cfa --- ) STATE @ IF COMPILE (IS) ELSE ' >IS ! THEN ; IMMEDIATE : SELECT ( N1 --- ) 14 bdos drop shndl @ >hndle @ -2 = if -1 shndl @ >hndle ! then ; : A: ( --- ) 0 SELECT ; : B: ( --- ) 1 SELECT ; : C: ( --- ) 2 SELECT ; : D: ( --- ) 3 SELECT ; : QUIT ( -- ) SP0 @ 'TIB ! [COMPILE] [ BEGIN BEGIN RP0 @ RP! STATUS QUERY RUN STATE @ NOT UNTIL ." ok" AGAIN ; DEFER BOOT DEFER INITSTUFF ' SEQINIT IS INITSTUFF DEFER SEGSET ' SETYSEG IS SEGSET : WARMSTRT ( --- ) FORTH TRUE ABORT" Warm Start" ; DEFER WARMFUNC ' WARMSTRT IS WARMFUNC : WARM ( -- ) [ LABEL WARMBODY ] WARMFUNC ; : COLD ( -- ) [ LABEL COLDBODY ] SEGSET VMODE.SET INITSTUFF BOOT QUIT ; : START ( -- ) SP0 @ 'TIB ! >IN OFF SPAN OFF #TIB OFF LOADING OFF DEFAULT INTERPRET ; VARIABLE BIOSBKSAVE 0 ,-T VARIABLE DIV0SAVE 0 ,-T HEX CODE RESTORE_VECTORS ( --- ) \ Restores Control BREAK MOV AX, CS MOV DS, AX MOV DX, CS: BIOSBKSAVE MOV DS, CS: BIOSBKSAVE 2+ MOV AX, # 251B INT 21 MOV AX, CS MOV DS, AX MOV DX, CS: DIV0SAVE MOV DS, CS: DIV0SAVE 2+ MOV AX, # 2500 INT 21 MOV AX, CS MOV DS, AX NEXT END-CODE : DIV0STRT ( --- ) TRUE ABORT" Divide OVERFLOW error" ; DEFER DIV0FUNC ' DIV0STRT IS DIV0FUNC DEFER BYEFUNC ' NOOP IS BYEFUNC : BYE ( -- ) BYEFUNC RESTORE_VECTORS CR CR ." Leaving" CR 0 0 BDOS ; : DIVIDE0 ( STATUS_reg, CS, IP, AX, BX, CX, DX, SI, BP --- ) [ LABEL DIV0BODY ] DIV0FUNC BYE ; LABEL DIV0BK STI \ Handle a Divide by 0 interupt PUSH AX PUSH BX PUSH CX PUSH DX PUSH SI PUSH DI PUSH BP MOV AX, # DIV0BODY 5 - JMP AX END-CODE LABEL SETBRK PUSH ES MOV AX, CS MOV DS, AX MOV AX, # AD26 \ Value to restore in >NEXT MOV >NEXT AX \ Restore it MOV AX, # E0FF \ Value to restore in >NEXT + 2 MOV >NEXT 2+ AX \ Restore it MOV DX, # BIOSBK MOV AX, # 251B \ BIOS Break INT 21 MOV DX, # DOSBK MOV AX, # 2523 \ DOS Break INT 21 MOV DX, # 1 MOV AX, # 3301 \ Enable DOS Break INT 21 MOV DX, # DIV0BK MOV AX, # 2500 \ BIOS Break INT 21 POP ES RET END-CODE LABEL SAVEVECTORS ( --- ) \ Just save Divide by 0 & Cntrl Brk for now PUSH ES MOV AX, # 351B \ Get the interupt vector for INT 21 \ BIOS control break vector MOV BIOSBKSAVE BX MOV BIOSBKSAVE 2+ ES \ Save old vector MOV AX, # 3500 \ Get the interupt vector for INT 21 \ DIVIDE by 0 MOV DIV0SAVE BX MOV DIV0SAVE 2+ ES \ Save old vector POP ES RET END-CODE DECIMAL CODE SET_VECTORS ( --- ) CALL SETBRK NEXT END-CODE [FORTH] ASSEMBLER LABEL WORIG HERE ORIGIN 6 + - ORIGIN 4 + !-T ( WARM ENTRY ) MOV AX, # WARMBODY 5 - JMP AX END-CODE LABEL CORIG HERE ORIGIN 3 + - ORIGIN 1+ !-T ( COLD ENTRY ) MOV AX, CS \ move CS to AX MOV DS, AX MOV SS, AX MOV BX, YSTART \ Read YSTART OR BX, BX 0<> \ If not reset, then move stuff IF ADD AX, ' #CODESEGS >BODY \ Add CODE segments and LIST ADD AX, ' #LISTSEGS >BODY \ segments to get to head space. MOV ES, AX \ move head seg to ES MOV CX, YDP MOV DI, # 0 \ Clear DI MOV SI, YSTART \ MOV YSTART to AX OR CX, CX 0<> \ if YDP was not zero (0) IF CLD REPZ MOVSB \ move HEADS to head space CLD THEN MOV YSEG ES \ set YSEG to ES THEN MOV BX, XMOVED \ Has LIST been moved? OR BX, BX 0= \ If not reset, then move stuff IF MOV AX, DS \ move DS to AX ADD AX, ' #CODESEGS >BODY \ Add 64k to get to heads MOV ES, AX \ move head seg to ES MOV CX, XSEGLEN SHL CX, # 1 \ MULTIPLY BY 16 DECIMAL SHL CX, # 1 SHL CX, # 1 SHL CX, # 1 MOV DI, # 0 \ Clear DI MOV SI, DPSTART \ MOV source offset to SI OR CX, CX 0<> \ if DPSTART was not zero (0) IF CLD \ Forward move, NOT backwards this time. REPZ MOVSB \ move LISTS to LIST space CLD THEN MOV XSEG ES \ set XSEG to ES THEN CALL SAVEVECTORS \ Save existing vectors CALL SETBRK \ Install Break vectors MOV AX, ' #CODESEGS >BODY SUB AX, # 1 \ One less than max SHL AX, # 1 SHL AX, # 1 SHL AX, # 1 SHL AX, # 1 MOV ' LIMIT 3 + AX \ LIMIT SUB AX, # 10 MOV ' FIRST 3 + AX \ FIRST = LIMIT - 10h SUB AX, # 10 MOV RP, AX \ RP = FIRST - 10h MOV BX, # RP0 ADD BX, UP MOV 0 [BX], RP \ RP0 = RP SUB AX, # 200 MOV 'TIB AX \ TIB = RP - 200 DECIMAL MOV BX, # SP0 ADD BX, UP MOV 0 [BX], AX \ SP0 = TIB MOV SP, AX \ SP = TIB MOV AX, COLDBODY 2- ADD AX, XSEG MOV ES, AX MOV IP, # 0 NEXT END-CODE IN-META HERE UP !-T ( SET UP USER AREA ) 0 , ( TOS ) 0 , ( ENTRY ) 0 , ( LINK ) 0 , ( ES0 ) INIT-R0 256 - , ( SP0 ) INIT-R0 , ( RP0 ) 0 , ( DP ) ( Must be patched later ) 0 , ( OFFSET ) 10 , ( BASE ) 0 , ( HLD ) FALSE , ( PRINTING ) ' (EMIT) , ( EMIT ) ' (KEY?) , ( KEY? ) ' (KEY) , ( KEY ) ' (TYPE) , ( TYPE ) ' (EXTYPE) , ( EXTYPE ) 0 , 0 , 0 , 0 , 0 , \ room for 10 additional USER variables 0 , 0 , 0 , 0 , 0 , : DEPTH ( -- n ) SP@ SP0 @ SWAP - 2/ ; VARIABLE MAX.S : .S ( -- ) DEPTH 0< ABORT" Stack UNDERFLOW !! " DEPTH ?DUP MAX.S @ 1 < IF 4 MAX.S ! THEN IF DUP ." [" 1 .R ." ]" 0 SWAP 1- MAX.S @ 1- MIN DO I PICK 7 U.R BL FEMIT -1 +LOOP ELSE ." Stack Empty. " THEN ; : .ID ( nfa -- ) DUP 1+ DUP YC@ ROT YC@ 31 AND 0 ?DO DUP 127 AND FEMIT 128 AND IF ASCII _ 128 OR ELSE 1+ DUP YC@ THEN LOOP 2DROP BL FEMIT ; : DUMP ( addr len -- ) 0 DO CR DUP 6 .R SPACE 16 0 DO DUP C@ 3 .R 1+ LOOP 16 +LOOP DROP ; : RECURSE ( -- ) LAST @ NAME> X, ; IMMEDIATE : H. ( N1 --- ) BASE @ >R HEX U. R> BASE ! ; VARIABLE LMARGIN 0 LMARGIN !-T VARIABLE RMARGIN 70 RMARGIN !-T VARIABLE TABSIZE 8 TABSIZE !-T : ?LINE ( n -- ) #OUT @ + RMARGIN @ > IF CR LMARGIN @ SPACES THEN ; : ?CR ( -- ) 0 ?LINE ; : TAB ( --- ) #OUT @ TABSIZE @ MOD TABSIZE @ SWAP - SPACES ; : \ ( --- ) SPAN @ >IN ! ; IMMEDIATE ' (.") :RESOLVES <(.")> ' (") :RESOLVES <(")> ' (;CODE) :RESOLVES <(;CODE)> ' (;USES) :RESOLVES <(;USES)> ' (IS) :RESOLVES <(IS)> ' (ABORT") :RESOLVES <(ABORT")> [ASSEMBLER] >NEXT META RESOLVES [ASSEMBLER] DOUSER-DEFER META RESOLVES [ASSEMBLER] DOUSER-VARIABLE META RESOLVES ' DEFINITIONS :RESOLVES DEFINITIONS ' [ :RESOLVES [ ' ?MISSING :RESOLVES ?MISSING ' QUIT :RESOLVES QUIT ' .ID :RESOLVES .ID \ Fill in some deferred words ' CRLF IS CR ' NOOP IS WHERE ' CR IS STATUS ' START IS BOOT ' (NUMBER) IS NUMBER ' (?ERROR) IS ?ERROR ' (PRINT) IS PEMIT ' (CONSOLE) IS CONSOLE ' FORTH >BODY-T CURRENT !-T ' FORTH >BODY-T CONTEXT !-T HERE-T DP UP @-T + !-T ( INIT USER DP ) #USER-T @ #USER !-T ( INIT USER VAR COUNT ) TRUE CAPS !-T ( SET TO IGNORE CASE ) TRUE WARNING !-T ( SET TO ISSUE WARNINGS ) 31 WIDTH !-T ( 31 CHARACTER NAMES ) VOC-LINK-T @ VOC-LINK !-T ( INIT VOC-LINK ) CR .( Unresolved references: ) CR .UNRESOLVED ?NEWPAGE 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. META 256 THERE \ start addr SVXSEG DPSTART !-T HERE-X DROP 1+ 0 XS: DROP - XSEGLEN !-T CR .( CODE space used: ) HERE-T U. CR .( LIST space used: ) HERE-X SWAP 0 XS: DROP - 16 * + U. CR .( HEAD space used: ) HERE-Y U. HERE-X DROP 1+ 0 XS: DROP - DUP 16 * ALLOT-T DROP \ XDPSEG ( UP @-T + ) !-T 0 XDP ( UP @-T + ) !-T SVYSEG DUP YSTART !-T 0 XMOVED !-T HERE-Y + HERE-Y YDP ( UP @-T + ) !-T DUP THERE ONLY FORTH ALSO SP@ SWAP - CR .( Free Symbol Table bytes: ) U. ONLY FORTH ALSO .COMPSTAT ( A1 N1 --- ) ZSAVE KERNEL.COM FORTH CR .( Now type EXTEND at the DOS prompt.) CR