\ KERNEL2.SEQ More kernel stuff FILES DEFINITIONS VARIABLE KERNEL2.SEQ FORTH DEFINITIONS USER DEFINITIONS VARIABLE TOS ( TOP OF STACK ) VARIABLE ENTRY ( ENTRY POINT, CONTAINS MACHINE CODE ) VARIABLE LINK ( LINK TO NEXT TASK ) VARIABLE ES0 ( INITIAL ES: SEGMENT ) VARIABLE SP0 ( INITIAL PARAMETER STACK ) VARIABLE RP0 ( INITIAL RETURN STACK ) VARIABLE DP ( DICTIONARY POINTER ) 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 PRINTING DEFER EMIT DEFER KEY? DEFER KEY DEFER TYPE DEFER EXTYPE META DEFINITIONS 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 VARIABLE 'TIB ( ADDRESS OF TERMINAL INPUT BUFFER ) VARIABLE WIDTH ( WIDTH OF NAME FIELD ) VARIABLE VOC-LINK ( POINTS TO NEWEST VOCABULARY ) 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 #OUT ( NUMBER OF CHARACTERS EMITTED ) VARIABLE #LINE ( THE NUMBER OF LINES SENT SO FAR ) VARIABLE XDP VARIABLE XDPSEG VARIABLE YDP \ HEADER SEG POINTER VARIABLE YSTART \ HEAD START OFFSET VARIABLE DPSTART \ LIST START OFFSET VARIABLE XSEGLEN VARIABLE XMOVED \ FLAG TO TELL IF LIST HAS BEEN MOVED VARIABLE SSEG \ SEARCH & SCAN SEGMENT VARIABLE SHNDL \ the sequential handl POINTER VARIABLE LOADLINE \ Offset to line we loaded from VARIABLE ERRORLINE \ Last loaded line # 32 CONSTANT BL 8 CONSTANT BS 7 CONSTANT BELL VARIABLE CAPS CODE FILL ( start-addr count char -- ) CLD MOV BX, DS POP AX POP CX POP DI PUSH ES MOV ES, BX REPNZ STOSB POP ES NEXT END-CODE CODE LFILL ( seg start-addr count char -- ) CLD POP AX POP CX POP DI POP BX PUSH ES MOV ES, BX REPNZ STOSB POP ES NEXT END-CODE : ERASE ( addr len -- ) 0 FILL ; : BLANK ( addr len -- ) BL FILL ; CODE COUNT ( addr -- addr+1 len ) POP BX SUB AX, AX MOV AL, 0 [BX] INC BX PUSH BX 1PUSH END-CODE CODE LENGTH ( addr -- addr+2 len ) \ REALLY WORD COUNT POP BX MOV AX, 0 [BX] ADD BX, # 2 PUSH BX 1PUSH END-CODE : MOVE ( from to len -- ) -ROT 2DUP U< IF ROT CMOVE> ELSE ROT CMOVE THEN ; DECIMAL CREATE ATBL \ Uppercase translation table 0 C, 1 C, 2 C, 3 C, 4 C, 5 C, 6 C, 7 C, 8 C, 32 C, 10 C, 11 C, 12 C, 13 C, 14 C, 15 C, 16 C, 17 C, 18 C, 19 C, 20 C, 21 C, 22 C, 23 C, 24 C, 25 C, 26 C, 27 C, 28 C, 29 C, 30 C, 31 C, 32 C, '!' C, '"' C, '#' C, '$' C, '%' C, '&' C, ''' C, '(' C, ')' C, '*' C, '+' C, ',' C, '-' C, '.' C, '/' C, '0' C, '1' C, '2' C, '3' C, '4' C, '5' C, '6' C, '7' C, '8' C, '9' C, ':' C, ';' C, '<' C, '=' C, '>' C, '?' C, '@' C, 'A' C, 'B' C, 'C' C, 'D' C, 'E' C, 'F' C, 'G' C, 'H' C, 'I' C, 'J' C, 'K' C, 'L' C, 'M' C, 'N' C, 'O' C, 'P' C, 'Q' C, 'R' C, 'S' C, 'T' C, 'U' C, 'V' C, 'W' C, 'X' C, 'Y' C, 'Z' C, '[' C, '\' C, ']' C, '^' C, '_' C, '`' C, 'A' C, 'B' C, 'C' C, 'D' C, 'E' C, 'F' C, 'G' C, 'H' C, 'I' C, 'J' C, 'K' C, 'L' C, 'M' C, 'N' C, 'O' C, 'P' C, 'Q' C, 'R' C, 'S' C, 'T' C, 'U' C, 'V' C, 'W' C, 'X' C, 'Y' C, 'Z' C, '{' C, '|' C, '}' C, '~' C, 127 C, \ Characters above 127 are translated to below 127 0 C, 1 C, 2 C, 3 C, 4 C, 5 C, 6 C, 7 C, 8 C, 9 C, 10 C, 11 C, 12 C, 13 C, 14 C, 15 C, 16 C, 17 C, 18 C, 19 C, 20 C, 21 C, 22 C, 23 C, 24 C, 25 C, 26 C, 27 C, 28 C, 29 C, 30 C, 31 C, 32 C, '!' C, '"' C, '#' C, '$' C, '%' C, '&' C, ''' C, '(' C, ')' C, '*' C, '+' C, ',' C, '-' C, '.' C, '/' C, '0' C, '1' C, '2' C, '3' C, '4' C, '5' C, '6' C, '7' C, '8' C, '9' C, ':' C, ';' C, '<' C, '=' C, '>' C, '?' C, '@' C, 'A' C, 'B' C, 'C' C, 'D' C, 'E' C, 'F' C, 'G' C, 'H' C, 'I' C, 'J' C, 'K' C, 'L' C, 'M' C, 'N' C, 'O' C, 'P' C, 'Q' C, 'R' C, 'S' C, 'T' C, 'U' C, 'V' C, 'W' C, 'X' C, 'Y' C, 'Z' C, '[' C, '\' C, ']' C, '^' C, '_' C, '`' C, 'A' C, 'B' C, 'C' C, 'D' C, 'E' C, 'F' C, 'G' C, 'H' C, 'I' C, 'J' C, 'K' C, 'L' C, 'M' C, 'N' C, 'O' C, 'P' C, 'Q' C, 'R' C, 'S' C, 'T' C, 'U' C, 'V' C, 'W' C, 'X' C, 'Y' C, 'Z' C, '{' C, '|' C, '}' C, '~' C, 127 C, CODE UPC ( char -- char' ) POP AX MOV BX, # ATBL XLAT 1PUSH END-CODE CODE UPPER ( addr len -- ) \ convert string to upper case POP CX \ get length POP DI \ and starting address LABEL >UPPER+2 PUSH SI \ save IP MOV DX, ES \ and LIST POINTER MOV BX, DS MOV ES, BX \ set ES to DS MOV SI, DI \ set SI to DI MOV BX, # ATBL \ loadup BX with table CLD \ clear direction flag CX<>0 IF HERE \ get a char and traslate it LODSB XLAT STOSB LOOPNZ \ until all chars are done THEN MOV ES, DX \ restore ES=LIST POP SI \ and SI=IP NEXT END-CODE \ : ?UPPERCASE ( adr -- adr ) \ CAPS @ IF DUP COUNT UPPER THEN ; CODE ?UPPERCASE ( A1 --- A1 ) \ conditionally convert to upper case MOV CX, CAPS \ test CAPS variable CX<>0 IF \ leave if CAPS is not on POP DI PUSH DI \ get a copy of address a1 SUB CX, CX MOV CL, 0 [DI] INC DI \ Addr and Cnt in DI & CX JMP >UPPER+2 \ go translate to upper case THEN NEXT END-CODE CODE HERE ( -- adr ) MOV BX, UP MOV AX, DP [BX] 1PUSH END-CODE \ : PAD ( -- addr ) HERE 80 + ; CODE PAD ( -- adr ) MOV BX, UP MOV AX, DP [BX] ADD AX, # 80 1PUSH END-CODE \ : -TRAILING ( addr len -- addr len' ) \ DUP 0 ?DO 2DUP + 1- C@ BL <> ?LEAVE 1- LOOP ; CODE -TRAILING ( addr len -- addr1 len1 ) POP BX POP DI MOV AL, # 32 BEGIN CMP -1 [DI+BX], AL 0= IF 2SWAP \ compile time correction DEC BX 0= UNTIL THEN PUSH DI PUSH BX NEXT END-CODE CODE COMP ( addr1 addr2 len -- -1 | 0 | 1 ) MOV DX, SI POP CX POP DI POP SI CX<>0 IF PUSH ES MOV ES, SSEG REPZ CMPSB 0<> IF LABEL COMPX 0< IF MOV CX, # -1 ELSE MOV CX, # 1 THEN THEN THEN LABEL NOMORE MOV SI, DX POP ES PUSH CX NEXT END-CODE HEX CODE CAPS-COMP ( addr1 addr2 len -- -1 | 0 | 1 ) MOV DX, SI POP CX POP DI POP SI PUSH ES MOV ES, SSEG BEGIN JCXZ NOMORE MOV AH, 0 [SI] INC SI MOV ES: AL, 0 [DI] INC DI OR AX, # 2020 CMP AH, AL JNE COMPX DEC CX AGAIN END-CODE DECIMAL : COMPARE ( addr1 addr2 len -- -1 | 0 | 1 ) CAPS @ IF CAPS-COMP ELSE COMP THEN ; VARIABLE OSF LABEL FCDOS PUSH SI PUSH BP INC CS: OSF WORD INT 33 DEC CS: OSF WORD POP BP POP SI RET END-CODE CODE XFDOS ( DX CX BX AX ES DS-CX BX AX CY) POP DI POP DS POP AX POP BX POP CX POP DX PUSH ES PUSH DS POP ES PUSH CS MOV DS, DI CALL FCDOS POP DS POP ES MOV DX, # -1 U>= IF XOR DX, DX THEN PUSH CX PUSH BX PUSH AX PUSH DX NEXT END-CODE CODE ?CS: ( -- CS ) PUSH CS NEXT END-CODE CODE ?ES: ( -- CS ) PUSH ES NEXT END-CODE CODE @L ( seg addr --- word ) POP BX POP DS MOV AX, 0 [BX] MOV BX, CS MOV DS, BX 1PUSH END-CODE CODE C@L ( seg addr --- byte ) POP BX POP DS MOV AL, 0 [BX] XOR AH, AH MOV BX, CS MOV DS, BX 1PUSH END-CODE CODE C!L ( byt seg adr ) POP BX POP DS POP AX MOV 0 [BX], AL MOV BX, CS MOV DS, BX NEXT END-CODE CODE !L ( n seg adr -- ) POP BX POP DS POP AX MOV 0 [BX], AX MOV BX, CS MOV DS, BX NEXT END-CODE CODE ( n fun -- m ) POP AX MOV AH, AL POP DX INT 33 SUB AH, AH 1PUSH END-CODE DEFER BDOS ' IS BDOS CODE BDOS2 ( CX DX AX -- CX DX AX ) POP AX POP DX POP CX MOV AH, AL INT 33 PUSH CX PUSH DX PUSH AX NEXT END-CODE : OS2 BDOS2 255 AND ; HEX VARIABLE BIOSCHAR \ Holds the char from BIOS on scan by BIOSKEY? VARIABLE BIOSKEYVAL \ Holds the key value from BIOSKEY CODE BIOSKEY? ( --- f1 ) BEGIN MOV AH, # 1 INT 16 MOV BIOSCHAR AX 0= IF MOV AX, # 0 1PUSH THEN CMP AX, # 0 \ Ignore Control Break keys 0= WHILE MOV AH, # 0 \ That is throw them away INT 16 REPEAT MOV AX, # -1 1PUSH END-CODE CODE BIOSKEY ( --- c1 ) BEGIN MOV AH, # 0 INT 16 CMP AX, # 0 \ Ignore Control BREAK, 00 Hex. 0<> UNTIL MOV BIOSKEYVAL AX 1PUSH END-CODE DECIMAL DEFER KEYFILTER ' NOOP IS KEYFILTER \ Pre-filter keys before passing on. DEFER BGSTUFF ' NOOP IS BGSTUFF \ BACKGROUND STUFF : (KEY?) ( -- f ) BGSTUFF BIOSKEY? ; : (KEY) ( -- CHAR ) BEGIN PAUSE KEY? UNTIL BIOSKEY DUP 127 AND 0= IF FLIP 127 AND 128 OR ELSE 127 AND THEN KEYFILTER ; DEFER OUTPAUSE ( ' PAUSE ) ' NOOP IS OUTPAUSE DEFER CONSOLE CODE CMOVEL ( sseg sptr dseg dptr cnt ) CLD MOV BX, SI POP CX POP DI POP AX POP SI POP DS PUSH ES MOV ES, AX OR CX, CX 0<> IF REPNZ MOVSB THEN POP ES MOV AX, CS MOV DS, AX MOV SI, BX NEXT END-CODE CODE CMOVEL> ( sseg sptr dseg dptr cnt ) STD MOV BX, SI POP CX POP DI POP AX POP SI POP DS PUSH ES MOV ES, AX OR CX, CX 0<> IF DEC CX ADD DI, CX ADD SI, CX INC CX REPNZ MOVSB THEN POP ES MOV AX, CS MOV DS, AX MOV SI, BX CLD NEXT END-CODE HEX 1000 CONSTANT #CODESEGS \ Number of segments needed for CODE. 64k 1000 CONSTANT #LISTSEGS \ Number of segments needed for : definitions. 64k 1000 CONSTANT #HEADSEGS \ Number of segments needed for HEADS. 64K DECIMAL : MEMCHK ( F1 --- ) IF ." Insufficient Memory" 0 0 BDOS THEN ; HEX CODE DEALLOC ( N1 -- F1 ) \ N1 = BLOCK TO DE-ALLOCATE, F1 = 0 IS OK MOV AH, # 49 \ F1 = 9 INVALID BLOCK ADDRESS POP DX PUSH ES MOV ES, DX INT 21 u< if sub ah, ah else mov ax, # 0 then POP ES 1PUSH END-CODE CODE ALLOC ( N1 -- N2 N3 F1 ) \ N1 = SIZE NEEDED, N3 = SEGMENT \ N2 = LARGEST SEGMENT AVAILABLE MOV AH, # 48 \ F1 = 8 NOT ENOUGH MEMORY. POP BX INT 21 PUSH BX PUSH AX u< if sub ah, ah else mov ax, # 0 then 1PUSH END-CODE : MEMSET ( N1 --- F1 ) 0 0 ROT 4A00 ?CS: DUP XFDOS >R 3DROP R> ; : DOSVER 0 30 BDOS 0FF AND ; DEFER CURSORSET ' NOOP IS CURSORSET : SETYSEG ( --- ) \ SETS HEAD SEGMENT + MORE SPACE [ LABEL 'SETYSEG ] ?CS: SSEG ! ?CS: TYPESEG ! XSEGLEN @ XSEG @ + XDPSEG ! XDP OFF DPSTART @ DP ! DOSVER 2 < IF ." Must have DOS 2.x or higher, prefer 3.x" 0 0 BDOS THEN #CODESEGS #LISTSEGS + #HEADSEGS + MEMSET MEMCHK #OUT 0! 18 ( 24 DECIMAL ) #LINE ! CURSORSET ; DECIMAL CODE YHERE ( -- adr ) MOV AX, YDP 1PUSH END-CODE CODE YS: ( W -- YSEG W ) POP AX MOV DX, YSEG 2PUSH END-CODE : YC@ ( yaddr -- char ) YS: C@L ; : YC! ( yaddr -- char ) YS: C!L ; : Y@ ( ad -- n ) YS: @L ; : Y! ( n yaddr -- ) YS: !L ; : Y, ( n -- ) YHERE Y! 2 YDP +! ; : YCSET ( byte yaddr -- ) TUCK YC@ OR SWAP YC! ; : YHASH ( ystr vocaddr -- thread ) SWAP DUP YC@ SWAP 1+ YC@ + #THREADS 1- AND 2* + ; CODE XHERE ( -- seg adr ) MOV AX, XDP MOV DX, XDPSEG 2PUSH END-CODE CODE X, ( n -- ) \ XHERE !L 2 XDP +! POP AX MOV CS: BX, XDP MOV DS, XDPSEG MOV 0 [BX], AX MOV BX, CS MOV DS, BX ADD XDP # 2 WORD NEXT END-CODE CODE XC, ( n -- ) \ XHERE C!L 1 XDP +! POP AX MOV CS: BX, XDP MOV DS, XDPSEG MOV 0 [BX], AL MOV BX, CS MOV DS, BX INC XDP WORD NEXT END-CODE CODE PR-STATUS ( N1 --- F1 ) POP DX \ PRINTER NUMBER MOV AH, # 2 PUSH SI PUSH BP INT 23 POP BP POP SI MOV AL, AH MOV AH, # 0 1PUSH END-CODE HEX \ 90 is printer not busy & printer selected. : ( --- F1 ) 0 PR-STATUS ( 90 AND ) 90 = ; DEFER ?PRINTER.READY ' IS ?PRINTER.READY DECIMAL DEFER CR DEFER PEMIT \ ' (PRINT) IS PEMIT : (EMIT) ( char -- ) PRINTING @ IF DUP PEMIT #OUT DECR THEN CONSOLE ; : CRLF ( -- ) 13 EMIT 10 EMIT #OUT OFF #LINE DUP @ 1+ PRINTING @ 0= IF 24 MIN THEN SWAP ! ; \ : (TYPE) ( addr len -- ) 0 ?DO COUNT EMIT LOOP DROP ; : FEMIT ( C1 --- ) SP@ 1 TYPE DROP ; : SPACE ( -- ) BL EMIT ; CREATE SPCS ( --- A1 ) \ An array of 80 spaces for use by SPACES HEX 2020 DUP , DUP , DUP , DUP , DUP , DUP , DUP , DUP , DUP , DUP , DUP , DUP , DUP , DUP , DUP , DUP , DUP , DUP , DUP , DUP , DUP , DUP , DUP , DUP , DUP , DUP , DUP , DUP , DUP , DUP , DUP , DUP , DUP , DUP , DUP , DUP , DUP , DUP , DUP , , DECIMAL : SPACES ( N --- ) SPCS SWAP 80 MIN 0 MAX TYPE ; : BACKSPACES ( n -- ) 0 ?DO BS EMIT -2 #OUT +! LOOP ; : BEEP ( -- ) BELL (EMIT) #OUT DECR ; : BS-IN ( n c -- 0 | n-1 ) >R DUP IF 1- BS ELSE BELL THEN EMIT #OUT DUP @ 2- 0 MAX SWAP ! R> ; : (DEL-IN) ( n c -- 0 | n-1 ) >R DUP IF 1- #OUT @ BS EMIT SPACE #OUT ! BS ELSE BELL THEN EMIT #OUT DUP @ 2- 0 MAX SWAP ! R> ; DEFER DEL-IN ' (DEL-IN) IS DEL-IN : BACK-UP ( n c -- 0 c ) >R DUP BACKSPACES DUP SPACES BACKSPACES 0 R> ; : RESET-IN ( c -- ) FORTH TRUE ABORT" Reset" ; DEFER RES-IN ' RESET-IN IS RES-IN : P-IN ( c -- c ) PRINTING @ 0= PRINTING ! ; : (ESC-IN) ( C -- ) >R 2DUP + @ EMIT 1+ R> ; DEFER ESC-IN ' (ESC-IN) IS ESC-IN : CR-IN ( m a n c -- m a m C ) >R SPAN ! OVER BL EMIT R> ; : (CHAR) ( a n char -- a n+1 CHAR ) DUP >R 3DUP EMIT + C! 1+ R> ; DEFER CHAR ' (CHAR) IS CHAR DEFER ^CHAR ' CHAR IS ^CHAR : NORM-KEYTABLE EXEC: ^CHAR ^CHAR ^CHAR RES-IN ^CHAR ^CHAR ^CHAR ^CHAR DEL-IN ^CHAR ^CHAR ^CHAR ^CHAR CR-IN ^CHAR ^CHAR P-IN ^CHAR ^CHAR ^CHAR ^CHAR BACK-UP ^CHAR ^CHAR BACK-UP ^CHAR ^CHAR ESC-IN ^CHAR ^CHAR ^CHAR ^CHAR ; DEFER KEYTABLE ' NORM-KEYTABLE IS KEYTABLE \ expect to a buffer that may already contain some data. : NEXPECT ( ADR LEN START -- ) DUP >R IF OVER R@ TYPE THEN DUP SPAN ! SWAP R> ( LEN ADR 0_SOFAR ) BEGIN 2 PICK OVER - ( len adr #so-far #left ) WHILE KEY DUP BL < IF DUP KEYTABLE DROP ELSE DUP 127 = IF DEL-IN ELSE CHAR THEN DROP THEN REPEAT 3DROP ; : EXPECT ( adr len -- ) 0 NEXPECT ; ( len adr 0 ) : TIB ( -- adr ) 'TIB @ ; : QUERY ( -- ) TIB 80 EXPECT SPAN @ #TIB ! >IN OFF ; VARIABLE DISK-ERROR -2 CONSTANT LIMIT LIMIT 10 - CONSTANT FIRST FIRST 10 - CONSTANT INIT-R0 DECIMAL FORTH DEFINITIONS : HEX ( -- ) 16 BASE ! ; : DECIMAL ( -- ) 10 BASE ! ; : OCTAL ( -- ) 8 BASE ! ; DEFER DEFAULT LABEL FAIL SUB AX, AX 1PUSH END-CODE CODE DIGIT ( char base -- n f ) POP DX POP AX PUSH AX SUB AL, # ASCII 0 JB FAIL CMP AL, # 9 > IF CMP AL, # 17 JB FAIL SUB AL, # 7 THEN CMP AL, DL JAE FAIL MOV DL, AL POP AX MOV AX, # TRUE 2PUSH END-CODE : DOUBLE? ( -- f ) DPL @ 1+ 0<> ; : CONVERT ( +d1 adr1 -- +d2 adr2 ) BEGIN 1+ DUP >R C@ BASE @ DIGIT WHILE SWAP BASE @ UM* DROP ROT BASE @ UM* D+ DOUBLE? IF DPL INCR THEN R> REPEAT DROP R> ; : (NUMBER?) ( adr -- d flag ) 0 0 ROT DUP 1+ C@ ASCII - = DUP >R - DPL -1! BEGIN CONVERT DUP C@ ASCII , ASCII / BETWEEN WHILE DPL 0! REPEAT -ROT R> IF DNEGATE THEN ROT C@ BL = ; : NUMBER? ( 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) ( adr -- d# ) NUMBER? NOT ?MISSING ; comment: A simple word to make Forth accept numbers prefixed with $ as Hex numbers. comment; CODE +1=$? ( A1 --- A1 F1 ) \ is second char in a1 a $ ? POP BX PUSH BX MOV AL, 1 [BX] CMP AL, # ASCII $ 0<> IF SUB AX, AX THEN 1PUSH END-CODE CODE +1='? ( A1 --- A1 F1 ) \ is second char in a1 a $ ? POP BX PUSH BX MOV AL, 1 [BX] CMP AL, # ASCII ' 0<> IF SUB AX, AX THEN 1PUSH END-CODE : (NUMBER) ( A1 --- D1 ) \ Prefix with $ for auto HEX base. +1=$? \ $ is for HEX IF DUP >R DUP COUNT 1- 0 MAX >R DUP 1+ SWAP R> CMOVE \ Extract the $. DUP C@ 1- OVER C! \ Shorten count by 1. BL OVER COUNT + C! \ Append a blank to string. BASE @ >R \ Save the base for later restoral. HEX NUMBER? \ Try to convert the number in HEX R> BASE ! \ Restore the BASE. DUP 0= \ If its not a number, restore the $. IF R@ COUNT >R DUP 1+ R> CMOVE> R@ C@ 1+ R@ C! ASCII $ R@ 1+ C! THEN r>drop ELSE +1='? \ recognize ' for ascii IF 2+ C@ 0 TRUE DPL ON ELSE NUMBER? THEN THEN NOT ?MISSING ; DEFER NUMBER : HOLD ( char -- ) HLD DECR HLD @ C! ; : <# ( -- ) PAD HLD ! ; : #> ( d# -- addr len ) 2DROP HLD @ PAD OVER - ; : SIGN ( n1 -- ) 0< IF ASCII - HOLD THEN ; : # ( -- ) BASE @ MU/MOD ROT 9 OVER < IF 7 + THEN ASCII 0 + HOLD ; : #S ( -- ) BEGIN # 2DUP OR 0= UNTIL ; : (U.) ( u -- a l ) 0 <# #S #> ; : U. ( u -- ) (U.) TYPE SPACE ; : U.R ( u l -- ) >R (U.) R> OVER - SPACES TYPE ; : (.) ( n -- a l ) DUP ABS 0 <# #S ROT SIGN #> ; : . ( n -- ) (.) TYPE SPACE ; : .R ( n l -- ) >R (.) R> OVER - SPACES TYPE ; : (UD.) ( ud -- a l ) <# #S #> ; : UD. ( ud -- ) (UD.) TYPE SPACE ; : UD.R ( ud l -- ) >R (UD.) R> OVER - SPACES TYPE ; : (D.) ( d -- a l ) TUCK DABS <# #S ROT SIGN #> ; : D. ( d -- ) (D.) TYPE SPACE ; : D.R ( d l -- ) >R (D.) R> OVER - SPACES TYPE ; LABEL DONE PUSH CX NEXT END-CODE CODE SKIP ( addr len char -- addr' len' ) POP AX POP CX JCXZ DONE POP DI PUSH ES MOV ES, SSEG REPZ SCASB POP ES 0<> IF INC CX DEC DI THEN PUSH DI PUSH CX NEXT END-CODE CODE SCAN ( addr len char -- addr' len' ) POP AX POP CX JCXZ DONE POP DI PUSH ES MOV ES, SSEG MOV BX, CX REPNZ SCASB POP ES 0= IF INC CX DEC DI THEN PUSH DI PUSH CX NEXT END-CODE CODE /STRING ( addr len n -- addr' len' ) POP AX POP BX PUSH BX CMP BX, AX U<= IF XCHG BX, AX \ AX = SMALLER OF AX BX THEN POP BX POP DX ADD DX, AX PUSH DX SUB BX, AX PUSH BX NEXT END-CODE CODE PARSE-WRD ( C1 A1 N1 --- A2 N2 ) POP CX POP DX POP BX PUSH ES \ Save ES for later restoral PUSH CX MOV AX, >IN CMP CX, AX U<= IF MOV AX, CX \ AX = SMALLER OF AX CX THEN ADD DX, AX PUSH DX SUB CX, AX MOV AX, BX CX<>0 IF POP DI MOV DX, DS MOV ES, DX REPZ SCASB 0<> IF INC CX DEC DI THEN PUSH DI THEN POP AX PUSH AX PUSH AX MOV AX, BX CX<>0 IF POP DI REPNZ SCASB 0= IF INC CX DEC DI THEN PUSH DI THEN POP AX POP DX SUB AX, DX POP BX POP ES \ Restore ES PUSH DX PUSH AX CX<>0 IF DEC CX THEN SUB BX, CX MOV >IN BX NEXT END-CODE CODE SOURCE ( -- addr len ) \ TIB #TIB @ MOV DX, 'TIB MOV AX, #TIB 2PUSH END-CODE : PARSE ( char -- addr len ) >R SOURCE >IN @ /STRING OVER SWAP R> SCAN >R OVER - DUP R> 0<> - >IN +! ; DEFER 'WORD ( -- adr ) ' HERE IS 'WORD CODE PLACE-SUFIX.BL ( from cnt to -- to ) POP DX MOV DI, DX POP CX MOV 0 [DI], CL INC DI CLD MOV BX, IP MOV AX, DS POP IP PUSH ES MOV ES, AX REPNZ MOVSB MOV AL, # 32 STOSB MOV IP, BX POP ES PUSH DX NEXT END-CODE : WORD ( char -- addr ) SOURCE PARSE-WRD 'WORD PLACE-SUFIX.BL ;