1 : \ `\n parse drop ; immediate
3 \ This file defines the core non-native functions (mainly used for
4 \ parsing words, i.e. not part of the generated output). The line above
5 \ defines the syntax for comments.
7 \ Define parenthesis comments.
8 \ : ( `) parse drop ; immediate
10 : else postpone ahead 1 cs-roll postpone then ; immediate
11 : while postpone if 1 cs-roll ; immediate
12 : repeat postpone again postpone then ; immediate
15 : [compile] compile ; immediate
20 \ Local variables are defined with the native word '(local)'. We define
21 \ a helper construction that mimics what is found in Apple's Open Firmware
22 \ implementation. The syntax is: { a b ... ; c d ... }
23 \ I.e. there is an opening brace, then some names. Names appearing before
24 \ the semicolon are locals that are both defined and then filled with the
25 \ values on stack (in stack order: { a b } fills 'b' with the top-of-stack,
26 \ and 'a' with the value immediately below). Names appearing after the
27 \ semicolon are not initialized.
28 : __deflocal ( from_stack name -- )
34 : __deflocals ( from_stack -- )
40 2drop 0 __deflocals ret
45 -1 __deflocals ; immediate
47 \ Data building words.
49 new-data-block next-word define-data-word ;
55 z if "Truncated hexadecimal byte" puts cr exitvm then
60 z if acc 4 << + data-add8 else >acc then
65 \ Convert hexadecimal character to number. Complain loudly if conversion
67 : hexval ( char -- x )
68 hexval-nf dup 0 < if "Not an hex digit: " puts . cr exitvm then ;
70 \ Convert hexadecimal character to number. If not an hexadecimal digit,
72 : hexval-nf ( char -- x )
73 dup dup `0 >= swap `9 <= and if `0 - ret then
74 dup dup `A >= swap `F <= and if `A - 10 + ret then
75 dup dup `a >= swap `f <= and if `a - 10 + ret then
78 \ Convert decimal character to number. Complain loudly if conversion
80 : decval ( char -- x )
81 decval-nf dup 0 < if "Not a decimal digit: " puts . cr exitvm then ;
83 \ Convert decimal character to number. If not a decimal digit,
85 : decval-nf ( char -- x )
86 dup dup `0 >= swap `9 <= and if `0 - ret then
89 \ Commonly used shorthands.
99 \ Get a 16-bit value from the constant data block. This uses big-endian
101 : data-get16 ( addr -- x )
102 dup data-get8 8 << swap 1+ data-get8 + ;
104 \ The case..endcase construction is the equivalent of 'switch' is C.
113 \ Upon entry, it considers the TOS (let's call it X). It will then evaluate
114 \ E1, which should yield a single value Y1; at that point, the X value is
115 \ still on the stack, just below Y1, and must remain untouched. The 'of'
116 \ word compares X with Y1; if they are equal, C1 is executed, and then
117 \ control jumps to after the 'endcase'. The X value is popped from the
118 \ stack immediately before evaluating C1.
120 \ If X and Y1 are not equal, flow proceeds to E2, to obtain a value Y2 to
121 \ compare with X. And so on.
123 \ If none of the 'of' clauses found a match, then CN is evaluated. When CN
124 \ is evaluated, the X value is on the TOS, and CN must either leave it on
125 \ the stack, or replace it with exactly one value; the 'endcase' word
126 \ expects (and drops) one value.
128 \ Implementation: this is mostly copied from ANS Forth specification,
129 \ although simplified a bit because we know that our control-flow stack
130 \ is independent of the data stack. During compilation, the number of
131 \ clauses is maintained on the stack; each of..endof clause really is
132 \ an 'if..else' that must be terminated with a matching 'then' in 'endcase'.
135 : of 1+ postpone over postpone = postpone if postpone drop ; immediate
136 : endof postpone else ; immediate
139 begin dup while 1- postpone then repeat drop ; immediate
141 \ A simpler and more generic "case": there is no management for a value
142 \ on the stack, and each test is supposed to come up with its own boolean
144 : choice 0 ; immediate
145 : uf 1+ postpone if ; immediate
146 : ufnot 1+ postpone ifnot ; immediate
147 : enduf postpone else ; immediate
148 : endchoice begin dup while 1- postpone then repeat drop ; immediate
150 \ C implementations for native words that can be used in generated code.
151 add-cc: co { T0_CO(); }
152 add-cc: execute { T0_ENTER(ip, rp, T0_POP()); }
153 add-cc: drop { (void)T0_POP(); }
154 add-cc: dup { T0_PUSH(T0_PEEK(0)); }
155 add-cc: swap { T0_SWAP(); }
156 add-cc: over { T0_PUSH(T0_PEEK(1)); }
157 add-cc: rot { T0_ROT(); }
158 add-cc: -rot { T0_NROT(); }
159 add-cc: roll { T0_ROLL(T0_POP()); }
160 add-cc: pick { T0_PICK(T0_POP()); }
162 uint32_t b = T0_POP();
163 uint32_t a = T0_POP();
167 uint32_t b = T0_POP();
168 uint32_t a = T0_POP();
172 uint32_t a = T0_POP();
176 uint32_t b = T0_POP();
177 uint32_t a = T0_POP();
181 int32_t b = T0_POPi();
182 int32_t a = T0_POPi();
186 uint32_t b = T0_POP();
187 uint32_t a = T0_POP();
191 int32_t b = T0_POPi();
192 int32_t a = T0_POPi();
196 uint32_t b = T0_POP();
197 uint32_t a = T0_POP();
201 int32_t b = T0_POPi();
202 int32_t a = T0_POPi();
203 T0_PUSH(-(uint32_t)(a < b));
206 int32_t b = T0_POPi();
207 int32_t a = T0_POPi();
208 T0_PUSH(-(uint32_t)(a <= b));
211 int32_t b = T0_POPi();
212 int32_t a = T0_POPi();
213 T0_PUSH(-(uint32_t)(a > b));
216 int32_t b = T0_POPi();
217 int32_t a = T0_POPi();
218 T0_PUSH(-(uint32_t)(a >= b));
221 uint32_t b = T0_POP();
222 uint32_t a = T0_POP();
223 T0_PUSH(-(uint32_t)(a == b));
226 uint32_t b = T0_POP();
227 uint32_t a = T0_POP();
228 T0_PUSH(-(uint32_t)(a != b));
231 uint32_t b = T0_POP();
232 uint32_t a = T0_POP();
233 T0_PUSH(-(uint32_t)(a < b));
236 uint32_t b = T0_POP();
237 uint32_t a = T0_POP();
238 T0_PUSH(-(uint32_t)(a <= b));
241 uint32_t b = T0_POP();
242 uint32_t a = T0_POP();
243 T0_PUSH(-(uint32_t)(a > b));
246 uint32_t b = T0_POP();
247 uint32_t a = T0_POP();
248 T0_PUSH(-(uint32_t)(a >= b));
251 uint32_t b = T0_POP();
252 uint32_t a = T0_POP();
256 uint32_t b = T0_POP();
257 uint32_t a = T0_POP();
261 uint32_t b = T0_POP();
262 uint32_t a = T0_POP();
266 uint32_t a = T0_POP();
270 int c = (int)T0_POPi();
271 uint32_t x = T0_POP();
275 int c = (int)T0_POPi();
276 int32_t x = T0_POPi();
280 int c = (int)T0_POPi();
281 uint32_t x = T0_POP();
285 size_t addr = T0_POP();
286 T0_PUSH(t0_datablock[addr]);
290 extern int printf(const char *fmt, ...);
291 printf(" %ld", (long)T0_POPi());
294 extern int printf(const char *fmt, ...);
295 printf("%c", (char)T0_POPi());
298 extern int printf(const char *fmt, ...);
299 printf("%s", &t0_datablock[T0_POPi()]);
302 extern int printf(const char *fmt, ...);
306 const void *b = &t0_datablock[T0_POPi()];
307 const void *a = &t0_datablock[T0_POPi()];
308 T0_PUSH(-(int32_t)(strcmp(a, b) == 0));