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
|
: \ 10 parse 2drop ; immediate \ test
: ( [ char ) ] literal parse 2drop ; immediate ( test )
: binary 2 base ! ;
: octal 8 base ! ;
: decimal 10 base ! ;
: hex 16 base ! ;
: nip swap drop ;
: tuck swap over ;
: <mark here ;
: <resolve here 4 + - d, ;
: >mark here 0 d, ;
: >resolve dup here swap - 4 - swap d! ;
: begin <mark ; immediate compile-only
: again branch <resolve ; immediate compile-only
: until ?branch <resolve ; immediate compile-only
: if ?branch >mark ; immediate compile-only
: else branch >mark swap >resolve ; immediate compile-only
: then >resolve ; immediate compile-only
: while ?branch >mark ; immediate compile-only
: repeat branch swap <resolve >resolve ; immediate compile-only
: ?dup dup 0<> if dup then ;
: allot dp +! ;
: ?find ?dup if find 0= if 2drop abort then else abort then ;
: 'h parse-name ?find ;
: ' 'h >body ;
: [compile] ' ( word ) compile, ; immediate compile-only
: ['] ' ( word ) [compile] literal ; immediate compile-only
: postpone 'h ( word ) dup immediate? if >body compile,
else >body [compile] literal ['] compile, compile, then ; immediate compile-only
: cells 8 * ;
: cell+ 8 + ;
: cell- 8 - ;
: create parse-name (header) latest ! ['] (create) compile, 0 , ;
: does> latest @ >body 2 + ['] (does>) over ! \ replace call loc
( replace destination ) 11 + r> swap ! ;
( the lone r> means we don't execute the rest of the word now, )
( but it is actually compiled into the definition and is jumped to )
( by a create does> made word )
: constant create , does> @ ;
: variable create 1 cells allot ;
: value parse-name (header) latest ! postpone literal
[ hex ] c3 c, [ decimal ] ; \ c3 = RET
: to ' ( word ) 6 + state @ if postpone literal postpone ! else ! then ; immediate
: +to ' ( word ) 6 + state @ if postpone literal postpone +! else +! then ; immediate
: -to ' ( word ) 6 + state @ if postpone literal postpone -! else -! then ; immediate
0 constant false
-1 constant true
: cmove, dup >r here swap cmove r> allot ;
: s" [ char " ] literal parse ( a u )
branch >mark >r 2dup cmove, nip ( u ) ( R: mark )
r> dup >resolve 4 + ( u a )
postpone literal ( a ) postpone literal ( u ) ; immediate compile-only
1 constant stdout
2 constant stderr
: type swap stdout 1 syscall3 ;
: emit sp 1 swap stdout 1 syscall3 2drop ;
bye
|
