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
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
|
~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
~ ~~ High-level flow-control ~~
~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
~
~ We use a novel suffix-based approach to flow control. We define words
~ { and } which describe the boundaries of blocks of code, leaving a
~ description on the value stack, while still compiling the contents
~ normally.
~
~ Then follow-up words such as "if" can use that information to slide
~ the blocks around and insert any needed branches and other logic.
~
~ Both the label transform and the log-load transform go out of their way
~ to make sure these words work. Because of that, we actually get to use these
~ before defining them... just keep in mind nothing under the transform is
~ calling THESE versions.
~ (-- start pointer)
: { here @ ; make-immediate
~ (start pointer -- start pointer, length)
: } dup here @ swap - ; make-immediate
~ (start pointer, length --)
: if
2dup swap dup 5 8 * + 3roll
~ (start pointer, length, start pointer, adjusted start pointer, length)
memmove
~ (start pointer, length)
swap here @ swap here ! swap
~ (old here, length)
' lit entry-to-execution-token , 0 ,
' != entry-to-execution-token ,
~ The branch length needs to be one word longer than the block length,
~ because the length field itself is part of the scope of the branch.
' 0branch entry-to-execution-token , dup 8 + ,
~ (old here, length)
drop 5 8 * + here !
; make-immediate
~ (start pointer, length --)
: unless
2dup swap dup 5 8 * + 3roll
~ (start pointer, length, start pointer, adjusted start pointer, length)
memmove
~ (start pointer, length)
swap here @ swap here ! swap
~ (old here, length)
' lit entry-to-execution-token , 0 ,
' = entry-to-execution-token ,
~ The branch length needs to be one word longer than the block length,
~ because the length field itself is part of the scope of the branch.
' 0branch entry-to-execution-token , dup 8 + ,
~ (old here, length)
drop 5 8 * + here ! ; make-immediate
~ (true start, true length, false start, false length --)
: if-else
~ First we slide the false-block forward, then the true-block. We slide
~ them both directly into their final positions, leaving space at the start
~ for a test and branch, and space in between for an unconditional branch.
~ Those spaces will take five words, and two words, respectively. So the
~ false-block gets moved by seven words, and the true-block gets moved by
~ five words.
2dup swap dup 7 8 * + 3roll memmove
~ (true start, true length, false start, false length)
3 pick dup 5 8 * + 4 pick memmove
~ (true start, true length, false start, false length)
~ Now we write out the initial test-and-branch.
4 roll dup 5 unroll here @ 6 unroll here !
~ (old here, true start, true length, false start, false length)
' lit entry-to-execution-token , 0 ,
' != entry-to-execution-token ,
~ Branch past the length field, the true-block, and the unconditional
~ branch in the middle.
' 0branch entry-to-execution-token ,
3roll dup 4 unroll 3 8 * + ,
~ Next, write out the unconditional branch in the middle.
swap dup 3unroll 5 8 * + here !
' branch entry-to-execution-token ,
~ Branch past the length field and the false-block.
dup 8 + ,
~ Set "here" to point to the true end.
drop drop drop drop 7 8 * + here !
; make-immediate
~ (start, length --)
: forever
' branch entry-to-execution-token , 8 + -1 * , drop
; make-immediate
~ This slides the body forward, leaving the test where it is. It puts a
~ conditional branch in-between them, then appends an unconditional branch
~ at the end.
~
~ (test start, test length, body start, body length --)
: while
~ The conditional branch needs five words.
2dup swap dup 5 8 * + 3roll memmove
here @ 5 unroll swap dup 3unroll here !
~ (old here, test start, test length, body start, body length)
' lit entry-to-execution-token , 0 ,
' != entry-to-execution-token ,
~ Branch past the length field, the body, and the unconditional branch.
' 0branch entry-to-execution-token ,
dup 3 8 * + ,
~ Set "here" to the new end.
5 8 * 6 roll + here !
~ (test start, test length, body start, body length)
~ Unconditionally branch backwards past the branch word, the body, the
~ conditional branch, and the test.
' branch entry-to-execution-token ,
6 8 * + swap drop + swap drop -1 * ,
; make-immediate
~ This is a helper which does non-local exit by directly overwriting the
~ control stack, then calling regular "exit" (implicitly as part of its own
~ semicolon). The name "nexit" is short for n-exit, meaning that it takes a
~ parameter which tells it how many times to exit.
~
~ 1 nexit is equivalent to regular "exit". 2 nexit is equivalent to asking
~ your own caller to exit. 0 nexit does nothing.
~
~ This style of programming isn't encouraged, but may be useful when doing
~ code that transforms other code.
~
~ This is much lower-level than the other flow-control stuff, but it isn't
~ compatible with the label transform due to relying on r0, so it needs to go
~ somewhere other than core.e, and this was the closest fit.
~
~ Anecdotally, this feature is traditionally called "shunt", and sometimes
~ "rdrop".
~
~ (count --)
: nexit 8 * control@ + r0 @ min control! ;
|