1: \ `\n parse drop ; immediate 2 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. 6 7\ Define parenthesis comments. 8\ : ( `) parse drop ; immediate 9 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 13 14: ['] ' ; immediate 15: [compile] compile ; immediate 16 17: 2drop drop drop ; 18: dup2 over over ; 19 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 -- ) 29 dup (local) swap if 30 compile-local-write 31 else 32 drop 33 then ; 34: __deflocals ( from_stack -- ) 35 next-word 36 dup "}" eqstr if 37 2drop ret 38 then 39 dup ";" eqstr if 40 2drop 0 __deflocals ret 41 then 42 over __deflocals 43 __deflocal ; 44: { 45 -1 __deflocals ; immediate 46 47\ Data building words. 48: data: 49 new-data-block next-word define-data-word ; 50: hexb| 51 0 0 { acc z } 52 begin 53 char 54 dup `| = if 55 z if "Truncated hexadecimal byte" puts cr exitvm then 56 ret 57 then 58 dup 0x20 > if 59 hexval 60 z if acc 4 << + data-add8 else >acc then 61 z not >z 62 then 63 again ; 64 65\ Convert hexadecimal character to number. Complain loudly if conversion 66\ is not possible. 67: hexval ( char -- x ) 68 hexval-nf dup 0 < if "Not an hex digit: " puts . cr exitvm then ; 69 70\ Convert hexadecimal character to number. If not an hexadecimal digit, 71\ return -1. 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 76 drop -1 ; 77 78\ Convert decimal character to number. Complain loudly if conversion 79\ is not possible. 80: decval ( char -- x ) 81 decval-nf dup 0 < if "Not a decimal digit: " puts . cr exitvm then ; 82 83\ Convert decimal character to number. If not a decimal digit, 84\ return -1. 85: decval-nf ( char -- x ) 86 dup dup `0 >= swap `9 <= and if `0 - ret then 87 drop -1 ; 88 89\ Commonly used shorthands. 90: 1+ 1 + ; 91: 2+ 2 + ; 92: 1- 1 - ; 93: 2- 2 - ; 94: 0= 0 = ; 95: 0<> 0 <> ; 96: 0< 0 < ; 97: 0> 0 > ; 98 99\ Get a 16-bit value from the constant data block. This uses big-endian 100\ encoding. 101: data-get16 ( addr -- x ) 102 dup data-get8 8 << swap 1+ data-get8 + ; 103 104\ The case..endcase construction is the equivalent of 'switch' is C. 105\ Usage: 106\ case 107\ E1 of C1 endof 108\ E2 of C2 endof 109\ ... 110\ CN 111\ endcase 112\ 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. 119\ 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. 122\ 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. 127\ 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'. 133 134: case 0 ; immediate 135: of 1+ postpone over postpone = postpone if postpone drop ; immediate 136: endof postpone else ; immediate 137: endcase 138 postpone drop 139 begin dup while 1- postpone then repeat drop ; immediate 140 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 143\ value. 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 149 150\ C implementations for native words that can be used in generated code. 151add-cc: co { T0_CO(); } 152add-cc: execute { T0_ENTER(ip, rp, T0_POP()); } 153add-cc: drop { (void)T0_POP(); } 154add-cc: dup { T0_PUSH(T0_PEEK(0)); } 155add-cc: swap { T0_SWAP(); } 156add-cc: over { T0_PUSH(T0_PEEK(1)); } 157add-cc: rot { T0_ROT(); } 158add-cc: -rot { T0_NROT(); } 159add-cc: roll { T0_ROLL(T0_POP()); } 160add-cc: pick { T0_PICK(T0_POP()); } 161add-cc: + { 162 uint32_t b = T0_POP(); 163 uint32_t a = T0_POP(); 164 T0_PUSH(a + b); 165} 166add-cc: - { 167 uint32_t b = T0_POP(); 168 uint32_t a = T0_POP(); 169 T0_PUSH(a - b); 170} 171add-cc: neg { 172 uint32_t a = T0_POP(); 173 T0_PUSH(-a); 174} 175add-cc: * { 176 uint32_t b = T0_POP(); 177 uint32_t a = T0_POP(); 178 T0_PUSH(a * b); 179} 180add-cc: / { 181 int32_t b = T0_POPi(); 182 int32_t a = T0_POPi(); 183 T0_PUSHi(a / b); 184} 185add-cc: u/ { 186 uint32_t b = T0_POP(); 187 uint32_t a = T0_POP(); 188 T0_PUSH(a / b); 189} 190add-cc: % { 191 int32_t b = T0_POPi(); 192 int32_t a = T0_POPi(); 193 T0_PUSHi(a % b); 194} 195add-cc: u% { 196 uint32_t b = T0_POP(); 197 uint32_t a = T0_POP(); 198 T0_PUSH(a % b); 199} 200add-cc: < { 201 int32_t b = T0_POPi(); 202 int32_t a = T0_POPi(); 203 T0_PUSH(-(uint32_t)(a < b)); 204} 205add-cc: <= { 206 int32_t b = T0_POPi(); 207 int32_t a = T0_POPi(); 208 T0_PUSH(-(uint32_t)(a <= b)); 209} 210add-cc: > { 211 int32_t b = T0_POPi(); 212 int32_t a = T0_POPi(); 213 T0_PUSH(-(uint32_t)(a > b)); 214} 215add-cc: >= { 216 int32_t b = T0_POPi(); 217 int32_t a = T0_POPi(); 218 T0_PUSH(-(uint32_t)(a >= b)); 219} 220add-cc: = { 221 uint32_t b = T0_POP(); 222 uint32_t a = T0_POP(); 223 T0_PUSH(-(uint32_t)(a == b)); 224} 225add-cc: <> { 226 uint32_t b = T0_POP(); 227 uint32_t a = T0_POP(); 228 T0_PUSH(-(uint32_t)(a != b)); 229} 230add-cc: u< { 231 uint32_t b = T0_POP(); 232 uint32_t a = T0_POP(); 233 T0_PUSH(-(uint32_t)(a < b)); 234} 235add-cc: u<= { 236 uint32_t b = T0_POP(); 237 uint32_t a = T0_POP(); 238 T0_PUSH(-(uint32_t)(a <= b)); 239} 240add-cc: u> { 241 uint32_t b = T0_POP(); 242 uint32_t a = T0_POP(); 243 T0_PUSH(-(uint32_t)(a > b)); 244} 245add-cc: u>= { 246 uint32_t b = T0_POP(); 247 uint32_t a = T0_POP(); 248 T0_PUSH(-(uint32_t)(a >= b)); 249} 250add-cc: and { 251 uint32_t b = T0_POP(); 252 uint32_t a = T0_POP(); 253 T0_PUSH(a & b); 254} 255add-cc: or { 256 uint32_t b = T0_POP(); 257 uint32_t a = T0_POP(); 258 T0_PUSH(a | b); 259} 260add-cc: xor { 261 uint32_t b = T0_POP(); 262 uint32_t a = T0_POP(); 263 T0_PUSH(a ^ b); 264} 265add-cc: not { 266 uint32_t a = T0_POP(); 267 T0_PUSH(~a); 268} 269add-cc: << { 270 int c = (int)T0_POPi(); 271 uint32_t x = T0_POP(); 272 T0_PUSH(x << c); 273} 274add-cc: >> { 275 int c = (int)T0_POPi(); 276 int32_t x = T0_POPi(); 277 T0_PUSHi(x >> c); 278} 279add-cc: u>> { 280 int c = (int)T0_POPi(); 281 uint32_t x = T0_POP(); 282 T0_PUSH(x >> c); 283} 284add-cc: data-get8 { 285 size_t addr = T0_POP(); 286 T0_PUSH(t0_datablock[addr]); 287} 288 289add-cc: . { 290 extern int printf(const char *fmt, ...); 291 printf(" %ld", (long)T0_POPi()); 292} 293add-cc: putc { 294 extern int printf(const char *fmt, ...); 295 printf("%c", (char)T0_POPi()); 296} 297add-cc: puts { 298 extern int printf(const char *fmt, ...); 299 printf("%s", &t0_datablock[T0_POPi()]); 300} 301add-cc: cr { 302 extern int printf(const char *fmt, ...); 303 printf("\n"); 304} 305add-cc: eqstr { 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)); 309} 310