-
Notifications
You must be signed in to change notification settings - Fork 1
/
forth.fth
82 lines (64 loc) · 1.9 KB
/
forth.fth
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
: version 1 ;
: cells 8 * ;
: space 32 emit ;
: cr 10 emit ;
: not 0= ;
: tuck swap over ;
: align dp @ aligned dp ! ;
: decimal 10 base ! ;
: hex 16 base ! ;
: ? @ . ;
: literal ['] lit , , ; immediate
: postpone parse-name find-name name>int , ; immediate
: [char] char postpone literal ; immediate
: recursive latest @ reveal ; immediate
: here dp @ ;
: if ['] 0branch , here 0 , ; immediate
: then dup here swap - swap ! ; immediate
: else ['] branch , here 0 , swap dup here swap - swap ! ; immediate
: begin here ; immediate
: until ['] 0branch , here - , ; immediate
: again ['] branch , here - , ; immediate
: while immediate ['] 0branch , here 0 , ;
: repeat ['] branch , swap here - , dup here swap - swap ! ; immediate
: unless ['] not , postpone if ; immediate
: _do-setup r> -rot 2dup >r >r rot >r ;
: unloop r> rdrop rdrop >r ;
: _do-next r> r> r> 1+ 2dup >r >r rot >r ;
: ?do ['] _do-setup , postpone begin ['] > , postpone while ; immediate
: loop ['] _do-next , postpone repeat ['] unloop , ; immediate
: i ['] lit compile, 1 , ['] rpick compile, ; immediate
: j ['] lit compile, 2 , ['] rpick compile, ; immediate
: k ['] lit compile, 3 , ['] rpick compile, ; immediate
: allot here swap dp +! ;
: constant create docol , ['] lit , , ['] exit , ;
: variable 1 cells allot constant ;
0 constant nil
: pad here 256 cells + ;
: c, dp @ c! 1 dp +! ;
: '"' [ char " ] literal ;
: s" state @ if
['] litstring , dp @ 0 ,
begin key dup '"' <>
while c,
repeat drop
dup dp @ swap - 1 cells - 1- swap ! align
else
dp @
begin key dup '"' <>
while over c! 1+
repeat drop
dp @ - 1- dp @ 1+ swap
then
; immediate
: ." state @ if
postpone s" ['] type ,
else
begin
key dup '"' = if drop exit then emit
again
then
; immediate
: ?dup dup if dup then ;
: comp' ' 0 ; immediate
." === railforth " version . ." === " cr