ProfitPress Mega CDROM2 Shareware Freeware (MSDOS)(1992)(Eng)

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

/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / PROG / MISC / FPC355_5.ZIP / TCOM96.ZIP / TCOM96 / COMPILER / LIB96.SEQ < prev next >

Wrap

Text File | 1990-10-16 | 61.7 KB | 1,947 lines

\ LIBRARY.SEQ Target Library Source by Tom Zimmer \ Version for 80c196 by Mike Mayo \ *************************************************************************** \ Target specific words used by the compiler to complete compilation of \ the the various types of library and target definitions. These words \ will need to be re-written when a new traget is being written. \ *************************************************************************** \ Target Library words \ *************************************************************************** >LIBRARY TARGET DEFINITIONS \ *************************************************************************** \ This macro puts a literal number on the data stack. The instructon \ sequence used is not optimal, but is likely to be optimized later by the \ automatic SAVE_BX optimizer. MACRO (LIT) ( n1 -- ) \ Special macro to compile an inline number SAVE_TTOS \ to the stack. [FORTH] HERE-T IMM-HERE ! [ASM96] LD TTOS # swap A; END-MACRO NO-INTERPRET ' (LIT) >EXECUTE IS COMP_SINGLE \ link into number compiler CODE EXEC: ( n1 -- ) \ execute the n-th CALL following EXEC: \ MUST be followed by CALL's, not MACROS LD W0 TTOS SHL W0 # 1 ADD W0 TTOS \ n1 * 3 ADD W0 []+ SP \ POP and add the return address INC W0 \ W0 now points to the CALL address LOAD_TTOS LDB W2 []+ W0 LDB W3 []+ W0 ADD W0 W2 BR[] W0 \ jump where the CALL instruction would go END-CODE NO-INTERPRET CODE BOUNDS ( n1 n2 --- n3 n4 ) \ Calculate limits used in DO-loop LD W0 [] PSP ADD TTOS W0 ST TTOS [] PSP LD TTOS W0 RET END-CODE NO-INTERPRET MACRO ?EXIT ( f1 -- ) \ If boolean f1 is true, exit from definition. LD W0 TTOS LD TTOS []+ PSP OR W0 W0 [ASM96] 0<> IF RET THEN END-MACRO NO-INTERPRET MACRO EXIT ( -- ) \ Terminate a high-level definition RET END-MACRO NO-INTERPRET MACRO BEGIN ( -- ) +BR# $:| END-MACRO NO-INTERPRET MACRO AGAIN ( -- ) \ an unconditional branch LJMP -BR# DUP $ 01LAB END-MACRO NO-INTERPRET MACRO IF ( f -- ) \ branch if flag is zero LD W0 TTOS LOAD_TTOS OR W0 W0 [ASM96] JNE here 5 + A; \ branch around JMP LJMP +BR# $ A; [FORTH] [ASM96] END-MACRO NO-INTERPRET TARGET ' IF ALIAS WHILE ( f1 -- ) MACRO ELSE ( -- ) LJMP +BR# $ A; BR#SWAP -BR# DUP $:| 01LAB A; END-MACRO NO-INTERPRET MACRO THEN ( -- ) \ resolve branch -BR# DUP $:| 01LAB A; END-MACRO NO-INTERPRET ' THEN ALIAS ENDIF FORTH >FORTH MACRO REPEAT ( -- ) BR#SWAP LJMP -BR# DUP $ 01LAB -BR# DUP $:| 01LAB END-MACRO NO-INTERPRET MACRO UNTIL ( f1 -- ) LD W0 TTOS LD TTOS []+ PSP OR W0 W0 JNE here 5 + A; \ branch around JMP LJMP -BR# DUP $ 01LAB A; END-MACRO NO-INTERPRET MACRO FOR ( n1 -- ) PUSH TTOS LOAD_TTOS +BR# $:| END-MACRO NO-INTERPRET MACRO NEXT ( -- ) POP W0 OR W0 W0 0<> IF DEC W0 PUSH W0 LJMP -BR# DUP $ 01LAB THEN END-MACRO NO-INTERPRET MACRO UNDO ( --- ) ADD SP # 4 END-MACRO NO-INTERPRET MACRO DO ( l i -- ) [FORTH] ?DOING OFF [ASM96] LD W0 []+ PSP ADD W0 # $8000 PUSH W0 SUB TTOS W0 PUSH TTOS LOAD_TTOS +BR# $:| END-MACRO NO-INTERPRET MACRO (LOOP) ( -- ) LD W0 [] SP INC W0 ST W0 [] SP JV here 5 + A; \ branch around JMP LJMP -BR# DUP $ 01LAB A; END-MACRO NO-INTERPRET MACRO (+LOOP) ( n -- ) ADD TTOS [] SP ST TTOS [] SP LD TTOS []+ PSP JV here 5 + A; \ branch around JMP JMP -BR# DUP $ 01LAB A; END-MACRO NO-INTERPRET MACRO DO? ( -- ) -BR# DUP $:| 01LAB [FORTH] ?DOING OFF END-MACRO NO-INTERPRET MACRO LEAVE? ( -- ) 20 DUP $:| 01LAB [FORTH] ?LEAVING DECR END-MACRO NO-INTERPRET FORTH >FORTH : %LOOP ( -- ) ['] (LOOP) >EXECUTE EXECUTE [FORTH] ?LEAVING @ IF ['] LEAVE? >EXECUTE EXECUTE THEN [TARGET] ['] UNDO >EXECUTE EXECUTE [FORTH] ?DOING @ IF ['] DO? >EXECUTE EXECUTE THEN [TARGET] ; FORTH : LOOP ( -- ) [FORTH] ?LIB IF COMPILE %LOOP ELSE %LOOP THEN [TARGET] ; IMMEDIATE FORTH : %+LOOP ( -- ) ['] (+LOOP) >EXECUTE EXECUTE [FORTH] ?LEAVING @ IF ['] LEAVE? >EXECUTE EXECUTE THEN [TARGET] ['] UNDO >EXECUTE EXECUTE [FORTH] ?DOING @ IF ['] DO? >EXECUTE EXECUTE THEN [TARGET] ; FORTH : +LOOP ( -- ) [FORTH] ?LIB IF COMPILE %+LOOP ELSE %+LOOP THEN [TARGET] ; IMMEDIATE TARGET >LIBRARY MACRO LEAVE ( -- ) [FORTH] ?LEAVING INCR [ASM96] LJMP 20 $ END-MACRO NO-INTERPRET MACRO ?LEAVE ( f -- ) [FORTH] ?LEAVING INCR [ASM96] LD W0 TTOS LOAD_TTOS OR W0 W0 JE here 5 + A; \ branch around JMP JMP 20 $ A; END-MACRO NO-INTERPRET MACRO I ( -- n ) SAVE_TTOS LD TTOS [] SP ADD TTOS [I] 2 SP END-MACRO NO-INTERPRET MACRO J ( -- n ) SAVE_TTOS LD TTOS [I] 4 SP ADD TTOS [I] 6 SP END-MACRO NO-INTERPRET MACRO K ( -- n ) SAVE_TTOS LD TTOS [I] 8 SP ADD TTOS [I] 10 SP END-MACRO NO-INTERPRET MACRO @ ( addr -- n ) ld ttos [] ttos END-MACRO EXECUTES> @ ' @ >EXECUTE IS COMP_FETCH \ link into compiler MACRO ! ( n addr -- ) LD W0 []+ PSP ST W0 [] TTOS LOAD_TTOS END-MACRO EXECUTES> ! ' ! >EXECUTE IS COMP_STORE \ link to compiler MACRO %SAVE>R ( a1 -- ) LD W0 [] TTOS PUSH W0 LOAD_TTOS END-MACRO NO-INTERPRET ' %SAVE>R >EXECUTE IS COMP_SAVE MACRO C@ ( addr -- char ) LDB TTOS [] TTOS CLRB TTOSH END-MACRO EXECUTES> C@ MACRO C! ( char addr -- ) LD W0 []+ PSP STB W0 [] TTOS LOAD_TTOS END-MACRO EXECUTES> C! comment: ICODE CMOVE ( from to count -- ) MOV CX, BX LODSW MOV DI, AX LODSW MOV BX, SI MOV SI, AX MOV DX, ES MOV AX, DS MOV ES, AX REPNZ MOVSB MOV SI, BX MOV ES, DX LOAD_TTOS RET END-ICODE ICODE CMOVE> ( from to count -- ) MOV CX, BX DEC CX LODSW MOV DI, AX LODSW MOV BX, SI MOV SI, AX ADD DI, CX ADD IP, CX INC CX MOV DX, ES MOV AX, DS MOV ES, AX STD REPNZ MOVSB CLD MOV SI, BX MOV ES, DX LOAD_TTOS RET END-ICODE ICODE COMP ( addr1 addr2 len -- -1 | 0 | 1 ) [ASM96] XCHG SI, SP MOV DX, SI MOV CX, BX POP DI POP SI CX<>0 IF PUSH ES MOV AX, DS MOV ES, AX REPZ CMPSB 0<> IF 0< IF MOV CX, # -1 ELSE MOV CX, # 1 THEN THEN POP ES THEN MOV SI, DX MOV BX, CX XCHG SI, SP RET END-ICODE ICODE CAPS-COMP ( addr1 addr2 len -- -1 | 0 | 1 ) [ASM96] XCHG SI, SP MOV DX, SI MOV CX, BX POP DI POP SI BEGIN JCXZ 0 $ MOV AH, 0 [SI] INC SI MOV AL, 0 [DI] INC DI OR AX, # $02020 CMP AH, AL JNE 1 $ DEC CX AGAIN 1 $: 0< IF MOV CX, # -1 ELSE MOV CX, # 1 THEN 0 $: MOV SI, DX MOV BX, CX XCHG SI, SP RET END-ICODE ICODE PLACE ( from cnt to -- ) MOV DI, BX LODSW MOV CX, AX LODSW XCHG AX, SI MOV 0 [DI], CL INC DI CLD MOV DX, ES MOV BX, DS MOV ES, BX REPNZ MOVSB MOV SI, AX MOV ES, DX LOAD_TTOS RET END-ICODE ICODE +PLACE ( from cnt to -- ) \ append text to counted string MOV DI, BX LODSW MOV CX, AX LODSW PUSH ES XCHG AX, SI SUB DX, DX MOV DL, 0 [DI] \ pick up current length ADD 0 [DI], CL \ adj current length plus cnt INC DI \ step to text start ADD DI, DX \ adjust to current text end CLD MOV BX, DS MOV ES, BX REPNZ MOVSB \ append the text MOV SI, AX POP ES LOAD_TTOS RET END-ICODE MACRO TIB ( -- a1 ) \ Terminal Input Buffer address above stack SAVE_BX MOV BX, 'TIB END-MACRO EXECUTES> TIB MACRO DEPTH ( -- n1 ) SAVE_TTOS LD TTOS PSP SUB TTOS PSP0 SHR TTOS # 1 END-MACRO EXECUTES> DEPTH comment; MACRO SP@ ( -- n ) SAVE_TTOS LD TTOS PSP END-MACRO NO-INTERPRET MACRO SP! ( n -- ) LD PSP TTOS END-MACRO NO-INTERPRET MACRO RP@ ( -- addr ) SAVE_TTOS LD TTOS SP END-MACRO NO-INTERPRET MACRO RP! ( n -- ) LD SP TTOS LOAD_TTOS END-MACRO NO-INTERPRET MACRO DROP ( n1 -- ) LOAD_TTOS END-MACRO EXECUTES> DROP MACRO DUP ( n1 -- n1 n1 ) SAVE_TTOS END-MACRO EXECUTES> DUP MACRO SWAP ( n1 n2 -- n2 n1 ) LD W0 [] PSP ST TTOS [] PSP LD TTOS W0 END-MACRO EXECUTES> SWAP MACRO OVER ( n1 n2 -- n1 n2 n1 ) SAVE_TTOS LD TTOS [I] 2 PSP END-MACRO EXECUTES> OVER MACRO PLUCK ( n1 n2 n3 --- n1 n2 n3 n1 ) SAVE_TTOS LD TTOS [I] 4 PSP END-MACRO NO-INTERPRET CODE TUCK ( n1 n2 -- n2 n1 n2 ) LD W0 [] PSP SUB PSP # 2 ST W0 [] PSP ST TTOS [I] 2 PSP RET END-CODE EXECUTES> TUCK MACRO NIP ( n1 n2 -- n2 ) ADD PSP # 2 END-MACRO EXECUTES> NIP CODE ROT ( n1 n2 n3 --- n2 n3 n1 ) LD W0 [I] 2 PSP \ get n1 LD W2 [] PSP \ get n2 ST TTOS [] PSP \ store n3 ST W2 [I] 2 PSP \ store n2 LD TTOS W0 \ store n1 RET END-CODE EXECUTES> ROT CODE -ROT ( n1 n2 n3 --- n3 n1 n2 ) LD W0 [I] 2 PSP \ get n1 LD W2 [] PSP \ get n2 ST TTOS [I] 2 PSP \ store n3 ST W0 [] PSP \ store n1 LD TTOS W0 \ store n2 RET END-CODE EXECUTES> -ROT MACRO FLIP ( n1 -- n2 ) LD W0 TTOS LDB TTOS W1 LDB TTOSH W0 END-MACRO EXECUTES> FLIP CODE SPLIT ( n1 --- n2 n3 ) LD W0 TTOS CLR TTOSH SAVE_TTOS LDB TTOS W1 RET END-CODE EXECUTES> SPLIT MACRO ?DUP ( n1 -- [n1] n1 ) OR TTOS TTOS [ASM96] 0<> IF SAVE_TTOS THEN END-MACRO EXECUTES> ?DUP MACRO R> ( -- n ) SAVE_TTOS POP TTOS END-MACRO NO-INTERPRET IMACRO R>DROP ( --- ) ADD SP # 2 END-IMACRO IMACRO DUP>R ( n1 --- n1 ) PUSH TTOS END-IMACRO IMACRO >R ( n -- ) PUSH TTOS LOAD_TTOS END-IMACRO IMACRO 2R> ( -- n1 n2 ) SAVE_TTOS POP TTOS SAVE_TTOS POP TTOS END-IMACRO IMACRO 2>R ( n1 n2 -- ) PUSH TTOS LOAD_TTOS PUSH TTOS LOAD_TTOS END-IMACRO IMACRO R@ ( -- n ) SAVE_TTOS LD TTOS [] SP END-IMACRO IMACRO 2R@ ( -- n1 n2 ) SAVE_TTOS LD TTOS [] SP SAVE_TTOS LD TTOS [I] 2 SP END-IMACRO MACRO PICK ( nm ... n2 n1 k -- nm ... n2 n1 nk ) SHL TTOS # 1 ADD TTOS PSP LD TTOS [I] -2 TTOS END-MACRO NO-INTERPRET IMACRO RPICK ( nm ... n2 n1 k -- nm ... n2 n1 nk ) SHL TTOS # 1 ADD TTOS SP LD TTOS [I] -2 TTOS END-IMACRO MACRO AND ( n1 n2 -- n3 ) AND TTOS []+ PSP END-MACRO EXECUTES> AND MACRO OR ( n1 n2 -- n3 ) OR TTOS []+ PSP END-MACRO EXECUTES> OR MACRO NOT ( n -- n' ) NOT TTOS END-MACRO EXECUTES> NOT IMACRO CSET ( b addr -- ) LDB W0 []+ PSP ORB W0 [] TTOS STB W0 [] TTOS LOAD_TTOS END-IMACRO IMACRO CRESET ( b addr -- ) LDB W0 []+ PSP NOTB W0 ANDB W0 [] TTOS STB W0 [] TTOS LOAD_TTOS END-IMACRO IMACRO CTOGGLE ( b addr -- ) LDB W0 [] TTOS XORB W0 []+ PSP STB W0 [] TTOS LOAD_TTOS END-IMACRO MACRO ON ( addr -- ) LD W0 # $0FFFF ST W0 [] TTOS LOAD_TTOS END-MACRO NO-INTERPRET ' ON >EXECUTE IS COMP_ON \ link to compiler MACRO OFF ( addr -- ) ST 0 [] TTOS LOAD_TTOS END-MACRO NO-INTERPRET ' OFF >EXECUTE IS COMP_OFF \ link to compiler MACRO INCR ( addr --- ) LD W0 [] TTOS INC W0 ST W0 [] TTOS LOAD_TTOS END-MACRO NO-INTERPRET ' INCR >EXECUTE IS COMP_INCR \ link to compiler MACRO DECR ( addr --- ) LD W0 [] TTOS DEC W0 ST W0 [] TTOS LOAD_TTOS END-MACRO NO-INTERPRET ' DECR >EXECUTE IS COMP_DECR \ link to compiler MACRO + ( n1 n2 -- sum ) ADD TTOS []+ PSP END-MACRO EXECUTES> + MACRO NEGATE ( n -- n' ) NEG TTOS END-MACRO EXECUTES> NEGATE MACRO - ( n1 n2 -- n1-n2 ) SUB TTOS []+ PSP NEG TTOS END-MACRO EXECUTES> - MACRO ABS ( n1 -- n2 ) LDBSE W0 TTOSH \ get sign of TTOS in W1 LDB W0 W1 \ and W0 XOR TTOS W0 \ complement TTOS if negative SUB TTOS W0 \ and add 1 if TTOS was negative END-MACRO EXECUTES> ABS comment: ICODE D+! ( d addr -- ) XCHG SI, SP POP AX POP DX ADD 2 [BX], DX ADC 0 [BX], AX POP BX XCHG SI, SP RET END-ICODE MACRO +! ( n addr -- ) [FORTH] IMM/ABS_OPT ?DUP IF 0< IF [ASM96] ADD ( xxxx ) BX [FORTH] ELSE [ASM96] MOV DI, ( xxxx ) ADD 0 [DI], BX [FORTH] THEN ELSE [ASM96] LODSW ADD 0 [BX], AX [FORTH] THEN LOAD_TTOS [TARGET] END-MACRO NO-INTERPRET ' +! >EXECUTE IS COMP_PSTORE \ link to compiler MACRO C+! ( n addr -- ) [FORTH] IMM/ABS_OPT ?DUP IF 0< IF [ASM96] ADD ( xxxx ) BL [FORTH] ELSE [ASM96] MOV DI, ( xxxx ) ADD 0 [DI], BL [FORTH] THEN ELSE [ASM96] LODSW ADD 0 [BX], AL [FORTH] THEN LOAD_TTOS END-MACRO NO-INTERPRET comment; MACRO 2* ( n -- 2*n ) SHL ttos # 1 END-MACRO EXECUTES> 2* MACRO 4* ( n -- 2*n ) SHL ttos # 1 SHL ttos # 1 END-MACRO NO-INTERPRET MACRO 2/ ( n -- n/2 ) SHRA TTOS # 1 END-MACRO EXECUTES> 2/ MACRO U2/ ( u -- u/2 ) SHR TTOS # 1 END-MACRO EXECUTES> U2/ ICODE U16/ ( u -- u/16 ) SHR TTOS # 1 SHR TTOS # 1 SHR TTOS # 1 SHR TTOS # 1 RET END-ICODE ICODE U8/ ( u -- u/8 ) SHR TTOS # 1 SHR TTOS # 1 SHR TTOS # 1 RET END-ICODE ICODE 8* ( n -- 8*n ) SHL TTOS # 1 SHL TTOS # 1 SHL TTOS # 1 RET END-ICODE MACRO 1+ ( n1 --- n2 ) INC TTOS END-MACRO EXECUTES> 1+ MACRO 2+ ( n1 --- n2 ) ADD TTOS # 2 END-MACRO EXECUTES> 2+ MACRO 1- ( n1 --- n2 ) DEC TTOS END-MACRO EXECUTES> 1- MACRO 2- ( n1 --- n2 ) SUB TTOS # 2 END-MACRO EXECUTES> 2- comment: ICODE UM* ( n1 n2 -- d ) MOV AX, 0 [SI] MUL BX MOV 0 [SI], AX XCHG BX, DX RET END-ICODE comment; MACRO * ( n1 n2 -- n3 ) \ LD W0 []+ PSP \ CLR W2 \ MUL W0 TTOS \ CLR TTOS+ CLR W2 MUL W0 <-- TTOS []+ PSP LD TTOS W0 END-MACRO EXECUTES> * comment: : U*D ( n1 n2 -- d ) UM* ; NO-INTERPRET ICODE UM/MOD ( ud un -- URemainder UQuotient ) XCHG SI, SP POP DX POP AX CMP DX, BX [ASM96] U>= IF \ divide by zero? MOV AX, # -1 MOV DX, AX PUSH DX MOV BX, AX XCHG SI, SP RET THEN DIV BX PUSH DX MOV BX, AX XCHG SI, SP RET END-ICODE COMMENT; MACRO 0= ( n -- f ) SUB TTOS # 1 SUBC TTOS TTOS END-MACRO EXECUTES> 0= MACRO 0< ( n -- f ) BITSET TTOSH 7 IF LD TTOS # -1 ELSE CLR TTOS THEN \ MOV AX, BX \ CWD \ MOV BX, DX END-MACRO EXECUTES> 0< COMMENT: ICODE 0> ( n -- f ) MOV AX, BX NEG AX [ASM96] OV<> IF CWD MOV BX, DX RET THEN SUB BX, BX RET END-ICODE IMACRO 0<> ( n -- f ) NEG BX SBB BX, BX END-IMACRO MACRO = ( n1 n2 -- f ) [FORTH] IMM/ABS_OPT ?DUP IF 0< IF [ASM96] SUB BX, # ( xxxx ) [FORTH] ELSE [ASM96] SUB BX, ( xxxx ) [FORTH] THEN ELSE [ASM96] LODSW SUB BX, AX [FORTH] THEN [ASM96] SUB BX, # 1 SBB BX, BX [TARGET] END-MACRO NO-INTERPRET MACRO <> ( n1 n2 -- f ) [FORTH] IMM/ABS_OPT ?DUP IF 0< IF [ASM96] SUB BX, # ( xxxx ) [FORTH] ELSE [ASM96] SUB BX, ( xxxx ) [FORTH] THEN ELSE [ASM96] LODSW SUB BX, AX [FORTH] THEN [ASM96] NEG BX SBB BX, BX [TARGET] END-MACRO NO-INTERPRET : ?NEGATE ( n1 n2 -- n3 ) 0< IF NEGATE THEN ; NO-INTERPRET MACRO U< ( n1 n2 -- f ) LD W0 []+ PSP SUB W0 TTOS SUBC W0 W0 LD TTOS W0 \ LODSW \ SUB AX, BX \ SBB AX, AX \ MOV BX, AX END-MACRO NO-INTERPRET MACRO U> ( n1 n2 -- f ) [FORTH] IMM/ABS_OPT ?DUP IF 0< IF [ASM96] MOV AX, # ( xxxx ) SUB AX, BX SBB AX, AX MOV BX, AX [FORTH] ELSE [ASM96] MOV AX, ( xxxx ) SUB AX, BX SBB AX, AX MOV BX, AX [FORTH] THEN ELSE [ASM96] LODSW SUB BX, AX SBB BX, BX [FORTH] THEN [TARGET] END-MACRO NO-INTERPRET ICODE < ( n1 n2 -- f ) LODSW MOV DI, # TRUE CMP AX, BX [ASM96] >= IF SUB DI, DI THEN MOV BX, DI RET END-ICODE ICODE > ( n1 n2 -- f ) LODSW MOV DI, # TRUE CMP AX, BX [ASM96] <= IF SUB DI, DI THEN MOV BX, DI RET END-ICODE ICODE UMIN ( n1 n2 -- n3 ) LODSW CMP BX, AX [ASM96] U> IF MOV BX, AX THEN RET END-ICODE ICODE MIN ( n1 n2 -- n3 ) LODSW CMP BX, AX [ASM96] > IF MOV BX, AX THEN RET END-ICODE ICODE MAX ( n1 n2 -- n3 ) LODSW CMP BX, AX [ASM96] <= IF MOV BX, AX THEN RET END-ICODE IMACRO 0MAX ( n1 -- n3 ) [ASM96] CMP BX, BP <= IF SUB BX, BX THEN END-IMACRO ICODE UMAX ( n1 n2 -- n3 ) [ASM96] LODSW CMP BX, AX U<= IF MOV BX, AX THEN RET END-ICODE ICODE WITHIN ( n lo hi -- flag ) [ASM96] MOV DI, BX LODSW MOV CX, AX LODSW SUB BX, BX CMP AX, DI < IF CMP AX, CX >= IF DEC BX THEN THEN RET END-ICODE ICODE BETWEEN ( n lo hi -- flag ) [ASM96] MOV DX, BX LODSW MOV CX, AX LODSW SUB BX, BX CMP AX, DX <= IF CMP AX, CX >= IF DEC BX THEN THEN RET END-ICODE $FFFF CONSTANT TRUE $0000 CONSTANT FALSE ICODE 2@ ( addr -- d ) XCHG SI, SP PUSH 2 [BX] MOV BX, 0 [BX] XCHG SI, SP RET END-ICODE ICODE 2! ( d addr -- ) XCHG SI, SP POP 0 [BX] POP 2 [BX] POP BX XCHG SI, SP RET END-ICODE MACRO 2DROP ( d -- ) INC SI INC SI LOAD_TTOS END-MACRO EXECUTES> 2DROP IMACRO 3DROP ( n1 n2 n3 -- ) ADD SI, # 4 LOAD_TTOS END-IMACRO CODE 2DUP ( d -- d d ) XCHG SI, SP MOV DI, SP PUSH BX PUSH 0 [DI] XCHG SI, SP RET END-CODE EXECUTES> 2DUP ICODE 3DUP ( n1 n2 n3 -- n1 n2 n3 n1 n2 n3 ) XCHG SI, SP MOV DI, SP PUSH BX PUSH 2 [DI] PUSH 0 [DI] XCHG SI, SP RET END-ICODE ICODE 2SWAP ( d1 d2 -- d2 d1 ) XCHG SI, SP POP CX XCHG BX, CX POP AX POP DX PUSH BX PUSH CX PUSH DX MOV BX, AX XCHG SI, SP RET END-ICODE ICODE 2OVER ( d1 d2 -- d1 d2 d1 ) XCHG SI, SP MOV DI, SP PUSH BX PUSH 4 [DI] MOV BX, 2 [DI] XCHG SI, SP RET END-ICODE ICODE D+ ( d1 d2 -- dsum ) MOV DX, BX LODSW ADD 2 [SI], AX LOAD_TTOS ADC BX, DX RET END-ICODE IMACRO DNEGATE ( d# -- d#' ) NEG BX NEG 0 [SI] WORD SBB BX, BP END-IMACRO ICODE S>D ( n -- d ) MOV AX, BX CWD DEC SI DEC SI MOV 0 [SI], DX MOV BX, AX RET END-ICODE ICODE DABS ( d1 -- d2 ) [ASM96] OR BX, BP 0< IF NEG BX NEG 0 [SI] WORD SBB BX, BP THEN RET END-ICODE IMACRO D2* ( d -- d*2 ) SHL 0 [SI], # 1 WORD RCL BX, # 1 END-IMACRO IMACRO D2/ ( d -- d/2 ) SAR BX, # 1 RCR 0 [SI], # 1 WORD END-IMACRO : D- ( d1 d2 -- d3 ) DNEGATE D+ ; NO-INTERPRET : ?DNEGATE ( d1 n -- d2 ) 0< IF DNEGATE THEN ; NO-INTERPRET : D0= ( d -- f ) OR 0= ; NO-INTERPRET : D= ( d1 d2 -- f ) D- D0= ; NO-INTERPRET : DU< ( ud1 ud2 -- f ) ROT SWAP 2DUP U< IF 2DROP 2DROP TRUE ELSE <> IF 2DROP FALSE ELSE U< THEN THEN ; NO-INTERPRET : D< ( d1 d2 -- f ) 2 PICK OVER = IF DU< ELSE NIP ROT DROP < THEN ; NO-INTERPRET : D> ( d1 d2 -- f ) 2SWAP D< ; NO-INTERPRET : 4DUP ( a b c d -- a b c d a b c d ) 2OVER 2OVER ; NO-INTERPRET : DMIN ( d1 d2 -- d3 ) 4DUP D> IF 2SWAP THEN 2DROP ; NO-INTERPRET : DMAX ( d1 d2 -- d3 ) 4DUP D< IF 2SWAP THEN 2DROP ; NO-INTERPRET ICODE *D ( n1 n2 -- d# ) MOV AX, 0 [SI] IMUL BX MOV 0 [SI], AX MOV BX, DX RET END-ICODE : MU/MOD ( ud# un1 -- rem d#quot ) >R 0 R@ UM/MOD R> SWAP >R UM/MOD R> ; comment; MACRO / ( num den --- quot ) LD W0 []+ PSP CLR W2 DIV W0 TTOS LD TTOS W0 END-MACRO EXECUTES> / comment: ICODE /MOD ( num den --- rem quot ) RET END-ICODE : MOD ( n1 n2 -- rem ) /MOD DROP ; EXECUTES> MOD ICODE */MOD ( n1 n2 n3 --- rem quot ) XCHG SI, SP POP AX POP CX IMUL CX MOV CX, BX XOR CX, DX [ASM96] 0>= IF IDIV BX ELSE IDIV BX OR DX, DX 0<> IF ADD DX, BX DEC AX THEN THEN PUSH DX MOV BX, AX XCHG SI, SP RET END-ICODE MACRO XOR ( n1 n2 -- n3 ) [FORTH] IMM/ABS_OPT ?DUP IF 0< IF [ASM96] XOR BX, # ( xxxx ) [FORTH] ELSE [ASM96] XOR BX, ( xxxx ) [FORTH] THEN ELSE [ASM96] LODSW XOR BX, AX [FORTH] THEN [TARGET] END-MACRO EXECUTES> XOR : M/MOD ( d# n1 -- rem quot ) ?DUP IF DUP>R 2DUP XOR >R >R DABS R@ ABS UM/MOD SWAP R> ?NEGATE SWAP R> 0< IF NEGATE OVER IF 1- R@ ROT - SWAP THEN THEN R>DROP THEN ; NO-INTERPRET : */ ( n1 n2 n3 -- n1*n2/n3 ) */MOD NIP ; NO-INTERPRET : ROLL ( n1 n2 .. nk k -- n2 n3 .. nk n1 ) >R R@ PICK SP@ DUP 2+ R> 1+ 2* CMOVE> DROP ; NO-INTERPRET : 2ROT ( a b c d e f - c d e f a b ) 5 ROLL 5 ROLL ; NO-INTERPRET comment; CODE FILL ( start-addr count char -- ) LD W2 []+ PSP LD W0 []+ PSP 1 $:| STB TTOS []+ W0 DEC W2 JNE 1 $ LOAD_TTOS RET END-CODE : ERASE ( addr len -- ) 0 FILL ; NO-INTERPRET $20 CONSTANT BL \ a blank : BLANK ( addr len -- ) BL FILL ; NO-INTERPRET \S ICODE COUNT ( a1 --- a2 n1 ) SUB AX, AX MOV AL, 0 [BX] INC BX DEC SI DEC SI MOV 0 [SI], BX MOV BX, AX RET END-ICODE ICODE COUNTL ( seg addr -- seg addr+1 len ) MOV AX, 0 [SI] MOV DX, DS MOV DS, AX XOR AX, AX MOV AL, 0 [BX] INC BX MOV DS, DX DEC SI DEC SI MOV 0 [SI], BX MOV BX, AX RET END-ICODE ICODE LENGTH ( a1 --- a2 n1 ) MOV AX, 0 [BX] INC BX INC BX DEC SI DEC SI MOV 0 [SI], BX MOV BX, AX RET END-ICODE ICODE CMOVEL ( sseg sptr dseg dptr cnt -- ) PUSH DS PUSH ES XCHG SI, SP MOV CX, BX \ count to CX MOV BX, SI \ preserve SI CLD POP DI POP ES POP SI POP DS [ASM96] CX<>0 IF REPNZ MOVSB THEN MOV SI, BX \ restore SI POP BX XCHG SI, SP POP ES POP DS RET END-ICODE ICODE CMOVEL> ( sseg sptr dseg dptr cnt -- ) PUSH DS PUSH ES XCHG SI, SP MOV CX, BX \ count to BX MOV BX, SI \ preserve SI STD POP DI POP ES POP SI POP DS [ASM96] CX<>0 IF DEC CX ADD DI, CX ADD SI, CX INC CX REPNZ MOVSB THEN CLD MOV SI, BX \ restore SI POP BX XCHG SI, SP POP ES POP DS RET END-ICODE : MOVE ( from to len -- ) -ROT 2DUP U< IF ROT CMOVE> ELSE ROT CMOVE THEN ; NO-INTERPRET ICODE SKIP ( addr len char -- addr' len' ) \ skip char forwards [ASM96] LODSW MOV CX, AX MOV AX, BX CX<>0 IF MOV DI, 0 [SI] MOV DX, ES MOV BX, DS MOV ES, BX REPZ SCASB MOV ES, DX 0<> IF INC CX DEC DI THEN MOV 0 [SI], DI THEN MOV BX, CX RET END-ICODE ICODE -SKIP ( addr len char -- addr' len' ) \ skip char backwards [ASM96] LODSW MOV CX, AX MOV AX, BX CX<>0 IF MOV DI, 0 [SI] MOV DX, ES MOV BX, DS MOV ES, BX STD REPZ SCASB CLD MOV ES, DX 0<> IF INC CX INC DI THEN MOV 0 [SI], DI THEN MOV BX, CX RET END-ICODE ICODE SCAN ( addr len char -- addr' len' ) \ scan char forwards [ASM96] LODSW MOV CX, AX MOV AX, BX CX<>0 IF MOV DI, 0 [SI] MOV DX, ES MOV BX, DS MOV ES, BX REPNZ SCASB MOV ES, DX 0= IF INC CX DEC DI THEN MOV 0 [SI], DI THEN MOV BX, CX RET END-ICODE ICODE -SCAN ( addr len char -- addr' len' ) \ scan char backwards [ASM96] LODSW MOV CX, AX MOV AX, BX CX<>0 IF MOV DI, 0 [SI] MOV DX, ES MOV BX, DS MOV ES, BX STD REPNZ SCASB CLD MOV ES, DX 0= IF DEC CX INC DI THEN MOV 0 [SI], DI THEN MOV BX, CX RET END-ICODE ICODE /STRING ( addr len n -- addr' len' ) LODSW XCHG BX, AX CMP BX, AX [ASM96] U<= IF MOV AX, BX \ AX = SMALLER OF AX BX THEN ADD 0 [SI], AX SUB BX, AX RET END-ICODE ICODE DIGIT ( char base -- n f ) [ASM96] MOV AX, 0 [SI] SUB AL, # $30 \ ASCII 0 can't user ASCII in CODE JB 0 $ CMP AL, # 9 > IF CMP AL, # 17 JB 0 $ SUB AL, # 7 THEN CMP AL, BL JAE 0 $ MOV 0 [SI], AX MOV BX, # -1 RET 0 $: SUB BX, BX RET END-ICODE VARIABLE DPL VARIABLE BASE VARIABLE HLD VARIABLE CAPS VARIABLE SSEG VARIABLE SPAN VARIABLE #OUT VARIABLE #LINE VARIABLE SAVECUR VARIABLE ESC_FLG VARIABLE #TIB VARIABLE >IN VARIABLE #EXSTRT VARIABLE FUDGE VARIABLE ATTRIB VARIABLE LMARGIN VARIABLE RMARGIN VARIABLE TABSIZE : HERE ( -- A1 ) \ return a1 the address of the next available \ free memory space in data ram DP @ ; EXECUTES> HERE : PAD ( -- a1 ) \ a place to put things for a bit DP @ 82 + ; EXECUTES> PAD : ALLOT ( n1 -- ) \ allot some DS: ram DP +! ; NO-INTERPRET : DS:ALLOC ( n1 -- a1 ) \ allocate n1 bytes of ram at runtime, \ returning a1 the address of the ram HERE SWAP ALLOT ; NO-INTERPRET : DS:FREE? ( -- n1 ) \ return the amount of free ram at runtime SP0 @ HERE - 300 - ; NO-INTERPRET : WORD ( c1 -- a1 ) \ return a1 a word from TIB >R TIB #TIB @ >IN @ /STRING \ starting point for word R@ SKIP 2DUP R> SCAN NIP \ parse out a word #TIB @ OVER - >IN ! \ adj >in to new point in $ - HERE PLACE HERE \ return string in HERE $2020 HERE COUNT + ! ; \ append blanks NO-INTERPRET : DOS_TO_TIB ( -- ) \ Move the DOS commandline to Forths TIB ?CS: DOS_CMD_TAIL COUNTL DUP #TIB ! ?DS: TIB ROT CMOVEL >IN OFF ; NO-INTERPRET : HEX ( -- ) $10 BASE ! ; EXECUTES> HEX : DECIMAL ( -- ) $0A BASE ! ; EXECUTES> DECIMAL : OCTAL ( -- ) $08 BASE ! ; EXECUTES> OCTAL : COMPARE ( addr1 addr2 len -- -1 | 0 | 1 ) CAPS @ IF CAPS-COMP ELSE COMP THEN ; NO-INTERPRET : DOUBLE? ( -- f ) DPL @ 1+ 0<> ; NO-INTERPRET : 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> ; NO-INTERPRET : (NUMBER?) ( adr -- d flag ) 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 = ; NO-INTERPRET : NUMBER? ( adr -- d flag ) FALSE OVER COUNT BOUNDS ?DO I C@ BASE @ DIGIT NIP IF DROP TRUE LEAVE THEN (LOOP) LEAVE? UNDO DO? IF (NUMBER?) ELSE DROP 0 0 FALSE THEN ; NO-INTERPRET ICODE %DOSEXPECT ( addr +n --- n2 ) PUSH BP XCHG SI, SP MOV AX, BX \ count to ax MOV BX, SP SUB BX, # $100 \ buffer 256 bytes below stck MOV 0 [BX], AL \ 1st byte buffer = chars MOV DX, BX \ DX = ^buffer MOV AH, # $0A \ buffered keyboard input INT $21 \ DOS function call SUB CX, CX \ zero CX INC BX \ BX = ^#chars read MOV CL, 0 [BX] \ CX = #chars READ POP DI \ DI = forth address PUSH CX \ return CX INC BX \ BX = ^buffer MOV DX, SI \ DX saves SI MOV AX, ES \ AX saves ES MOV SI, BX \ SI = DOS address MOV BX, DS MOV ES, BX \ set ES = DS REPNZ MOVSB \ move it MOV SI, DX \ restore SI MOV ES, AX \ restore ES POP BX XCHG SI, SP POP BP RET END-ICODE ICODE DEALLOC ( n1 -- f1 ) PUSH ES MOV ES, BX MOV AH, # $49 INT $21 [ASM96] U< IF SUB AH, AH ELSE SUB AX, AX THEN POP ES MOV BX, AX RET END-ICODE ICODE ALLOC ( n1 -- n2 n3 f1 ) XCHG SI, SP MOV AH, # $48 INT $21 PUSH BX PUSH AX [ASM96] U< IF SUB AH, AH ELSE SUB AX, AX THEN MOV BX, AX XCHG SI, SP RET END-ICODE ICODE SETBLOCK ( seg siz -- f1 ) LODSW MOV DX, AX MOV AH, # $4A \ setblock call PUSH ES MOV ES, DX INT $21 [ASM96] U< IF SUB AH, AH ELSE SUB AX, AX THEN POP ES MOV BX, AX RET END-ICODE : PARAGRAPH ( offset -- paragraph-inc ) 15 + U16/ ; EXECUTES> PARAGRAPH ICODE EXECF ( string PARMS --- return-code ) [ASM96] \ BX contains PARMS LODSW MOV DX, AX \ DX contains string PUSH ES PUSH SI PUSH BP PUSH DS MOV AX, DS MOV ES, AX MOV AX, # $4B00 INT $21 POP DS POP BP POP SI POP ES U< IF \ ONLY when carry is NON ZERO AND AX, # $FF ELSE SUB AX, AX THEN MOV BX, AX RET END-ICODE ICODE VIDEO ( DX CX BX AX -- DX AX ) \ perform a VIDEO interrupt \ call. MOV DX, BX LOAD_TTOS LODSW MOV CX, AX LODSW XCHG DX, AX PUSH SI PUSH BP INT $10 POP BP POP SI DEC SI DEC SI MOV 0 [SI], DX MOV BX, AX RET END-ICODE : AT? ( -- x y ) \ return the current cursor position 0 0 0 $0300 VIDEO DROP SPLIT ; NO-INTERPRET : AT ( X Y -- ) \ set the current cursor position 2DUP #LINE ! #OUT ! FLIP OR 0 0 $0200 VIDEO 2DROP ; NO-INTERPRET : VMODE@ ( -- n1 ) \ get the current video mode. 0 0 0 $0F00 VIDEO NIP $FF AND ; NO-INTERPRET : VMODE! ( n1 -- ) \ use to set video modes. n1 is the \ desired mode number. For example \ 6 VMODE! will select 640x200 \ black & white graphics. >R 0 0 0 R> VIDEO 2DROP ; NO-INTERPRET : DARK ( -- ) \ fetch and store video mode thus \ clearing the screen. VMODE@ VMODE! #OUT OFF #LINE OFF ; EXECUTES> DARK ' DARK ALIAS CLS ICODE ?VMODE ( --- N1 ) \ Get the video mode from DOS DEC SI DEC SI MOV 0 [SI], BX MOV AH, # $0F INT $10 SUB AH, AH MOV BX, AX RET END-ICODE ICODE SET-CURSOR ( n1 --- ) \ set the cursor shape MOV CX, BX MOV AH, # 1 PUSH SI PUSH BP INT $10 POP BP POP SI LOAD_TTOS RET END-ICODE : GET-CURSOR ( --- shape ) \ get the cursor shape 0 $460 @L ; NO-INTERPRET : INIT-CURSOR ( -- ) GET-CURSOR SAVECUR ! ; NO-INTERPRET : CURSOR-OFF ( --- ) GET-CURSOR $2000 OR SET-CURSOR ; NO-INTERPRET : CURSOR-ON ( --- ) GET-CURSOR $0F0F AND SET-CURSOR ; NO-INTERPRET : NORM-CURSOR ( --- ) SAVECUR C@ DUP 1- FLIP + SET-CURSOR ; NO-INTERPRET : BIG-CURSOR ( --- ) SAVECUR C@ SET-CURSOR ; NO-INTERPRET : SAVECURSOR ( -- ) \ save all of the current cursor stuff R> ATTRIB @ >R \ save attribute GET-CURSOR >R \ cursor shape #OUT @ #LINE @ 2>R \ and position >R ; NO-INTERPRET : RESTCURSOR ( -- ) \ restore all of the cursor stuff R> 2R> AT \ restore position R> SET-CURSOR \ shape R> ATTRIB ! \ and attribute >R ; NO-INTERPRET ICODE BDOS2 ( CX DX AL -- CX DX AX ) MOV AX, BX MOV DX, 0 [SI] MOV CX, 2 [SI] MOV AH, AL INT $21 MOV BX, AX MOV 0 [SI], DX MOV 2 [SI], CX RET END-ICODE : OS2 BDOS2 255 AND ; NO-INTERPRET ICODE BDOS ( DX AH -- AL ) LODSW MOV DX, AX MOV AH, BL INT $21 SUB AH, AH MOV BX, AX RET END-ICODE : DOSVER ( -- n1 ) 0 $030 BDOS $0FF AND ; NO-INTERPRET : BYE ( -- ) 0 0 BDOS DROP ; EXECUTES> BYE : DOSEMIT ( c1 -- ) 6 BDOS DROP #OUT INCR ; NO-INTERPRET ICODE PR-STATUS ( n1 -- b1 ) MOV DX, BX \ PRINTER NUMBER MOV AH, # 2 PUSH SI PUSH BP INT $17 POP BP POP SI MOV BL, AH SUB BH, BH RET END-ICODE : ?PRINTER.READY ( -- f1 ) 0 PR-STATUS ( $090 AND ) $090 = ; NO-INTERPRET ICODE PEMIT ( c1 -- ) MOV DX, # 0 \ PRINTER NUMBER MOV AL, BL MOV AH, # 0 PUSH SI PUSH BP INT $17 POP BP POP SI LOAD_TTOS RET END-ICODE ICODE KEY? ( -- f1 ) \ BIOS KEY?, NO redirection! DEC SI DEC SI MOV 0 [SI], BX MOV AH, # 1 PUSH SI PUSH BP INT $16 POP BP POP SI [ASM96] 0= IF SUB AX, AX ELSE MOV AX, # -1 THEN MOV BX, AX RET END-ICODE : BDOSKEY? ( -- c1 ) \ DOS KEY?, redirectable 255 6 BDOS $FF AND ; NO-INTERPRET : BDOSKEY ( -- c1 ) \ DOS KEY, redirectable, RAW 0 7 BDOS $FF AND ; NO-INTERPRET : %KEY ( -- c1 ) \ DOS KEY, redirectable, translates BDOSKEY ?DUP 0= \ function keys to above 128. IF BDOSKEY 128 OR THEN ; NO-INTERPRET DEFER KEY DEFER EMIT DEFER TYPE DEFER SPACES : SPACE ( -- ) BL EMIT ; EXECUTES> SPACE : %SPACES ( n1 -- ) 0 MAX ?DUP IF 1- FOR BL EMIT NEXT THEN ; NO-INTERPRET : %TYPE ( a1 n1 -- ) 0 MAX ?DUP IF 1- FOR DUP C@ EMIT 1+ NEXT DROP ELSE DROP THEN ; NO-INTERPRET : EEOL ( -- ) \ Erase to end of line 80 #OUT @ - 0MAX SPACES ; EXECUTES> EEOL : CR ( -- ) $0D DOSEMIT $0A DOSEMIT #OUT OFF #LINE @ 1+ 24 MIN #LINE ! ; EXECUTES> CR : $>TIB ( A1 --- ) COUNT DUP #TIB ! TIB SWAP CMOVE >IN OFF ; NO-INTERPRET : ?LINE ( N -- ) AT? DROP + RMARGIN @ > IF CR LMARGIN @ SPACES THEN ; NO-INTERPRET : ?CR ( -- ) 0 ?LINE ; NO-INTERPRET : MARGIN_INIT ( -- ) LMARGIN OFF 64 RMARGIN ! \ default margins 8 TABSIZE ! ; NO-INTERPRET : ABORT ( -- ) \ Just leave when we abort CR BYE ; EXECUTES> ABORT : ?ABORT" ( f1 a1 n1 -- ) \ display string a1,n1 & abort if f1 true ROT IF TYPE ABORT ELSE 2DROP THEN ; : MS ( n1 -- ) \ Delay n1 units of about a millisecond. FOR FUDGE @ 1+ FOR NEXT NEXT ; EXECUTES> MS FORTH >FORTH : %T." ( | string" -- ) [COMPILE] T" ['] TYPE RES_COMP_DEFER ; IMMEDIATE ' %T." IS T." \ link into defered word : %L." ( | string" -- ) [COMPILE] L" COMPILE RES_COMP_DEF ['] TYPE X, ; IMMEDIATE ' %L." IS L." \ link into defered word : %TABORT" ( | string" -- ) [COMPILE] T" ['] ?ABORT" COMP_CALL ; IMMEDIATE ' %TABORT" IS TABORT" : %LABORT" ( | string" -- ) [COMPILE] L" COMPILE <'> COMPILE ?ABORT" COMPILE COMP_CALL ; IMMEDIATE ' %LABORT" IS LABORT" TARGET >LIBRARY ICODE ['] ( -- a1 ) \ get address of routine following this one DEC SI DEC SI MOV 0 [SI], BX POP BX \ get address where we came from INC BX MOV AX, BX INC AX INC AX PUSH AX \ push adjusted return address on return stk ADD AX, CS: 0 [BX] MOV BX, AX \ BX holds address of routine following RET END-ICODE : TAB ( -- ) AT? DROP TABSIZE @ MOD TABSIZE @ SWAP - SPACES ; EXECUTES> TAB : BEEP ( -- ) 7 DOSEMIT #OUT DECR ; EXECUTES> BEEP : HOLD ( char -- ) HLD DECR HLD @ C! ; NO-INTERPRET : <# ( -- ) PAD HLD ! ; NO-INTERPRET : #> ( d# -- addr len ) 2DROP HLD @ PAD OVER - ; NO-INTERPRET : SIGN ( n1 -- ) 0< IF ASCII - HOLD THEN ; NO-INTERPRET : # ( d1 -- d2 ) BASE @ MU/MOD ROT 9 OVER < IF 7 + THEN ASCII 0 + HOLD ; NO-INTERPRET : #S ( d -- 0 0 ) BEGIN # 2DUP OR 0= UNTIL ; NO-INTERPRET : (U.) ( u -- a l ) 0 <# #S #> ; NO-INTERPRET : U. ( u -- ) (U.) TYPE SPACE ; EXECUTES> U. : U.R ( u l -- ) >R (U.) R> OVER - SPACES TYPE ; EXECUTES> U.R : (.) ( n -- a l ) DUP ABS 0 <# #S ROT SIGN #> ; NO-INTERPRET : . ( n -- ) (.) TYPE SPACE ; EXECUTES> . : .R ( n l -- ) >R (.) R> OVER - SPACES TYPE ; EXECUTES> .R : (UD.) ( ud -- a l ) <# #S #> ; NO-INTERPRET : UD. ( ud -- ) (UD.) TYPE SPACE ; NO-INTERPRET : UD.R ( ud l -- ) >R (UD.) R> OVER - SPACES TYPE ; NO-INTERPRET : (D.) ( d -- a l ) TUCK DABS <# #S ROT SIGN #> ; NO-INTERPRET : D. ( d -- ) (D.) TYPE SPACE ; NO-INTERPRET : D.R ( d l -- ) >R (D.) R> OVER - SPACES TYPE ; NO-INTERPRET : NOOP ( -- ) ; EXECUTES> NOOP : H.R ( n1 n2 -- ) BASE @ >R HEX U.R R> BASE ! ; : H. ( n1 -- ) 1 H.R SPACE ; EXECUTES> H. : ">$ ( a1 n1 -- a2 ) DROP 1- ; NO-INTERPRET : U<= ( u1 u2 -- f ) U> NOT ; NO-INTERPRET : U>= ( u1 u2 -- f ) U< NOT ; NO-INTERPRET : <= ( n1 n2 -- f ) > NOT ; NO-INTERPRET : >= ( n1 n2 -- f ) < NOT ; NO-INTERPRET : 0>= ( n1 n2 -- f ) 0< NOT ; NO-INTERPRET : 0<= ( n1 n2 -- f ) 0> NOT ; NO-INTERPRET : DUMP ( addr len -- ) 0 DO CR DUP 6 H.R SPACE 15 FOR DUP C@ 3 H.R 1+ NEXT 16 +LOOP DROP ; EXECUTES> DUMP ' !> ALIAS =: IMMEDIATE ' !> ALIAS IS IMMEDIATE comment; >FORTH