665 lines
9 KiB
Lua
665 lines
9 KiB
Lua
base_fth = [[
|
|
: HEX 16 BASE ! ;
|
|
: DEC 10 BASE ! ;
|
|
: OCT 8 BASE ! ;
|
|
: BIN 2 BASE ! ;
|
|
|
|
: C! SWAP 255 AND SWAP ! ;
|
|
: C@ @ 255 AND ;
|
|
: C,
|
|
HERE @ C!
|
|
1 HERE +!
|
|
;
|
|
|
|
: LITERAL IMMEDIATE
|
|
COMP' LIT ,
|
|
,
|
|
;
|
|
: CHAR BL WORD 1+ C@ ;
|
|
|
|
: '"' [ CHAR " ] LITERAL ;
|
|
: '[' [ CHAR [ ] LITERAL ;
|
|
: ']' [ CHAR ] ] LITERAL ;
|
|
: '(' [ CHAR ( ] LITERAL ;
|
|
: ')' [ CHAR ) ] LITERAL ;
|
|
: ':' [ CHAR : ] LITERAL ;
|
|
: ';' [ CHAR ; ] LITERAL ;
|
|
: '0' [ CHAR 0 ] LITERAL ;
|
|
: 'A' [ CHAR A ] LITERAL ;
|
|
: '-' [ CHAR - ] LITERAL ;
|
|
: '.' [ CHAR . ] LITERAL ;
|
|
|
|
: CR 10 EMIT ;
|
|
: SPACE 32 EMIT ;
|
|
|
|
: ' BL WORD FIND >CFA ;
|
|
: [COMPILE] IMMEDIATE ' , ;
|
|
: ['] IMMEDIATE ' [COMPILE] LITERAL ;
|
|
: LIT, ['] LIT , , ;
|
|
|
|
: / /MOD SWAP DROP ;
|
|
: MOD /MOD DROP ;
|
|
|
|
: U/ UM/MOD SWAP DROP ;
|
|
: UMOD UM/MOD DROP ;
|
|
|
|
: NOT 0= ;
|
|
|
|
: RECURSE IMMEDIATE
|
|
LATEST @
|
|
>CFA ,
|
|
;
|
|
|
|
: IF IMMEDIATE
|
|
['] 0BRANCH ,
|
|
HERE @
|
|
0 ,
|
|
;
|
|
: THEN IMMEDIATE
|
|
DUP
|
|
HERE @ SWAP -
|
|
SWAP !
|
|
;
|
|
: ELSE IMMEDIATE
|
|
['] BRANCH ,
|
|
HERE @
|
|
0 ,
|
|
SWAP
|
|
DUP HERE @ SWAP -
|
|
SWAP !
|
|
;
|
|
|
|
: ?HIDDEN 1+ C@ F_HIDDEN AND ;
|
|
: ?IMMEDIATE 1+ C@ F_IMMED AND ;
|
|
|
|
: EXECUTE-COMPILING
|
|
STATE @ IF EXECUTE EXIT THEN
|
|
] EXECUTE [
|
|
;
|
|
|
|
: POSTPONE IMMEDIATE
|
|
BL WORD FIND
|
|
DUP ?IMMEDIATE
|
|
SWAP >CFA LIT,
|
|
IF ['] EXECUTE-COMPILING ELSE ['] , THEN ,
|
|
;
|
|
|
|
: BEGIN IMMEDIATE HERE @ ;
|
|
: UNTIL IMMEDIATE
|
|
POSTPONE 0BRANCH
|
|
HERE @ - ,
|
|
;
|
|
: AGAIN IMMEDIATE
|
|
POSTPONE BRANCH
|
|
HERE @ - ,
|
|
;
|
|
: WHILE IMMEDIATE
|
|
POSTPONE 0BRANCH
|
|
HERE @
|
|
0 ,
|
|
;
|
|
: REPEAT IMMEDIATE
|
|
POSTPONE BRANCH
|
|
SWAP HERE @ - ,
|
|
DUP HERE @ SWAP - SWAP !
|
|
;
|
|
: UNLESS IMMEDIATE
|
|
POSTPONE NOT
|
|
POSTPONE IF
|
|
;
|
|
|
|
: ( IMMEDIATE
|
|
1
|
|
BEGIN
|
|
KEY DUP '(' = IF
|
|
DROP
|
|
1+
|
|
ELSE
|
|
')' = IF
|
|
1-
|
|
THEN
|
|
THEN
|
|
DUP 0= UNTIL
|
|
DROP
|
|
;
|
|
|
|
: NIP ( x y -- y ) SWAP DROP ;
|
|
: TUCK ( x y -- y x y ) SWAP OVER ;
|
|
: PICK ( xn ... x1 x0 n -- xn ... x1 x0 xn )
|
|
1+ 1 CELLS * DSP@ + @
|
|
;
|
|
|
|
( Print many of a character )
|
|
: MANY ( n c -- )
|
|
SWAP
|
|
BEGIN
|
|
DUP 0>
|
|
WHILE
|
|
OVER EMIT
|
|
1-
|
|
REPEAT
|
|
2DROP
|
|
;
|
|
|
|
: SPACES ( n -- )
|
|
BL MANY
|
|
;
|
|
|
|
: ZEROS ( n -- )
|
|
'0' MANY
|
|
;
|
|
|
|
: U. ( u -- )
|
|
BASE @ UM/MOD ( base rem quot )
|
|
?DUP IF
|
|
RECURSE
|
|
THEN
|
|
|
|
DUP 10 < IF
|
|
'0'
|
|
ELSE
|
|
10 -
|
|
'A'
|
|
THEN
|
|
+ EMIT
|
|
;
|
|
|
|
( Get number of chars in an unsigend number )
|
|
: UWIDTH ( u -- width )
|
|
BASE @ U/ ( rem quot)
|
|
?DUP IF ( if quot <> 0 )
|
|
RECURSE 1+
|
|
ELSE
|
|
1
|
|
THEN
|
|
;
|
|
|
|
( Get number of chars in an unsigend number )
|
|
: SWIDTH ( u -- width )
|
|
DUP 0< IF NEGATE THEN
|
|
BASE @ / ( rem quot)
|
|
?DUP IF ( if quot <> 0 )
|
|
RECURSE 1+
|
|
ELSE
|
|
1
|
|
THEN
|
|
;
|
|
|
|
( Left pad number )
|
|
: U.R ( u width -- )
|
|
SWAP
|
|
DUP
|
|
UWIDTH
|
|
ROT
|
|
SWAP -
|
|
SPACES
|
|
U.
|
|
;
|
|
|
|
( Zero pad number )
|
|
: U.0R ( u width -- )
|
|
SWAP
|
|
DUP
|
|
UWIDTH
|
|
ROT
|
|
SWAP -
|
|
ZEROS
|
|
U.
|
|
;
|
|
|
|
( Print left padded signed number )
|
|
: .R
|
|
SWAP
|
|
DUP 0< IF
|
|
NEGATE
|
|
1
|
|
SWAP
|
|
ROT
|
|
1-
|
|
ELSE
|
|
0
|
|
SWAP
|
|
ROT
|
|
THEN
|
|
SWAP
|
|
DUP
|
|
SWIDTH
|
|
ROT
|
|
SWAP -
|
|
|
|
SPACES
|
|
SWAP
|
|
|
|
IF
|
|
'-' EMIT
|
|
THEN
|
|
|
|
U.
|
|
;
|
|
|
|
( Print zero padded signed number )
|
|
: .0R
|
|
SWAP
|
|
DUP 0< IF
|
|
NEGATE
|
|
1
|
|
SWAP
|
|
ROT
|
|
1-
|
|
ELSE
|
|
0
|
|
SWAP
|
|
ROT
|
|
THEN
|
|
SWAP
|
|
DUP
|
|
SWIDTH
|
|
ROT
|
|
SWAP -
|
|
|
|
ZEROS
|
|
SWAP
|
|
|
|
IF
|
|
'-' EMIT
|
|
THEN
|
|
|
|
U.
|
|
;
|
|
|
|
: . 0 .R SPACE ;
|
|
: U. U. SPACE ;
|
|
|
|
: .S ( Print the stack )
|
|
DSP@ S0 @
|
|
BEGIN
|
|
2DUP <
|
|
WHILE
|
|
1-
|
|
DUP @ .
|
|
SPACE
|
|
REPEAT
|
|
2DROP
|
|
CR
|
|
;
|
|
|
|
( Print number at address )
|
|
: ? ( addr -- ) @ . ;
|
|
|
|
: WITHIN
|
|
-ROT OVER
|
|
<= IF
|
|
> IF
|
|
TRUE
|
|
ELSE
|
|
FALSE
|
|
THEN
|
|
ELSE
|
|
2DROP
|
|
FALSE
|
|
THEN
|
|
;
|
|
|
|
( Returns depth of stack )
|
|
: DEPTH ( -- n )
|
|
S0 @ DSP@ -
|
|
1-
|
|
;
|
|
|
|
: S" IMMEDIATE
|
|
STATE @ IF
|
|
POSTPONE LITSTRING
|
|
HERE @
|
|
0 ,
|
|
BEGIN
|
|
KEY
|
|
DUP '"' <>
|
|
WHILE
|
|
C,
|
|
REPEAT
|
|
DROP
|
|
DUP
|
|
HERE @ SWAP -
|
|
1-
|
|
SWAP !
|
|
ELSE
|
|
HERE @
|
|
BEGIN
|
|
KEY
|
|
DUP '"' <>
|
|
WHILE
|
|
OVER C!
|
|
1+
|
|
REPEAT
|
|
DROP
|
|
HERE @ -
|
|
HERE @
|
|
SWAP
|
|
THEN
|
|
;
|
|
|
|
: ." IMMEDIATE
|
|
STATE @ IF
|
|
POSTPONE S"
|
|
POSTPONE TELL
|
|
ELSE
|
|
BEGIN
|
|
KEY
|
|
DUP '"' = IF
|
|
DROP
|
|
EXIT
|
|
THEN
|
|
EMIT
|
|
AGAIN
|
|
THEN
|
|
;
|
|
|
|
: DOES>
|
|
STATE @ IF
|
|
POSTPONE (DOES>)
|
|
ELSE
|
|
HERE @ ( HERE )
|
|
LATEST @ >CFA ( HERE CFA )
|
|
DUP [ ' DODOES @ ] LITERAL SWAP ! ( Write CW of DODOES to CFA )
|
|
1+ ! ( Write HERE to >DOES )
|
|
LATEST @ HIDDEN
|
|
]
|
|
THEN
|
|
; IMMEDIATE
|
|
|
|
: VARIABLE CREATE 0 , ;
|
|
: CONSTANT CREATE , DOES> @ ;
|
|
|
|
: VALUE ( n -- )
|
|
CREATE ,
|
|
DOES> ( -- n )
|
|
@
|
|
;
|
|
|
|
: TO ( n "name" -- )
|
|
' >BODY !
|
|
;
|
|
|
|
: +TO ( n "name" -- )
|
|
' >BODY +!
|
|
;
|
|
|
|
0 VALUE I
|
|
: SETI [ ' I >BODY ] LITERAL ! ;
|
|
|
|
: DO IMMEDIATE ( C: -- HERE ) ( LIMIT I -- )
|
|
SETI
|
|
R> ( r: -- LIMIT )
|
|
HERE @ ( C: -- HERE )
|
|
;
|
|
|
|
: (LOOP)
|
|
I 1+ DUP SETI
|
|
R@ >
|
|
0BRANCH
|
|
;
|
|
|
|
: (UNLOOP)
|
|
>R DROP
|
|
;
|
|
|
|
: LOOP IMMEDIATE
|
|
POSTPONE (LOOP)
|
|
HERE @ - ,
|
|
POSTPONE (UNLOOP)
|
|
;
|
|
|
|
: ID.
|
|
1+ ( Skip link pointer )
|
|
DUP C@ ( entry flags )
|
|
F_LENMASK AND ( entry len)
|
|
|
|
BEGIN
|
|
DUP 0> ( entry len len>0? )
|
|
WHILE
|
|
SWAP 1+ ( len entry+1 )
|
|
DUP C@ EMIT
|
|
SWAP 1- ( entry+1 len-1 )
|
|
REPEAT
|
|
2DROP ( entry len -- )
|
|
;
|
|
|
|
: WORDS
|
|
LATEST @
|
|
BEGIN
|
|
?DUP
|
|
WHILE
|
|
DUP ?HIDDEN IF
|
|
." (H)"
|
|
THEN
|
|
DUP ?IMMEDIATE IF
|
|
." (I)"
|
|
THEN
|
|
DUP ID. SPACE
|
|
@
|
|
REPEAT
|
|
CR
|
|
;
|
|
|
|
: HIDE
|
|
BL WORD FIND
|
|
HIDDEN
|
|
;
|
|
|
|
: FORGET
|
|
BL WORD FIND
|
|
DUP @ LATEST !
|
|
HERE !
|
|
;
|
|
|
|
: DUMP ( addr len -- )
|
|
( Save BASE )
|
|
BASE @ -ROT
|
|
|
|
BEGIN
|
|
?DUP
|
|
WHILE
|
|
HEX
|
|
OVER 8 U.0R
|
|
4 SPACES
|
|
|
|
( Print hex )
|
|
2DUP
|
|
1- 15 AND 1+
|
|
BEGIN
|
|
?DUP
|
|
WHILE
|
|
SWAP
|
|
DUP
|
|
5 PICK DEC 10 = IF
|
|
@ 0 DEC
|
|
ELSE
|
|
C@ 2 HEX
|
|
THEN
|
|
.0R SPACE
|
|
1+ SWAP 1-
|
|
REPEAT
|
|
DROP
|
|
|
|
3 SPACES
|
|
|
|
( Print ascii )
|
|
2DUP
|
|
1- 15 AND 1+
|
|
BEGIN
|
|
?DUP
|
|
WHILE
|
|
SWAP
|
|
DUP C@
|
|
DUP 32 128 WITHIN IF
|
|
EMIT
|
|
ELSE
|
|
DROP '.' EMIT
|
|
THEN
|
|
1+ SWAP 1-
|
|
REPEAT
|
|
DROP
|
|
CR
|
|
|
|
DUP 1- 15 AND 1+
|
|
TUCK
|
|
-
|
|
>R + R>
|
|
REPEAT
|
|
|
|
DROP
|
|
BASE !
|
|
;
|
|
|
|
: CASE IMMEDIATE
|
|
0
|
|
;
|
|
|
|
: OF IMMEDIATE
|
|
POSTPONE OVER
|
|
POSTPONE =
|
|
POSTPONE IF
|
|
POSTPONE DROP
|
|
;
|
|
|
|
: ENDOF IMMEDIATE
|
|
POSTPONE ELSE
|
|
;
|
|
|
|
: ENDCASE IMMEDIATE
|
|
POSTPONE DROP
|
|
|
|
( Compile THEN's for each ELSE )
|
|
BEGIN
|
|
?DUP
|
|
WHILE
|
|
POSTPONE THEN
|
|
REPEAT
|
|
;
|
|
|
|
: CFA>
|
|
LATEST @
|
|
BEGIN
|
|
?DUP
|
|
WHILE
|
|
2DUP SWAP
|
|
< IF
|
|
NIP
|
|
EXIT
|
|
THEN
|
|
@
|
|
REPEAT
|
|
DROP
|
|
0
|
|
;
|
|
|
|
: SEE
|
|
BL WORD FIND
|
|
|
|
HERE @
|
|
LATEST @
|
|
BEGIN
|
|
2 PICK
|
|
OVER
|
|
<>
|
|
WHILE
|
|
NIP
|
|
DUP @
|
|
REPEAT
|
|
|
|
DROP SWAP
|
|
|
|
':' EMIT SPACE DUP ID. CR
|
|
DUP ?IMMEDIATE IF ." IMMEDIATE " THEN
|
|
|
|
>DFA
|
|
|
|
BEGIN
|
|
2DUP >
|
|
WHILE
|
|
DUP @
|
|
|
|
CASE
|
|
['] LIT OF
|
|
CELL+ DUP @
|
|
. CR
|
|
ENDOF
|
|
['] LITSTRING OF
|
|
[ CHAR S ] LITERAL EMIT '"' EMIT SPACE
|
|
CELL+
|
|
COUNT 2DUP TELL
|
|
'"' EMIT CR
|
|
+
|
|
CELL-
|
|
ENDOF
|
|
['] 0BRANCH OF
|
|
." 0BRANCH("
|
|
CELL+ DUP @ 0 .R
|
|
." ) " CR
|
|
ENDOF
|
|
['] BRANCH OF
|
|
." BRANCH("
|
|
CELL+ DUP @ 0 .R
|
|
." ) " CR
|
|
ENDOF
|
|
['] ' OF
|
|
[ CHAR ' ] LITERAL EMIT SPACE
|
|
CELL+ @
|
|
CFA> ID. CR
|
|
ENDOF
|
|
['] EXIT OF
|
|
2DUP CELL+
|
|
<> IF
|
|
." EXIT " CR
|
|
THEN
|
|
ENDOF
|
|
DUP
|
|
CFA>
|
|
ID. CR
|
|
ENDCASE
|
|
|
|
CELL+
|
|
REPEAT
|
|
|
|
';' EMIT CR
|
|
|
|
2DROP
|
|
;
|
|
|
|
: :NONAME
|
|
HERE @
|
|
LATEST @ ,
|
|
LATEST !
|
|
0 ,
|
|
HERE @
|
|
[ ' DOCOL @ ] LITERAL ,
|
|
0 ,
|
|
]
|
|
;
|
|
|
|
( Colors )
|
|
DEC
|
|
: ESC[ 27 EMIT '[' EMIT ;
|
|
0 CONSTANT RESET
|
|
1 CONSTANT BRIGHT
|
|
2 CONSTANT DIM
|
|
4 CONSTANT UNSERSCORE
|
|
5 CONSTANT BLINK
|
|
7 CONSTANT REVERSE
|
|
8 CONSTANT HIDDEN
|
|
|
|
: FG> 30 + ;
|
|
: BG> 40 + ;
|
|
|
|
0 CONSTANT <BLK
|
|
1 CONSTANT <RED
|
|
2 CONSTANT <GRN
|
|
3 CONSTANT <YEL
|
|
4 CONSTANT <BLU
|
|
5 CONSTANT <MAG
|
|
6 CONSTANT <CYN
|
|
7 CONSTANT <WHT
|
|
|
|
: <COLOR> ESC[ 0 .R ';' EMIT 0 .R ." m" ;
|
|
: <ATTRIB> ESC[ 0 .R ';' EMIT ." ;m" ;
|
|
]]
|