Programmer 7500

home *** CD-ROM | disk | FTP | other *** search

/ Programmer 7500 / MAX_PROGRAMMERS.iso / CLIPPER / MISC / FFA.ZIP / KERNEL2.SEQ < prev next >

Wrap

Text File | 1988-01-06 | 27.6 KB | 798 lines

\ 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 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 VARIABLE YDP ( HEADER SEG POINTER ) DEFER EMIT DEFER KEY? DEFER KEY DEFER TYPE VARIABLE XDP 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 YSTART \ HEAD START OFFSET VARIABLE XSTART \ LIST START OFFSET VARIABLE XMOVED \ FLAG TO TELL IF LIST HAS BEEN MOVED VARIABLE YSEG \ HEAD SEGMENT VARIABLE XSEG \ BODY SEGMENT 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] INC BX INC BX 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 LABEL >UPPER POP CX \ get length POP DI \ and starting address PUSH SI \ save IP PUSH ES \ and LIST POINTER MOV DX, DS MOV ES, DX \ set ES to DS MOV SI, DI \ set SI to DI MOV BX, # ATBL \ loadup BX with table CLD \ clear direction flag OR CX, CX \ test length not zero 0<> IF HERE \ get a char and traslate it LODSB XLAT STOSB LOOPNZ \ until all chars are done THEN POP ES \ 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 AX, CAPS \ test CAPS variable OR AX, AX 0= IF \ leave if CAPS is not on NEXT THEN \ it is is, then do COUNT POP BX PUSH BX \ get a copy of address a1 SUB AX, AX MOV AL, 0 [BX] INC BX PUSH BX \ push a1+1 PUSH AX \ and count JMP >UPPER \ go translate to upper case END-CODE CODE <HERE> ( -- adr ) MOV BX, UP MOV AX, DP [BX] 1PUSH END-CODE DEFER HERE ' <HERE> IS HERE : PAD ( -- addr ) HERE 80 + ; : -TRAILING ( addr len -- addr len' ) DUP 0 ?DO 2DUP + 1- C@ BL <> ?LEAVE 1- LOOP ; 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 <BDOS> ( n fun -- m ) POP AX MOV AH, AL POP DX INT 33 SUB AH, AH 1PUSH END-CODE DEFER BDOS ' <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 ) MOV AH, # 1 INT 16 MOV BIOSCHAR AX 0= IF MOV AX, # 0 ELSE MOV AX, # -1 THEN 1PUSH END-CODE CODE BIOSKEY ( --- c1 ) MOV AH, # 0 INT 16 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 : (CONSOLE) ( char -- ) OUTPAUSE 6 BDOS DROP #OUT INCR PRINTING @ 0= IF #OUT @ 79 > \ if at right edge IF #OUT OFF \ fix counters #LINE @ 1+ 24 MIN #LINE ! THEN THEN ; 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 C00 CONSTANT #HEADSEGS \ Number of segments needed for HEADS. 48k 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 ; : SETYSEG ( --- ) \ SETS HEAD SEGMENT + MORE SPACE [ LABEL 'SETYSEG ] ?CS: SSEG ! ?ES: XSEG ! XSTART @ 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 ! ; DECIMAL CODE YHERE ( -- adr ) MOV BX, UP MOV AX, YDP [BX] 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@ + \ **** 1+ YC@ #THREADS 1- AND 2* + ; CODE XHERE ( -- adr ) MOV BX, UP MOV AX, XDP [BX] 1PUSH END-CODE CODE XS: ( W -- XSEG W ) POP AX MOV DX, XSEG 2PUSH END-CODE : XC@ ( xaddr -- char ) XS: C@L ; : XC! ( xaddr -- char ) XS: C!L ; : X@ ( ad -- n ) XS: @L ; : X! ( n xaddr -- ) XS: !L ; : X, ( n -- ) XHERE X! 2 XDP +! ; : XC, ( n -- ) XHERE XC! 1 XDP +! ; 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. : ?PRINTER.READY ( --- F1 ) 0 PR-STATUS ( 90 AND ) 90 = ; DECIMAL : (PRINT) ( char -- ) BEGIN OUTPAUSE ?PRINTER.READY UNTIL 5 BDOS DROP #OUT INCR ; 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 ; : SPACES ( n -- ) 0 MAX 0 ?DO SPACE LOOP ; : 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 VARIABLE KEYTBL ( XHERE ) HERE-X ] ^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 [ CONSTANT NORM-KEYTBL : EXPECT ( adr len -- ) DUP SPAN ! SWAP 0 ( len adr 0 ) BEGIN 2 PICK OVER - ( len adr #so-far #left ) WHILE KEY DUP BL < IF DUP 2* KEYTBL @ + XPERFORM DROP ELSE DUP 127 = IF DEL-IN ELSE CHAR THEN DROP THEN REPEAT 3DROP ; : 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 <= 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 AX DEC RP DEC RP MOV 0 [RP], AX PUSH CX MOV AX, >IN CMP CX, AX <= IF MOV AX, CX \ AX = SMALLER OF AX CX THEN ADD DX, AX PUSH DX SUB CX, AX MOV AX, 0 [RP] CX<>0 IF POP DI MOV DX, DS PUSH ES MOV ES, DX REPZ SCASB POP ES 0<> IF INC CX DEC DI THEN PUSH DI THEN POP AX PUSH AX PUSH AX MOV AX, 0 [RP] INC RP INC RP CX<>0 IF POP DI MOV DX, DS PUSH ES MOV ES, DX MOV BX, CX REPNZ SCASB POP ES 0= IF INC CX DEC DI THEN PUSH DI THEN POP AX POP BX SUB AX, BX POP DX XCHG DX, BX PUSH DX PUSH AX MOV AX, CX OR AX, AX 0<> IF ADD AX, # TRUE THEN SUB BX, AX MOV >IN BX NEXT END-CODE : (SOURCE) ( -- addr len ) TIB #TIB @ ; DEFER SOURCE : 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 SUFIX.BL ( A1 -- A1 ) POP BX PUSH BX SUB AX, AX MOV AL, 0 [BX] ADD BX, AX MOV 1 [BX], # 32 NEXT END-CODE : WORD ( char -- addr ) SOURCE PARSE-WRD 'WORD PLACE 'WORD SUFIX.BL ;