kern.t0
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. 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()); } 161 add-cc: + { 162 uint32_t b = T0_POP(); 163 uint32_t a = T0_POP(); 164 T0_PUSH(a + b); 165 } 166 add-cc: - { 167 uint32_t b = T0_POP(); 168 uint32_t a = T0_POP(); 169 T0_PUSH(a - b); 170 } 171 add-cc: neg { 172 uint32_t a = T0_POP(); 173 T0_PUSH(-a); 174 } 175 add-cc: * { 176 uint32_t b = T0_POP(); 177 uint32_t a = T0_POP(); 178 T0_PUSH(a * b); 179 } 180 add-cc: / { 181 int32_t b = T0_POPi(); 182 int32_t a = T0_POPi(); 183 T0_PUSHi(a / b); 184 } 185 add-cc: u/ { 186 uint32_t b = T0_POP(); 187 uint32_t a = T0_POP(); 188 T0_PUSH(a / b); 189 } 190 add-cc: % { 191 int32_t b = T0_POPi(); 192 int32_t a = T0_POPi(); 193 T0_PUSHi(a % b); 194 } 195 add-cc: u% { 196 uint32_t b = T0_POP(); 197 uint32_t a = T0_POP(); 198 T0_PUSH(a % b); 199 } 200 add-cc: < { 201 int32_t b = T0_POPi(); 202 int32_t a = T0_POPi(); 203 T0_PUSH(-(uint32_t)(a < b)); 204 } 205 add-cc: <= { 206 int32_t b = T0_POPi(); 207 int32_t a = T0_POPi(); 208 T0_PUSH(-(uint32_t)(a <= b)); 209 } 210 add-cc: > { 211 int32_t b = T0_POPi(); 212 int32_t a = T0_POPi(); 213 T0_PUSH(-(uint32_t)(a > b)); 214 } 215 add-cc: >= { 216 int32_t b = T0_POPi(); 217 int32_t a = T0_POPi(); 218 T0_PUSH(-(uint32_t)(a >= b)); 219 } 220 add-cc: = { 221 uint32_t b = T0_POP(); 222 uint32_t a = T0_POP(); 223 T0_PUSH(-(uint32_t)(a == b)); 224 } 225 add-cc: <> { 226 uint32_t b = T0_POP(); 227 uint32_t a = T0_POP(); 228 T0_PUSH(-(uint32_t)(a != b)); 229 } 230 add-cc: u< { 231 uint32_t b = T0_POP(); 232 uint32_t a = T0_POP(); 233 T0_PUSH(-(uint32_t)(a < b)); 234 } 235 add-cc: u<= { 236 uint32_t b = T0_POP(); 237 uint32_t a = T0_POP(); 238 T0_PUSH(-(uint32_t)(a <= b)); 239 } 240 add-cc: u> { 241 uint32_t b = T0_POP(); 242 uint32_t a = T0_POP(); 243 T0_PUSH(-(uint32_t)(a > b)); 244 } 245 add-cc: u>= { 246 uint32_t b = T0_POP(); 247 uint32_t a = T0_POP(); 248 T0_PUSH(-(uint32_t)(a >= b)); 249 } 250 add-cc: and { 251 uint32_t b = T0_POP(); 252 uint32_t a = T0_POP(); 253 T0_PUSH(a & b); 254 } 255 add-cc: or { 256 uint32_t b = T0_POP(); 257 uint32_t a = T0_POP(); 258 T0_PUSH(a | b); 259 } 260 add-cc: xor { 261 uint32_t b = T0_POP(); 262 uint32_t a = T0_POP(); 263 T0_PUSH(a ^ b); 264 } 265 add-cc: not { 266 uint32_t a = T0_POP(); 267 T0_PUSH(~a); 268 } 269 add-cc: << { 270 int c = (int)T0_POPi(); 271 uint32_t x = T0_POP(); 272 T0_PUSH(x << c); 273 } 274 add-cc: >> { 275 int c = (int)T0_POPi(); 276 int32_t x = T0_POPi(); 277 T0_PUSHi(x >> c); 278 } 279 add-cc: u>> { 280 int c = (int)T0_POPi(); 281 uint32_t x = T0_POP(); 282 T0_PUSH(x >> c); 283 } 284 add-cc: data-get8 { 285 size_t addr = T0_POP(); 286 T0_PUSH(t0_datablock[addr]); 287 } 288 289 add-cc: . { 290 extern int printf(const char *fmt, ...); 291 printf(" %ld", (long)T0_POPi()); 292 } 293 add-cc: putc { 294 extern int printf(const char *fmt, ...); 295 printf("%c", (char)T0_POPi()); 296 } 297 add-cc: puts { 298 extern int printf(const char *fmt, ...); 299 printf("%s", &t0_datablock[T0_POPi()]); 300 } 301 add-cc: cr { 302 extern int printf(const char *fmt, ...); 303 printf("\n"); 304 } 305 add-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 }