home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power-Programmierung
/
CD1.mdf
/
forth
/
compiler
/
fpc
/
source
/
library.seq
< prev
next >
Wrap
Text File
|
1991-04-13
|
91KB
|
2,677 lines
\ LIBRARY.SEQ Target Library Source by Tom Zimmer
\ ***************************************************************************
\ 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_BX A; \ to the stack.
[FORTH]
HERE-T IMM-HERE !
[ASSEMBLER]
MOV BX, # END-MACRO NO-INTERPRET
' (LIT) >EXECUTE IS COMP_SINGLE \ link into number compiler
ICODE EXEC: ( n1 -- ) \ execute the n-th CALL following EXEC:
\ MUST be followed by CALL's, not MACROS
MOV AX, BX \ AX = BX
SHL BX, # 1 \ BX * 2
ADD AX, BX \ BX + 1 equals n1*3
POP DI \ get return address
ADD DI, AX \ offset to desired CALL
INC DI \ step over the CALL opcode
ADD DI, CS: 0 [DI] \ add relative destination to pointer
ADD DI, # 2 \ plus 2 to correct for relative CALL
LOAD_BX \ reload BX
JMP DI END-ICODE \ and finally jump to function
ICODE BOUNDS ( n1 n2 --- n3 n4 ) \ Calculate limits used in DO-loop
XCHG SI, SP
POP AX
ADD BX, AX
XCHG BX, AX
PUSH AX
XCHG SI, SP
RET END-ICODE
MACRO ?CS: ( -- cs ) \ where the code is located.
SAVE_BX
MOV BX, CS END-MACRO EXECUTES> ?CS:
MACRO ?DS: ( -- ds ) \ where all of our @(fetch) & !(store) data
\ is located.
SAVE_BX
MOV BX, DS END-MACRO NO-INTERPRET
MACRO DS:! ( ds -- ) \ set DS to the value on the stack
MOV DS, BX
LOAD_BX END-MACRO NO-INTERPRET
MACRO DS:->SS: ( -- ) \ set SS to DS
MOV AX, DS
MOV SS, AX END-MACRO
MACRO EXIT ( -- ) \ Terminate a high-level definition
RET END-MACRO NO-INTERPRET
MACRO ?EXIT ( f1 -- ) \ If boolean f1 is true, exit from definition.
LODSW
XCHG BX, AX
CMP AX, BP
[ASSEMBLER]
0<> IF RET
THEN END-MACRO NO-INTERPRET
MACRO BEGIN ( -- )
+BR# $:|
OPT_OFF1 END-MACRO NO-INTERPRET
MACRO AGAIN ( -- ) \ an unconditional branch
JMP -BR# DUP $ 01LAB
END-MACRO NO-INTERPRET
MACRO IF ( f -- ) \ branch if flag is zero
LODSW
XCHG BX, AX
CMP AX, BP A; \ BP ALWAYS EQUALS ZERO
?LONG [FORTH]
IF [ASSEMBLER]
JNZ here 5 + A; \ branch around JMP
JMP +BR# $ WORD A;
[FORTH]
ELSE [ASSEMBLER]
JZ +BR# $ A;
[FORTH]
THEN
[ASSEMBLER] END-MACRO NO-INTERPRET
TARGET ' IF ALIAS WHILE ( f1 -- )
MACRO ELSE ( -- )
?LONG [FORTH]
IF [ASSEMBLER]
JMP +BR# $ WORD
[FORTH]
ELSE [ASSEMBLER]
JMP +BR# $
[FORTH]
THEN [ASSEMBLER]
BR#SWAP
-BR# DUP $:| 01LAB
OPT_OFF1 END-MACRO NO-INTERPRET
MACRO THEN ( -- ) \ resolve branch
-BR# DUP $:| 01LAB
OPT_OFF1 END-MACRO NO-INTERPRET
' THEN ALIAS ENDIF
FORTH >FORTH
0 VALUE #CASES \ a CASE counter
FORTH
: %CASE ( -- )
[FORTH]
OFF> #CASES ;
FORTH
: CASE ( -- )
[FORTH]
?LIB
IF COMPILE %CASE
ELSE %CASE
THEN
[TARGET]
; IMMEDIATE
TARGET >LIBRARY
MACRO OF ( n1 n2 -- n1 ) ( n1 n2 -- )
[FORTH]
IMM/ABS_OPT ?DUP
IF 0<
IF
[ASSEMBLER]
CMP BX, # ( xxxx )
[FORTH]
ELSE
[ASSEMBLER]
CMP BX, ( xxxx )
[FORTH]
THEN
ELSE
[ASSEMBLER]
LODSW
XCHG AX, BX
CMP BX, AX
[FORTH]
THEN
INCR> #CASES \ bump number of cases
?LONG
IF [ASSEMBLER]
JZ here 5 + A; \ branch around JMP
JMP +BR# $ WORD A;
[FORTH]
ELSE [ASSEMBLER]
JNZ +BR# $ A;
[FORTH]
THEN
[ASSEMBLER]
LOAD_BX END-MACRO NO-INTERPRET
MACRO ENDOF ( -- )
JMP +BR# $ WORD
BR#SWAP
-BR# DUP $:| 01LAB
OPT_OFF1 END-MACRO NO-INTERPRET
MACRO ENDCASE ( -- ) \ resolve branch
[FORTH]
SAVE> ?LONG \ save current branch length flag
LONG_BRANCH \ we default to long for ENDCASE
#CASES 0 \ resolve #CASES case statments
DO [ASSEMBLER]
-BR# DUP $:| 01LAB
[FORTH]
LOOP
OFF> #CASES
RESTORE> ?LONG \ restore branch length flag
[ASSEMBLER]
OPT_OFF1 END-MACRO NO-INTERPRET
MACRO REPEAT ( -- )
BR#SWAP
JMP -BR# DUP $ 01LAB
-BR# DUP $:| 01LAB
END-MACRO NO-INTERPRET
MACRO UNTIL ( f1 -- )
LODSW
XCHG BX, AX
CMP AX, BP A;
?LONG
[FORTH]
IF [ASSEMBLER]
JNZ here 5 + A; \ branch around JMP
JMP -BR# DUP $ WORD 01LAB A;
[FORTH]
ELSE [ASSEMBLER]
JZ -BR# DUP $ 01LAB A;
[FORTH]
THEN
[ASSEMBLER] END-MACRO NO-INTERPRET
MACRO FOR ( n1 -- )
PUSH BX
LOAD_BX
+BR# $:|
OPT_OFF1 END-MACRO NO-INTERPRET
MACRO NEXT ( -- )
POP CX
[ASSEMBLER]
CX<>0 IF
DEC CX
PUSH CX
JMP -BR# DUP $ 01LAB
THEN END-MACRO NO-INTERPRET
MACRO UNDO ( --- )
ADD SP, # 4 END-MACRO NO-INTERPRET
MACRO DO ( l i -- )
[FORTH]
?DOING OFF
[ASSEMBLER]
LODSW
ADD AX, # $8000
PUSH AX
SUB BX, AX
PUSH BX
LOAD_BX
+BR# $:|
OPT_OFF1 END-MACRO NO-INTERPRET
MACRO ?DO ( l i -- )
[FORTH]
?DOING ON
[ASSEMBLER]
MOV DI, BX
LODSW MOV DX, AX
LOAD_BX
CMP DX, DI A;
?LONG [FORTH]
IF [ASSEMBLER]
JNE here 5 + A; \ branch around JMP
JMP +BR# $ WORD A;
[FORTH]
ELSE [ASSEMBLER]
JE +BR# $ A;
[FORTH]
THEN [ASSEMBLER]
ADD DX, # $8000
PUSH DX
SUB DI, DX
PUSH DI
+BR# $:|
OPT_OFF1 END-MACRO NO-INTERPRET
MACRO (LOOP) ( -- )
MOV DI, SP
INC 0 [DI] WORD A;
?LONG
[FORTH]
IF [ASSEMBLER]
JO here 5 + A; \ branch around JMP
JMP -BR# DUP $ WORD 01LAB A;
[FORTH]
ELSE [ASSEMBLER]
JNO -BR# DUP $ 01LAB A;
[FORTH]
THEN
[ASSEMBLER] END-MACRO NO-INTERPRET
MACRO (+LOOP) ( n -- )
LODSW
XCHG BX, AX
MOV DI, SP
ADD 0 [DI], AX A;
?LONG
[FORTH]
IF [ASSEMBLER]
JO here 5 + A; \ branch around JMP
JMP -BR# DUP $ WORD 01LAB A;
[FORTH]
ELSE [ASSEMBLER]
JNO -BR# DUP $ 01LAB A;
[FORTH]
THEN
[ASSEMBLER] 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 ( -- )
F['] (LOOP) >EXECUTE EXECUTE
[FORTH]
?LEAVING @
IF F['] LEAVE? >EXECUTE EXECUTE
THEN
[TARGET]
F['] UNDO >EXECUTE EXECUTE
[FORTH]
?DOING @
IF F['] DO? >EXECUTE EXECUTE
THEN
[TARGET]
;
FORTH
: LOOP ( -- )
[FORTH]
?LIB
IF COMPILE %LOOP
ELSE %LOOP
THEN
[TARGET]
; IMMEDIATE
FORTH
: %+LOOP ( -- )
F['] (+LOOP) >EXECUTE EXECUTE
[FORTH]
?LEAVING @
IF F['] LEAVE? >EXECUTE EXECUTE
THEN
[TARGET]
F['] UNDO >EXECUTE EXECUTE
[FORTH]
?DOING @
IF F['] DO? >EXECUTE EXECUTE
THEN
[TARGET]
;
FORTH
: +LOOP ( -- )
[FORTH]
?LIB
IF COMPILE %+LOOP
ELSE %+LOOP
THEN
[TARGET]
; IMMEDIATE
TARGET >LIBRARY
MACRO LEAVE ( -- )
[FORTH] ?LEAVING INCR [ASSEMBLER]
JMP 20 $ END-MACRO NO-INTERPRET
MACRO ?LEAVE ( f -- )
[FORTH] ?LEAVING INCR [ASSEMBLER]
LODSW
XCHG BX, AX
OR AX, AX A;
?LONG
[FORTH]
IF [ASSEMBLER]
JE here 5 + A; \ branch around JMP
JMP 20 $ WORD A;
[FORTH]
ELSE [ASSEMBLER]
JNE 20 $ A;
[FORTH]
THEN
[ASSEMBLER] END-MACRO NO-INTERPRET
MACRO I ( -- n )
SAVE_BX
MOV DI, SP
MOV BX, 0 [DI]
ADD BX, 2 [DI] END-MACRO NO-INTERPRET
MACRO J ( -- n )
SAVE_BX
MOV DI, SP
MOV BX, 4 [DI]
ADD BX, 6 [DI] END-MACRO NO-INTERPRET
MACRO K ( -- n )
SAVE_BX
MOV DI, SP
MOV BX, 8 [DI]
ADD BX, 10 [DI] END-MACRO NO-INTERPRET
MACRO EXECUTE ( cfa -- )
[FORTH]
IMM/ABS_OPT ?DUP
IF 0<
IF \ Immediate
[ASSEMBLER]
CALL ( xxxx )
[FORTH]
ELSE \ absolute
[ASSEMBLER]
CALL [] ( xxxx )
[FORTH]
THEN
ELSE
[ASSEMBLER]
LODSW
XCHG BX, AX
CALL AX
[FORTH]
THEN
[TARGET] END-MACRO NO-INTERPRET
MACRO PERFORM ( addr-of-cfa -- )
[FORTH]
IMM/ABS_OPT ?DUP
IF 0<
IF
[ASSEMBLER]
CALL [] ( xxxx )
[FORTH]
ELSE
[ASSEMBLER]
MOV DI, ( xxxx )
MOV AX, 0 [DI]
CALL AX
[FORTH]
THEN
ELSE
[ASSEMBLER]
LODSW
XCHG BX, AX
MOV DI, AX
MOV AX, 0 [DI]
CALL AX
[FORTH]
THEN
[TARGET] END-MACRO NO-INTERPRET
' PERFORM >EXECUTE IS COMP_PERFORM \ link into compiler
MACRO @ ( addr -- n )
AT_OPT END-MACRO EXECUTES> @-D
' @ >EXECUTE IS COMP_FETCH \ link into compiler
MACRO ! ( n addr -- )
STORE_OPT
LOAD_BX
STORE_OPT2
STORE_OPT3 END-MACRO EXECUTES> !-D
' ! >EXECUTE IS COMP_STORE \ link to compiler
MACRO %SAVE>R ( a1 -- )
MOV BX, 0 [BX]
PUSH BX
LOAD_BX END-MACRO NO-INTERPRET
' %SAVE>R >EXECUTE IS COMP_SAVE
MACRO %SAVE!>R ( n1 a1 -- )
MOV DI, BX
MOV DI, 0 [DI]
PUSH DI
LODSW
MOV 0 [BX], AX
LOAD_BX END-MACRO NO-INTERPRET
' %SAVE!>R >EXECUTE IS COMP_SAVEST
MACRO %R>REST ( a1 -- )
POP AX
MOV 0 [BX], AX
LOAD_BX END-MACRO NO-INTERPRET
' %R>REST >EXECUTE IS COMP_REST
ICODE @L ( seg addr -- word )
MOV DX, ES
LODSW
MOV ES, AX
MOV BX, ES: 0 [BX]
MOV ES, DX
RET END-ICODE
ICODE C@L ( seg addr -- byte )
MOV DX, ES
LODSW
MOV ES, AX
MOV BL, ES: 0 [BX]
MOV ES, DX
SUB BH, BH
RET END-ICODE
ICODE C!L ( byte seg addr -- )
MOV DX, ES
LODSW MOV ES, AX
LODSW
MOV ES: 0 [BX], AL
MOV ES, DX
LOAD_BX
RET END-ICODE
ICODE !L ( n1 seg addr -- )
MOV DX, ES
LODSW MOV ES, AX
LODSW
MOV ES: 0 [BX], AX
MOV ES, DX
LOAD_BX
RET END-ICODE
MACRO C@ ( addr -- char )
CAT_OPT
SUB BH, BH END-MACRO EXECUTES> C@-D
MACRO C! ( char addr -- )
CSTORE_OPT
LOAD_BX END-MACRO EXECUTES> C!-D
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_BX
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_BX
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_BX
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_BX
RET END-ICODE
CODE DEPTH ( -- n1 )
SAVE_BX
MOV BX, SP0
SUB BX, SI
SAR BX, # 1
DEC BX
RET END-CODE EXECUTES> DEPTH
MACRO TIB ( -- a1 ) \ Terminal Input Buffer address above stack
SAVE_BX
MOV BX, 'TIB END-MACRO EXECUTES> TIB
MACRO SP@ ( -- n )
SAVE_BX
MOV BX, SI END-MACRO NO-INTERPRET
MACRO SP! ( n -- )
MOV SI, BX
SUB BX, BX END-MACRO NO-INTERPRET
MACRO RP@ ( -- addr )
SAVE_BX
MOV BX, SP END-MACRO NO-INTERPRET
MACRO RP! ( n -- )
MOV SP, BX
LOAD_BX END-MACRO NO-INTERPRET
MACRO DROP ( n1 -- )
LOAD_BX END-MACRO EXECUTES> DROP
MACRO DUP ( n1 -- n1 n1 )
DEC SI
DEC SI
MOV 0 [SI], BX END-MACRO EXECUTES> DUP
MACRO SWAP ( n1 n2 -- n2 n1 )
XCHG 0 [SI], BX END-MACRO EXECUTES> SWAP
MACRO OVER ( n1 n2 -- n1 n2 n1 )
SAVE_BX
MOV BX, 2 [SI] END-MACRO EXECUTES> OVER
MACRO PLUCK ( n1 n2 n3 --- n1 n2 n3 n1 )
SAVE_BX
MOV BX, 4 [SI] END-MACRO NO-INTERPRET
CODE TUCK ( n1 n2 -- n2 n1 n2 )
LODSW
SUB SI, # 4
MOV 2 [SI], BX
MOV 0 [SI], AX
RET END-CODE EXECUTES> TUCK
MACRO NIP ( n1 n2 -- n2 )
INC SI
INC SI END-MACRO EXECUTES> NIP
CODE ROT ( n1 n2 n3 --- n2 n3 n1 )
XCHG SI, SP
POP DX
POP AX
PUSH DX
XCHG BX, AX
PUSH AX
XCHG SI, SP
RET END-CODE EXECUTES> ROT
CODE -ROT ( n1 n2 n3 --- n3 n1 n2 )
XCHG SI, SP
POP AX
POP DX
XCHG BX, AX
PUSH AX
PUSH DX
XCHG SI, SP
RET END-CODE EXECUTES> -ROT
MACRO FLIP ( n1 -- n2 )
XCHG BL, BH END-MACRO EXECUTES> FLIP
CODE SPLIT ( n1 --- n2 n3 )
MOV AX, BX
SUB AH, AH
DEC SI
DEC SI
MOV 0 [SI], AX
MOV BL, BH
MOV BH, AH
RET END-CODE EXECUTES> SPLIT
MACRO ?DUP ( n1 -- [n1] n1 )
MOV CX, BX
[ASSEMBLER]
CX<>0 IF DEC SI
DEC SI
MOV 0 [SI], BX
THEN END-MACRO EXECUTES> ?DUP
MACRO R> ( -- n )
SAVE_BX
POP BX END-MACRO NO-INTERPRET
IMACRO R>DROP ( --- )
ADD SP, # 2 END-IMACRO
IMACRO DUP>R ( n1 --- n1 )
PUSH BX END-IMACRO
IMACRO >R ( n -- )
PUSH BX
LOAD_BX END-IMACRO
IMACRO 2R> ( -- n1 n2 )
SUB SI, # 4
MOV 2 [SI], BX
POP BX
POP AX
MOV 0 [SI], AX END-IMACRO
IMACRO 2>R ( n1 n2 -- )
XCHG SI, SP
SUB SI, # 4
MOV 0 [SI], BX
POP 2 [SI]
POP BX
XCHG SI, SP END-IMACRO
IMACRO R@ ( -- n )
XCHG SI, SP
PUSH BX
MOV BX, 0 [SI]
XCHG SI, SP END-IMACRO
IMACRO 2R@ ( -- n1 n2 )
XCHG SI, SP
PUSH BX
PUSH 2 [SI]
MOV BX, 0 [SI]
XCHG SI, SP END-IMACRO
MACRO PICK ( nm ... n2 n1 k -- nm ... n2 n1 nk )
SHL BX, # 1
ADD BX, SI
MOV BX, 0 [BX] END-MACRO NO-INTERPRET
IMACRO RPICK ( nm ... n2 n1 k -- nm ... n2 n1 nk )
SHL BX, # 1
ADD BX, SP
MOV BX, 0 [BX] END-IMACRO
MACRO AND ( n1 n2 -- n3 )
[FORTH]
IMM/ABS_OPT ?DUP
IF 0<
IF
[ASSEMBLER]
AND BX, # ( xxxx )
[FORTH]
ELSE
[ASSEMBLER]
AND BX, ( xxxx )
[FORTH]
THEN
ELSE
[ASSEMBLER]
LODSW
AND BX, AX
[FORTH]
THEN
[TARGET] END-MACRO EXECUTES> AND
MACRO OR ( n1 n2 -- n3 )
[FORTH]
IMM/ABS_OPT ?DUP
IF 0<
IF
[ASSEMBLER]
OR BX, # ( xxxx )
[FORTH]
ELSE
[ASSEMBLER]
OR BX, ( xxxx )
[FORTH]
THEN
ELSE
[ASSEMBLER]
LODSW
OR BX, AX
[FORTH]
THEN
[TARGET] END-MACRO EXECUTES> OR
MACRO NOT ( n -- n' )
NOT BX END-MACRO EXECUTES> NOT
IMACRO CSET ( b addr -- )
LODSW
OR 0 [BX], AL
LOAD_BX END-IMACRO
IMACRO CRESET ( b addr -- )
LODSW
NOT AX
AND 0 [BX], AL
LOAD_BX END-IMACRO
IMACRO CTOGGLE ( b addr -- )
LODSW
XOR 0 [BX], AL
LOAD_BX END-IMACRO
MACRO ON ( addr -- )
[FORTH]
IMM/ABS_OPT ?DUP
IF 0<
IF
[ASSEMBLER]
MOV ( xxxx ) # TRUE WORD
[FORTH]
ELSE
[ASSEMBLER]
MOV DI, ( xxxx )
MOV 0 [DI], # TRUE WORD
[FORTH]
THEN
ELSE
[ASSEMBLER]
MOV 0 [BX], # TRUE WORD
LOAD_BX
[FORTH]
THEN
[TARGET] END-MACRO NO-INTERPRET
' ON >EXECUTE IS COMP_ON \ link to compiler
MACRO OFF ( addr -- )
[FORTH]
IMM/ABS_OPT ?DUP
IF 0<
IF
[ASSEMBLER]
MOV ( xxxx ) BP
[FORTH]
ELSE
[ASSEMBLER]
MOV DI, ( xxxx )
MOV 0 [DI], BP
[FORTH]
THEN
ELSE
[ASSEMBLER]
MOV 0 [BX], BP \ BP is always FALSE
LOAD_BX
[FORTH]
THEN
[TARGET] END-MACRO NO-INTERPRET
' OFF >EXECUTE IS COMP_OFF \ link to compiler
MACRO INCR ( addr --- )
[FORTH]
IMM/ABS_OPT ?DUP
IF 0<
IF
[ASSEMBLER]
INC ( xxxx ) WORD
[FORTH]
ELSE
[ASSEMBLER]
MOV DI, ( xxxx )
INC 0 [DI] WORD
[FORTH]
THEN
ELSE
[ASSEMBLER]
INC 0 [BX] WORD
LOAD_BX
[FORTH]
THEN
[TARGET] END-MACRO NO-INTERPRET
' INCR >EXECUTE IS COMP_INCR \ link to compiler
MACRO DECR ( addr --- )
[FORTH]
IMM/ABS_OPT ?DUP
IF 0<
IF
[ASSEMBLER]
DEC ( xxxx ) WORD
[FORTH]
ELSE
[ASSEMBLER]
MOV DI, ( xxxx )
DEC 0 [DI] WORD
[FORTH]
THEN
ELSE
[ASSEMBLER]
DEC 0 [BX] WORD
LOAD_BX
[FORTH]
THEN
[TARGET] END-MACRO NO-INTERPRET
' DECR >EXECUTE IS COMP_DECR \ link to compiler
MACRO + ( n1 n2 -- sum )
[FORTH]
IMM/ABS_OPT ?DUP
IF 0<
IF
[ASSEMBLER]
ADD BX, # ( xxxx )
[FORTH]
ELSE
[ASSEMBLER]
ADD BX, ( xxxx )
[FORTH]
THEN
ELSE
[ASSEMBLER]
LODSW
ADD BX, AX
[FORTH]
THEN
[TARGET] END-MACRO EXECUTES> +
MACRO NEGATE ( n -- n' )
NEG BX END-MACRO EXECUTES> NEGATE
MACRO - ( n1 n2 -- n1-n2 )
[FORTH]
IMM/ABS_OPT ?DUP
IF 0<
IF
[ASSEMBLER]
SUB BX, # ( xxxx )
[FORTH]
ELSE
[ASSEMBLER]
SUB BX, ( xxxx )
[FORTH]
THEN
ELSE
[ASSEMBLER]
LODSW
SUB AX, BX
MOV BX, AX
[FORTH]
THEN
[TARGET] END-MACRO EXECUTES> -
MACRO ABS ( n1 -- n2 )
MOV AX, BX
CWD
XOR AX, DX
SUB AX, DX
MOV BX, AX END-MACRO EXECUTES> ABS
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
[ASSEMBLER]
ADD ( xxxx ) BX
[FORTH]
ELSE
[ASSEMBLER]
MOV DI, ( xxxx )
ADD 0 [DI], BX
[FORTH]
THEN
ELSE
[ASSEMBLER]
LODSW
ADD 0 [BX], AX
[FORTH]
THEN
LOAD_BX
[TARGET] END-MACRO NO-INTERPRET
' +! >EXECUTE IS COMP_PSTORE \ link to compiler
MACRO C+! ( n addr -- )
[FORTH]
IMM/ABS_OPT ?DUP
IF 0<
IF
[ASSEMBLER]
ADD ( xxxx ) BL
[FORTH]
ELSE
[ASSEMBLER]
MOV DI, ( xxxx )
ADD 0 [DI], BL
[FORTH]
THEN
ELSE
[ASSEMBLER]
LODSW
ADD 0 [BX], AL
[FORTH]
THEN
LOAD_BX END-MACRO NO-INTERPRET
MACRO PC@ ( port# -- n )
IMM_BEFORE
[FORTH]
IF DUP 255 >
IF
[ASSEMBLER]
MOV DX, # ( xxxx )
IN AL, DX
[FORTH]
ELSE
[ASSEMBLER]
IN AL, # ( xxxx )
[FORTH]
THEN
ELSE
[ASSEMBLER]
MOV DX, BX
IN AL, DX
[FORTH]
THEN
[ASSEMBLER]
SUB AH, AH
MOV BX, AX
[TARGET] END-MACRO NO-INTERPRET
MACRO P@ ( port# -- n )
IMM_BEFORE
[FORTH]
IF DUP 255 >
IF
[ASSEMBLER]
MOV DX, # ( xxxx )
IN AX, DX
MOV BX, AX
[FORTH]
ELSE
[ASSEMBLER]
IN AX, # ( xxxx )
MOV BX, AX
[FORTH]
THEN
ELSE
[ASSEMBLER]
MOV DX, BX
IN AX, DX
MOV BX, AX
[FORTH]
THEN
[TARGET] END-MACRO NO-INTERPRET
MACRO PC! ( n port# -- )
[FORTH]
IMM/ABS_OPT ?DUP
IF 0<
IF DUP 255 >
IF
[ASSEMBLER]
MOV AX, BX
MOV DX, # ( xxxx )
OUT DX, AL
[FORTH]
ELSE
[ASSEMBLER]
MOV AX, BX
OUT # ( xxxx ) AL
[FORTH]
THEN
ELSE
[ASSEMBLER]
MOV AX, BX
MOV DX, ( xxxx )
OUT DX, AL
[FORTH]
THEN
ELSE
[ASSEMBLER]
MOV DX, BX
LODSW
OUT DX, AL
[FORTH]
THEN
[ASSEMBLER]
LOAD_BX
[TARGET] END-MACRO NO-INTERPRET
MACRO P! ( n port# -- )
[FORTH]
IMM/ABS_OPT ?DUP
IF 0<
IF DUP 255 >
IF
[ASSEMBLER]
MOV AX, BX
MOV DX, # ( xxxx )
OUT DX, AX
[FORTH]
ELSE
[ASSEMBLER]
MOV AX, BX
OUT # ( xxxx ) AX
[FORTH]
THEN
ELSE
[ASSEMBLER]
MOV AX, BX
MOV DX, ( xxxx )
OUT DX, AX
[FORTH]
THEN
ELSE
[ASSEMBLER]
MOV DX, BX
LODSW
OUT DX, AX
[FORTH]
THEN
[ASSEMBLER]
LOAD_BX
[TARGET] END-MACRO NO-INTERPRET
ICODE PDOS ( addr drive# --- f1 ) \ get current directory to addr
\ return f1 true if failed
MOV DX, BX
LODSW
PUSH SI MOV SI, AX
MOV AH, # $47 INT $21
[ASSEMBLER]
U< IF
MOV AL, # 1
ELSE
SUB AL, AL
THEN
SUB AH, AH POP SI
MOV BX, AX
RET END-ICODE
MACRO 2* ( n -- 2*n )
SHL BX, # 1 END-MACRO EXECUTES> 2*
MACRO 4* ( n -- 2*n )
SHL BX, # 1
SHL BX, # 1 END-MACRO NO-INTERPRET
MACRO 2/ ( n -- n/2 )
SAR BX, # 1 END-MACRO EXECUTES> 2/
MACRO U2/ ( u -- u/2 )
SHR BX, # 1 END-MACRO EXECUTES> U2/
ICODE U16/ ( u -- u/16 )
SHR BX, # 1 SHR BX, # 1
SHR BX, # 1 SHR BX, # 1
RET END-ICODE
ICODE U8/ ( u -- u/8 )
SHR BX, # 1
SHR BX, # 1
SHR BX, # 1
RET END-ICODE
ICODE 8* ( n -- 8*n )
SHL BX, # 1
SHL BX, # 1
SHL BX, # 1
RET END-ICODE
MACRO 1+ ( n1 --- n2 )
INC BX END-MACRO EXECUTES> 1+
MACRO 2+ ( n1 --- n2 )
ADD BX, # 2 END-MACRO EXECUTES> 2+
MACRO 1- ( n1 --- n2 )
DEC BX END-MACRO EXECUTES> 1-
MACRO 2- ( n1 --- n2 )
SUB BX, # 2 END-MACRO EXECUTES> 2-
ICODE UM* ( n1 n2 -- d )
MOV AX, 0 [SI]
MUL BX
MOV 0 [SI], AX
XCHG BX, DX
RET END-ICODE
MACRO * ( n1 n2 -- n3 )
[FORTH]
IMM/ABS_OPT ?DUP
IF 0<
IF
[ASSEMBLER]
MOV AX, # ( xxxx )
[FORTH]
ELSE
[ASSEMBLER]
MOV AX, ( xxxx )
[FORTH]
THEN
ELSE
[ASSEMBLER]
LODSW
[FORTH]
THEN
[ASSEMBLER]
MUL BX
MOV BX, AX
[TARGET] END-MACRO EXECUTES> *
M: U*D ( n1 n2 -- d )
UM* ; NO-INTERPRET
CODE UM/MOD ( ud un -- URemainder UQuotient )
NO_INLINE
XCHG SI, SP
POP DX
POP AX
CMP DX, BX
[ASSEMBLER]
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-CODE
MACRO 0= ( n -- f )
SUB BX, # 1
SBB BX, BX END-MACRO EXECUTES> 0=
MACRO 0< ( n -- f )
MOV AX, BX
CWD
MOV BX, DX END-MACRO EXECUTES> 0<
CODE 0> ( n -- f )
NO_INLINE
MOV AX, BX
NEG AX
[ASSEMBLER]
OV<> IF CWD
MOV BX, DX
RET
THEN
SUB BX, BX
RET END-CODE
IMACRO 0<> ( n -- f )
NEG BX
SBB BX, BX END-IMACRO
MACRO = ( n1 n2 -- f )
[FORTH]
IMM/ABS_OPT ?DUP
IF 0<
IF
[ASSEMBLER]
SUB BX, # ( xxxx )
[FORTH]
ELSE
[ASSEMBLER]
SUB BX, ( xxxx )
[FORTH]
THEN
ELSE
[ASSEMBLER]
LODSW
SUB BX, AX
[FORTH]
THEN
[ASSEMBLER]
SUB BX, # 1
SBB BX, BX
[TARGET] END-MACRO NO-INTERPRET
MACRO <> ( n1 n2 -- f )
[FORTH]
IMM/ABS_OPT ?DUP
IF 0<
IF
[ASSEMBLER]
SUB BX, # ( xxxx )
[FORTH]
ELSE
[ASSEMBLER]
SUB BX, ( xxxx )
[FORTH]
THEN
ELSE
[ASSEMBLER]
LODSW
SUB BX, AX
[FORTH]
THEN
[ASSEMBLER]
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 )
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
[ASSEMBLER]
MOV AX, # ( xxxx )
SUB AX, BX
SBB AX, AX
MOV BX, AX
[FORTH]
ELSE
[ASSEMBLER]
MOV AX, ( xxxx )
SUB AX, BX
SBB AX, AX
MOV BX, AX
[FORTH]
THEN
ELSE
[ASSEMBLER]
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
[ASSEMBLER]
>= IF SUB DI, DI
THEN
MOV BX, DI
RET END-ICODE
ICODE > ( n1 n2 -- f )
LODSW
MOV DI, # TRUE
CMP AX, BX
[ASSEMBLER]
<= IF SUB DI, DI
THEN
MOV BX, DI
RET END-ICODE
ICODE UMIN ( n1 n2 -- n3 )
LODSW
CMP BX, AX
[ASSEMBLER]
U> IF MOV BX, AX
THEN
RET END-ICODE
ICODE MIN ( n1 n2 -- n3 )
LODSW
CMP BX, AX
[ASSEMBLER]
> IF MOV BX, AX
THEN
RET END-ICODE
ICODE MAX ( n1 n2 -- n3 )
LODSW
CMP BX, AX
[ASSEMBLER]
<= IF MOV BX, AX
THEN
RET END-ICODE
IMACRO 0MAX ( n1 -- n3 )
[ASSEMBLER]
CMP BX, BP
<= IF SUB BX, BX
THEN END-IMACRO
ICODE UMAX ( n1 n2 -- n3 )
[ASSEMBLER]
LODSW
CMP BX, AX
U<= IF MOV BX, AX
THEN
RET END-ICODE
ICODE WITHIN ( n lo hi -- flag )
[ASSEMBLER]
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 )
[ASSEMBLER]
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
ICODE UBETWEEN ( n ulo uhi -- flag )
[ASSEMBLER]
MOV DX, BX
LODSW
MOV CX, AX
LODSW
SUB BX, BX
CMP AX, DX
U<= IF CMP AX, CX
U>= 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_BX END-MACRO EXECUTES> 2DROP
IMACRO 3DROP ( n1 n2 n3 -- )
ADD SI, # 4
LOAD_BX 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_BX
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 )
[ASSEMBLER]
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
M: D- ( d1 d2 -- d3 )
DNEGATE D+ ; NO-INTERPRET
: ?DNEGATE ( d1 n -- d2 )
0< IF DNEGATE THEN ; NO-INTERPRET
M: D0= ( d -- f )
OR 0= ; NO-INTERPRET
M: 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
M: D> ( d1 d2 -- f )
2SWAP D< ; NO-INTERPRET
M: 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> ;
CODE / ( num den --- quot )
LODSW
CWD
MOV CX, BX XOR CX, DX
[ASSEMBLER]
0>= IF \ POSITIVE QUOTIENT CASE
IDIV BX
ELSE
IDIV BX OR DX, DX
0<> IF
DEC AX
THEN
THEN
MOV BX, AX
RET END-CODE EXECUTES> /
ICODE /MOD ( num den --- rem quot )
MOV AX, 0 [SI] CWD
MOV CX, BX XOR CX, DX
[ASSEMBLER]
0>= IF
IDIV BX
ELSE
IDIV BX
OR DX, DX
0<> IF
ADD DX, BX
DEC AX
THEN
THEN
MOV 0 [SI], DX
MOV BX, AX
RET END-ICODE
M: 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
[ASSEMBLER]
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
[ASSEMBLER]
XOR BX, # ( xxxx )
[FORTH]
ELSE
[ASSEMBLER]
XOR BX, ( xxxx )
[FORTH]
THEN
ELSE
[ASSEMBLER]
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
M: */ ( 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
ICODE FILL ( start-addr count char -- )
XCHG SI, SP
MOV AX, BX
CLD MOV BX, DS
POP CX POP DI
XCHG SI, SP
PUSH ES MOV ES, BX
REPNZ STOSB POP ES
LOAD_BX
RET END-ICODE
ICODE LFILL ( seg start-addr count char -- )
XCHG SI, SP
CLD
MOV AX, BX POP CX
POP DI POP BX
XCHG SI, SP
PUSH ES MOV ES, BX
REPNZ STOSB POP ES
LOAD_BX
RET END-ICODE
ICODE LFILLW ( seg start-addr BYTE-count WORD -- )
SAVE_BX
XCHG SI, SP
CLD POP AX
POP CX
SHR CX, # 1
POP DI POP BX
MOV DX, ES MOV ES, BX
REPNZ STOSW
MOV ES, DX
XCHG SI, SP
LOAD_BX
RET END-ICODE
: ERASE ( addr len -- )
0 FILL ; NO-INTERPRET
$20 CONSTANT BL \ a blank
$80 CONSTANT DOS_CMD_TAIL \ DOS command line pointer in ?CS: space
: BLANK ( addr len -- )
BL FILL ; NO-INTERPRET
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
[ASSEMBLER]
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
[ASSEMBLER]
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
CODE CRLF>BL'S ( a1 --- a1 ) \ change CRLF at end of string to blanks
\ leaving the string address on the stack
mov cx, bx \ Same as -> DUP COUNT + 2- DUP @ $0D0A =
mov al, 0 [bx] \ IF 8224 SWAP ! ELSE DROP DROP ;
sub ah, ah
add bx, ax
dec bx
cmp 0 [bx], # $0A0D word \ if line ends in CRLF
0= if mov 0 [bx], # 8224 word \ change then to blanks
then
mov bx, cx
RET END-CODE
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 TIB0
VARIABLE #EXSTRT
VARIABLE FUDGE
VARIABLE ATTRIB
VARIABLE LMARGIN
VARIABLE RMARGIN
VARIABLE TABSIZE
VARIABLE PRINTING
DEFER AT?
DEFER AT
DEFER KEY
DEFER EMIT
DEFER TYPE
DEFER SPACES
DEFER CR EXECUTES> CR
DEFER DARK EXECUTES> DARK
' DARK ALIAS CLS
CODE COMP ( addr1 addr2 len -- -1 | 0 | 1 )
[ASSEMBLER]
XCHG SI, SP
MOV DX, SI MOV CX, BX
POP DI POP SI
CX<>0 IF PUSH ES MOV ES, SSEG
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-CODE
CODE CAPS-COMP ( addr1 addr2 len -- -1 | 0 | 1 )
[ASSEMBLER]
PUSH ES
XCHG SI, SP
MOV DX, SI MOV CX, BX
POP DI POP SI
MOV ES, SSEG
BEGIN
JCXZ 0 $
MOV AH, 0 [SI] INC SI
MOV AL, ES: 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
POP ES
RET END-CODE
CODE SKIP ( addr len char -- addr' len' ) \ skip char forwards
[ASSEMBLER]
LODSW MOV CX, AX
MOV AX, BX
CX<>0 IF MOV DI, 0 [SI]
MOV DX, ES MOV ES, SSEG
REPZ SCASB
MOV ES, DX
0<> IF
INC CX
DEC DI
THEN
MOV 0 [SI], DI
THEN MOV BX, CX
RET END-CODE
CODE -SKIP ( addr len char -- addr' len' ) \ skip char backwards
[ASSEMBLER]
LODSW MOV CX, AX
MOV AX, BX
CX<>0 IF MOV DI, 0 [SI]
MOV DX, ES MOV ES, SSEG
STD REPZ SCASB CLD
MOV ES, DX
0<> IF
INC CX
DEC DI
THEN
MOV 0 [SI], DI
THEN MOV BX, CX
RET END-CODE
CODE SCAN ( addr len char -- addr' len' ) \ scan char forwards
[ASSEMBLER]
LODSW MOV CX, AX
MOV AX, BX
CX<>0 IF MOV DI, 0 [SI]
MOV DX, ES MOV ES, SSEG
REPNZ SCASB
MOV ES, DX
0= IF INC CX
DEC DI
THEN
MOV 0 [SI], DI
THEN MOV BX, CX
RET END-CODE
CODE -SCAN ( addr len char -- addr' len' ) \ scan char backwards
[ASSEMBLER]
LODSW MOV CX, AX
MOV AX, BX
CX<>0 IF MOV DI, 0 [SI]
MOV DX, ES MOV ES, SSEG
STD REPNZ SCASB CLD
MOV ES, DX
0= IF DEC CX
INC DI
THEN
MOV 0 [SI], DI
THEN MOV BX, CX
RET END-CODE
ICODE /STRING ( addr len n -- addr' len' )
LODSW
XCHG BX, AX
CMP BX, AX
[ASSEMBLER]
U<= IF MOV AX, BX \ AX = SMALLER OF AX BX
THEN
ADD 0 [SI], AX
SUB BX, AX
RET END-ICODE
CODE DIGIT ( char base -- n f )
NO_INLINE
[ASSEMBLER]
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-CODE
M: HERE ( -- A1 ) \ return a1 the address of the next available
\ free memory space in data ram
DP @ ; EXECUTES> HERE
M: PAD ( -- a1 ) \ a place to put things for a bit
DP @ 82 + ; EXECUTES> PAD
M: ALLOT ( n1 -- ) \ allot some DS: ram
DP +! ; EXECUTES> ALLOT-D
: 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
M: HEX ( -- )
$10 BASE ! ; EXECUTES> HEX
M: DECIMAL ( -- )
$0A BASE ! ; EXECUTES> DECIMAL
M: 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 ) \ n1 = segment returned by ALLOC
PUSH ES MOV ES, BX
MOV AH, # $49
INT $21
[ASSEMBLER]
U< IF SUB AH, AH
ELSE SUB AX, AX
THEN
POP ES
MOV BX, AX
RET END-ICODE
ICODE ALLOC ( n1 -- n2 n3 f1 ) \ n1 = "PARAGRAPHS" not bytes
\ n2 = largest available if failed
\ n3 = segment start if succeeded
\ f1 = 8 if failed else don't care
XCHG SI, SP
MOV AH, # $48
INT $21
PUSH BX
PUSH AX
[ASSEMBLER]
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
[ASSEMBLER]
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 )
[ASSEMBLER] \ 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_BX
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
: IBM-AT? ( -- x y ) \ return the current cursor position
0 0 0 $0300 VIDEO DROP SPLIT ; NO-INTERPRET
: IBM-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
: IBM-DARK ( -- ) \ fetch and store video mode thus
\ clearing the screen.
VMODE@ VMODE! #OUT OFF #LINE OFF ; NO-INTERPRET
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_BX
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
CODE PEMIT ( c1 -- )
MOV DX, # 0 \ PRINTER NUMBER
MOV AL, BL
MOV AH, # 0
PUSH SI PUSH BP
INT $17
POP BP POP SI
INC #OUT WORD
LOAD_BX
RET END-CODE
: (EMIT) ( C1 -- )
PRINTING @
IF PEMIT
ELSE DOSEMIT
THEN ; NO-INTERPRET
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
[ASSEMBLER]
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
' %KEY ALIAS (KEY)
: 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
' %TYPE ALIAS (TYPE)
: EEOL ( -- ) \ Erase to end of line
80 #OUT @ - 0MAX SPACES ; EXECUTES> EEOL
: CRLF ( -- )
$0D (EMIT) $0A (EMIT)
#OUT OFF #LINE @ 1+ ( 24 MIN ) #LINE ! ;
: $>TIB ( A1 --- )
COUNT DUP #TIB ! TIB SWAP CMOVE >IN OFF ; NO-INTERPRET
: MARGIN_INIT ( -- )
LMARGIN OFF 64 RMARGIN ! \ default margins
8 TABSIZE ! ; NO-INTERPRET
: MS ( n1 -- ) \ Delay n1 units of about a millisecond.
FOR FUDGE @ 1+ FOR NEXT
NEXT ; EXECUTES> MS
ICODE TT['] ( -- 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
: DOSIO_INIT ( -- ) \ initialize the DOS I/O words
TT['] CRLF !> CR
TT['] IBM-AT? !> AT?
TT['] IBM-AT !> AT \ init AT
TT['] %KEY !> KEY \ KEY,
TT['] (EMIT) !> EMIT \ EMIT,
TT['] (TYPE) !> TYPE \ TYPE,
TT['] %SPACES !> SPACES \ SPACES
TT['] IBM-DARK !> DARK \ and DARK
AT? AT ;
: ?LINE ( N -- )
#OUT @ + RMARGIN @ > IF CR LMARGIN @ SPACES THEN ;
NO-INTERPRET
: ?CR ( -- )
0 ?LINE ; NO-INTERPRET
0 VALUE ABORT_FUNC
: ABORT ( -- ) \ Just leave when we abort
ABORT_FUNC ?DUP
IF EXECUTE
ELSE CR BYE
THEN ; EXECUTES> ABORT
: ?ABORT" ( f1 a1 n1 -- ) \ display string a1,n1 & abort if f1 true
ROT
IF TYPE ABORT
ELSE 2DROP
THEN ;
FORTH >FORTH
: %T['] ( | <name> -- a1 )
F['] TT['] RES_COMP_CALL
[FORTH] ' DUP RES_COMP_CALL >DTYPE C@ {S} <>
ABORT" is NOT a subroutine, Can ONLY ['] subroutines!" ;
IMMEDIATE
' %T['] IS T[']
: %L['] ( | <name> -- a1 )
COMPILE RES_COMP_CLL F['] TT['] X,
COMPILE RES_COMP_CLL [FORTH] ' DUP X,
>DTYPE C@ {S} <>
ABORT" is NOT a subroutine, Can ONLY ['] subroutines!" ;
IMMEDIATE
' %L['] IS L[']
: %T." ( | string" -- )
[COMPILE] T"
F['] TYPE RES_COMP_DEFER ; IMMEDIATE
' %T." IS T."
: %L." ( | string" -- )
[COMPILE] L"
COMPILE RES_COMP_DEF F['] TYPE X, ; IMMEDIATE
' %L." IS L."
: %TABORT" ( | string" -- )
[COMPILE] T" F['] ?ABORT" COMP_CALL ; IMMEDIATE
' %TABORT" IS TABORT"
: %LABORT" ( | string" -- )
[COMPILE] L"
COMPILE <'> COMPILE ?ABORT" COMPILE COMP_CALL ; IMMEDIATE
' %LABORT" IS LABORT"
TARGET >LIBRARY
\ n1 = DS: ram in bytes for target program
: SET_MEMORY ( n1 -- ) \ adjust allocated memory for target
PAD 40 + UMAX \ clip to above used ram
65500 400 -
UMIN DUP PAD ! \ save end of DS: mem
DUP 2+ DUP TIB0 ! 'TIB ! \ reset TIB
DUP SP0 ! SP! \ reset data stack
RP@ RP0 @ OVER - >R PAD @ 300 + R@ - R@ CMOVE R>
\ move return stack down
PAD @ 300 + DUP RP0 ! SWAP - RP! \ reset return stack
PAD @ 400 + PARAGRAPH \ paragraphs desired
?DS: ?CS: - + \ + CODE memory + segments
?CS: SWAP SETBLOCK \ adj memory
IF CR ." Couldn't adjust memory size!"
BYE
THEN ;
: TAB ( -- )
#OUT @ TABSIZE @ MOD TABSIZE @ SWAP - SPACES ;
EXECUTES> TAB
: BEEP ( -- )
7 (EMIT) #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
: DOS_EXPECT ( a1 n1 -- )
AT? >R >R
%DOSEXPECT DUP SPAN ! R> + R> AT ; NO-INTERPRET
ALSO HTARGET DEFINITIONS TARGET
: DOEXP1 ( A1 C1 N1 -- A2 N2 ) \ n2 = loop count
OVER $C7 = ( HOME ) \ if Home, then clear line
IF DUP>R AT? >R SWAP - R> 2DUP AT R@ SPACES AT R>
NEGATE >R DROP R@ + R>
EXIT
THEN
OVER $08 = ( BACKSPACE ) \ if BS then backup one
IF 0=
IF DROP BEEP 0 \ or BEEP if at beginning
ELSE (EMIT) \ backup one char
BL (EMIT)
8 (EMIT) \ erase chars space
-4 #OUT +!
1- -1
THEN EXIT \ leave if BACKSPACE
THEN DROP \ discard current index
DUP $1B = ( ESC ) \ char = ESC?, then cancel
IF DROP \ discard char
#EXSTRT @ ?DUP
IF SPAN @ SWAP ABS SPAN !
ELSE SPAN @ SPAN OFF \ skip to end
THEN
ESC_FLG ON \ set escaped flag
ELSE \ else emit, and bump to next
DUP EMIT OVER C! 1+ 1
THEN ;
: #EXSTRT_@+ ( a1 -- a2 n1 ) \ adj a1 by #exstrt
#EXSTRT @ DUP>R + R> DUP NEGATE #EXSTRT ! ;
TARGET DEFINITIONS PREVIOUS
: #EXPECT ( a1 n1 n1 -- ) \ EXPECT chars n1 into addr a1.
\ starting at char n2 in string
0MAX DUP #EXSTRT ! ?DUP
IF 2 PICK SWAP TYPE \ display text sofar
THEN
ESC_FLG OFF
DUP SPAN ! 0
?DO #EXSTRT @ 0>
IF #EXSTRT_@+
ELSE KEY DUP $0D = \ if CR then leave, done
IF DROP I SPAN ! LEAVE
ELSE I DOEXP1
THEN
THEN
+LOOP DROP ;
: EXPECT ( a1 n1 -- ) \ expect chars n1 into addr a1
0 #EXPECT ; NO-INTERPRET
: QUERY ( -- )
TIB 80 EXPECT SPAN @ #TIB ! >IN OFF ; NO-INTERPRET
: UPC ( c1 -- c2 )
DUP 'a' 'z' BETWEEN
IF $5F AND
THEN ; NO-INTERPRET
: UPPER ( addr len -- )
BOUNDS
?DO I C@ UPC I C!
LOOP ; NO-INTERPRET
: ?UPPERCASE ( a1 -- a1 )
CAPS @
IF DUP COUNT UPPER
THEN ; NO-INTERPRET
: NOOP ( -- )
; EXECUTES> NOOP
: H.R ( n1 n2 -- )
BASE @ >R HEX U.R R> BASE ! ;
: H. ( n1 -- )
1 H.R SPACE ; EXECUTES> H.
M: ">$ ( a1 n1 -- a2 )
DROP 1- ; NO-INTERPRET
M: U<= ( u1 u2 -- f ) U> NOT ; NO-INTERPRET
M: U>= ( u1 u2 -- f ) U< NOT ; NO-INTERPRET
M: <= ( n1 n2 -- f ) > NOT ; NO-INTERPRET
M: >= ( n1 n2 -- f ) < NOT ; NO-INTERPRET
M: 0>= ( n1 n2 -- f ) 0< NOT ; NO-INTERPRET
M: 0<= ( n1 n2 -- f ) 0> NOT ; NO-INTERPRET
: ?KEYPAUSE ( --- ) \ Pause if key pressed
KEY?
IF KEY 27 = IF ABORT THEN
KEY 27 = IF ABORT THEN
THEN ; NO-INTERPRET
0 VALUE DUMP_OFF
: DUMP_1LINE ( seg a1 -- seg a2 )
CR DUP DUMP_OFF + 4 H.R ." | "
2DUP 15 FOR 2DUP C@L 3 H.R 1+ NEXT 2DROP ." | "
15 FOR 2DUP C@L $7F AND BL MAX EMIT 1+ NEXT ;
: %LDUMP ( seg addr len -- )
0
DO DUMP_1LINE ?KEYPAUSE
16 +LOOP 2DROP ;
: LDUMP ( seg addr len -- )
OFF> DUMP_OFF %LDUMP ;
: DUMP ( addr len -- )
?DS: -ROT LDUMP ; EXECUTES> DUMP
: #input ( --- n1 )
query bl word number? 0= abort" Must be a NUMBER" drop ;
' !> ALIAS =: IMMEDIATE
' !> ALIAS IS IMMEDIATE
>FORTH