84 lines
2.9 KiB
Forth
84 lines
2.9 KiB
Forth
CREATE BUF 0 , \ single-character look-ahead buffer
|
|
: PEEK BUF @ 0= IF KEY BUF ! THEN BUF @ ;
|
|
: GETC PEEK 0 BUF ! ;
|
|
: SPACE? DUP BL = SWAP 9 14 WITHIN OR ;
|
|
: >SPACE BEGIN PEEK SPACE? WHILE GETC DROP REPEAT ;
|
|
: DIGIT? 48 58 WITHIN ;
|
|
: >INT ( -- n) >SPACE 0
|
|
BEGIN PEEK DIGIT?
|
|
WHILE GETC [CHAR] 0 - SWAP 10 * + REPEAT ;
|
|
CREATE A 0 ,
|
|
: C@A ( -- c) A @ C@ ;
|
|
: C@A+ ( -- c) C@A 1 CHARS A +! ;
|
|
: C!A+ ( c --) A @ C! 1 CHARS A +! ;
|
|
: WORD ( -- c-addr) >SPACE PAD 1+ A !
|
|
BEGIN PEEK SPACE? INVERT WHILE GETC C!A+ REPEAT
|
|
>SPACE PAD A @ OVER - 1- PAD C! ;
|
|
: >STRING ( -- c-addr) >SPACE GETC DROP PAD 1+ A !
|
|
BEGIN PEEK [CHAR] " <> WHILE GETC C!A+ REPEAT
|
|
GETC DROP PAD A @ OVER - 1- PAD C! ;
|
|
: \INTERN ( c-addr -- c-addr) HERE >R A ! C@A+ DUP C,
|
|
BEGIN DUP WHILE C@A+
|
|
DUP [CHAR] \ = IF DROP -1 R@ +! C@A+
|
|
[CHAR] n = IF 10 ELSE [CHAR] \ THEN
|
|
THEN C, 1-
|
|
REPEAT DROP R> ;
|
|
: . 0 .R ;
|
|
|
|
CREATE DATA 0 ,
|
|
CREATE STRINGS 0 ,
|
|
: >DATA HERE DATA !
|
|
WORD DROP >INT 4 * BEGIN DUP WHILE 0 C, 1- REPEAT DROP ;
|
|
: >STRINGS HERE STRINGS !
|
|
WORD DROP >INT DUP >R CELLS ALLOT
|
|
0 BEGIN DUP R@ < WHILE
|
|
DUP CELLS >STRING \INTERN STRINGS @ ROT + ! 1+
|
|
REPEAT R> DROP DROP ;
|
|
: >HEADER >DATA >STRINGS ;
|
|
: i32! ( n addr --)
|
|
OVER $FF AND OVER C! 1+
|
|
OVER 8 RSHIFT $FF AND OVER C! 1+
|
|
OVER 16 RSHIFT $FF AND OVER C! 1+
|
|
SWAP 24 RSHIFT $FF AND SWAP C! ;
|
|
: i32@ ( addr -- n) >R \ This is kinda slow... hmm
|
|
R@ C@
|
|
R@ 1 + C@ 8 LSHIFT OR
|
|
R@ 2 + C@ 16 LSHIFT OR
|
|
R> 3 + C@ 24 LSHIFT OR
|
|
DUP $7FFFFFFF AND SWAP $80000000 AND - ; \ sign extend
|
|
: i32, ( n --) HERE 4 ALLOT i32! ;
|
|
: i32@+ ( -- n) A @ i32@ A @ 4 + A ! ;
|
|
CREATE BYTECODE 0 ,
|
|
: @fetch i32@+ 4 * DATA @ + i32@ ;
|
|
: @store i32@+ 4 * DATA @ + i32! ;
|
|
: @jmp i32@+ BYTECODE @ + A ! ;
|
|
: @jz IF 4 A +! ELSE @jmp THEN ;
|
|
: @prts CELLS STRINGS @ + @ COUNT TYPE ;
|
|
: @div >R S>D R> SM/REM SWAP DROP ;
|
|
CREATE OPS
|
|
' @fetch , ' @store , ' i32@+ , ' @jmp , ' @jz ,
|
|
' EMIT , ' . , ' @prts , ' NEGATE , ' 0= ,
|
|
' + , ' - , ' * , ' @div , ' MOD ,
|
|
' < , ' > , ' <= , ' >= ,
|
|
' = , ' <> , ' AND , ' OR , ' BYE ,
|
|
CREATE #OPS 0 ,
|
|
: OP: CREATE #OPS @ , 1 #OPS +! DOES> @ ;
|
|
OP: fetch OP: store OP: push OP: jmp OP: jz
|
|
OP: prtc OP: prti OP: prts OP: neg OP: not
|
|
OP: add OP: sub OP: mul OP: div OP: mod
|
|
OP: lt OP: gt OP: le OP: ge
|
|
OP: eq OP: ne OP: and OP: or OP: halt
|
|
: >OP WORD FIND
|
|
0= IF ." Unrecognized opcode" ABORT THEN EXECUTE ;
|
|
: >i32 >INT i32, ;
|
|
: >[i32] GETC DROP >i32 GETC DROP ;
|
|
: >OFFSET WORD DROP ( drop relative offset) >i32 ;
|
|
CREATE >PARAM ' >[i32] DUP , , ' >i32 , ' >OFFSET DUP , ,
|
|
: >BYTECODE HERE >R
|
|
BEGIN >INT DROP >OP >R R@ C,
|
|
R@ 5 < IF R@ CELLS >PARAM + @ EXECUTE THEN
|
|
R> halt = UNTIL R> BYTECODE ! ;
|
|
: RUN BYTECODE @ A !
|
|
BEGIN C@A+ CELLS OPS + @ EXECUTE AGAIN ;
|
|
>HEADER >BYTECODE RUN
|