1*0957b409SSimon J. Gerraty: \ `\n parse drop ; immediate 2*0957b409SSimon J. Gerraty 3*0957b409SSimon J. Gerraty\ This file defines the core non-native functions (mainly used for 4*0957b409SSimon J. Gerraty\ parsing words, i.e. not part of the generated output). The line above 5*0957b409SSimon J. Gerraty\ defines the syntax for comments. 6*0957b409SSimon J. Gerraty 7*0957b409SSimon J. Gerraty\ Define parenthesis comments. 8*0957b409SSimon J. Gerraty\ : ( `) parse drop ; immediate 9*0957b409SSimon J. Gerraty 10*0957b409SSimon J. Gerraty: else postpone ahead 1 cs-roll postpone then ; immediate 11*0957b409SSimon J. Gerraty: while postpone if 1 cs-roll ; immediate 12*0957b409SSimon J. Gerraty: repeat postpone again postpone then ; immediate 13*0957b409SSimon J. Gerraty 14*0957b409SSimon J. Gerraty: ['] ' ; immediate 15*0957b409SSimon J. Gerraty: [compile] compile ; immediate 16*0957b409SSimon J. Gerraty 17*0957b409SSimon J. Gerraty: 2drop drop drop ; 18*0957b409SSimon J. Gerraty: dup2 over over ; 19*0957b409SSimon J. Gerraty 20*0957b409SSimon J. Gerraty\ Local variables are defined with the native word '(local)'. We define 21*0957b409SSimon J. Gerraty\ a helper construction that mimics what is found in Apple's Open Firmware 22*0957b409SSimon J. Gerraty\ implementation. The syntax is: { a b ... ; c d ... } 23*0957b409SSimon J. Gerraty\ I.e. there is an opening brace, then some names. Names appearing before 24*0957b409SSimon J. Gerraty\ the semicolon are locals that are both defined and then filled with the 25*0957b409SSimon J. Gerraty\ values on stack (in stack order: { a b } fills 'b' with the top-of-stack, 26*0957b409SSimon J. Gerraty\ and 'a' with the value immediately below). Names appearing after the 27*0957b409SSimon J. Gerraty\ semicolon are not initialized. 28*0957b409SSimon J. Gerraty: __deflocal ( from_stack name -- ) 29*0957b409SSimon J. Gerraty dup (local) swap if 30*0957b409SSimon J. Gerraty compile-local-write 31*0957b409SSimon J. Gerraty else 32*0957b409SSimon J. Gerraty drop 33*0957b409SSimon J. Gerraty then ; 34*0957b409SSimon J. Gerraty: __deflocals ( from_stack -- ) 35*0957b409SSimon J. Gerraty next-word 36*0957b409SSimon J. Gerraty dup "}" eqstr if 37*0957b409SSimon J. Gerraty 2drop ret 38*0957b409SSimon J. Gerraty then 39*0957b409SSimon J. Gerraty dup ";" eqstr if 40*0957b409SSimon J. Gerraty 2drop 0 __deflocals ret 41*0957b409SSimon J. Gerraty then 42*0957b409SSimon J. Gerraty over __deflocals 43*0957b409SSimon J. Gerraty __deflocal ; 44*0957b409SSimon J. Gerraty: { 45*0957b409SSimon J. Gerraty -1 __deflocals ; immediate 46*0957b409SSimon J. Gerraty 47*0957b409SSimon J. Gerraty\ Data building words. 48*0957b409SSimon J. Gerraty: data: 49*0957b409SSimon J. Gerraty new-data-block next-word define-data-word ; 50*0957b409SSimon J. Gerraty: hexb| 51*0957b409SSimon J. Gerraty 0 0 { acc z } 52*0957b409SSimon J. Gerraty begin 53*0957b409SSimon J. Gerraty char 54*0957b409SSimon J. Gerraty dup `| = if 55*0957b409SSimon J. Gerraty z if "Truncated hexadecimal byte" puts cr exitvm then 56*0957b409SSimon J. Gerraty ret 57*0957b409SSimon J. Gerraty then 58*0957b409SSimon J. Gerraty dup 0x20 > if 59*0957b409SSimon J. Gerraty hexval 60*0957b409SSimon J. Gerraty z if acc 4 << + data-add8 else >acc then 61*0957b409SSimon J. Gerraty z not >z 62*0957b409SSimon J. Gerraty then 63*0957b409SSimon J. Gerraty again ; 64*0957b409SSimon J. Gerraty 65*0957b409SSimon J. Gerraty\ Convert hexadecimal character to number. Complain loudly if conversion 66*0957b409SSimon J. Gerraty\ is not possible. 67*0957b409SSimon J. Gerraty: hexval ( char -- x ) 68*0957b409SSimon J. Gerraty hexval-nf dup 0 < if "Not an hex digit: " puts . cr exitvm then ; 69*0957b409SSimon J. Gerraty 70*0957b409SSimon J. Gerraty\ Convert hexadecimal character to number. If not an hexadecimal digit, 71*0957b409SSimon J. Gerraty\ return -1. 72*0957b409SSimon J. Gerraty: hexval-nf ( char -- x ) 73*0957b409SSimon J. Gerraty dup dup `0 >= swap `9 <= and if `0 - ret then 74*0957b409SSimon J. Gerraty dup dup `A >= swap `F <= and if `A - 10 + ret then 75*0957b409SSimon J. Gerraty dup dup `a >= swap `f <= and if `a - 10 + ret then 76*0957b409SSimon J. Gerraty drop -1 ; 77*0957b409SSimon J. Gerraty 78*0957b409SSimon J. Gerraty\ Convert decimal character to number. Complain loudly if conversion 79*0957b409SSimon J. Gerraty\ is not possible. 80*0957b409SSimon J. Gerraty: decval ( char -- x ) 81*0957b409SSimon J. Gerraty decval-nf dup 0 < if "Not a decimal digit: " puts . cr exitvm then ; 82*0957b409SSimon J. Gerraty 83*0957b409SSimon J. Gerraty\ Convert decimal character to number. If not a decimal digit, 84*0957b409SSimon J. Gerraty\ return -1. 85*0957b409SSimon J. Gerraty: decval-nf ( char -- x ) 86*0957b409SSimon J. Gerraty dup dup `0 >= swap `9 <= and if `0 - ret then 87*0957b409SSimon J. Gerraty drop -1 ; 88*0957b409SSimon J. Gerraty 89*0957b409SSimon J. Gerraty\ Commonly used shorthands. 90*0957b409SSimon J. Gerraty: 1+ 1 + ; 91*0957b409SSimon J. Gerraty: 2+ 2 + ; 92*0957b409SSimon J. Gerraty: 1- 1 - ; 93*0957b409SSimon J. Gerraty: 2- 2 - ; 94*0957b409SSimon J. Gerraty: 0= 0 = ; 95*0957b409SSimon J. Gerraty: 0<> 0 <> ; 96*0957b409SSimon J. Gerraty: 0< 0 < ; 97*0957b409SSimon J. Gerraty: 0> 0 > ; 98*0957b409SSimon J. Gerraty 99*0957b409SSimon J. Gerraty\ Get a 16-bit value from the constant data block. This uses big-endian 100*0957b409SSimon J. Gerraty\ encoding. 101*0957b409SSimon J. Gerraty: data-get16 ( addr -- x ) 102*0957b409SSimon J. Gerraty dup data-get8 8 << swap 1+ data-get8 + ; 103*0957b409SSimon J. Gerraty 104*0957b409SSimon J. Gerraty\ The case..endcase construction is the equivalent of 'switch' is C. 105*0957b409SSimon J. Gerraty\ Usage: 106*0957b409SSimon J. Gerraty\ case 107*0957b409SSimon J. Gerraty\ E1 of C1 endof 108*0957b409SSimon J. Gerraty\ E2 of C2 endof 109*0957b409SSimon J. Gerraty\ ... 110*0957b409SSimon J. Gerraty\ CN 111*0957b409SSimon J. Gerraty\ endcase 112*0957b409SSimon J. Gerraty\ 113*0957b409SSimon J. Gerraty\ Upon entry, it considers the TOS (let's call it X). It will then evaluate 114*0957b409SSimon J. Gerraty\ E1, which should yield a single value Y1; at that point, the X value is 115*0957b409SSimon J. Gerraty\ still on the stack, just below Y1, and must remain untouched. The 'of' 116*0957b409SSimon J. Gerraty\ word compares X with Y1; if they are equal, C1 is executed, and then 117*0957b409SSimon J. Gerraty\ control jumps to after the 'endcase'. The X value is popped from the 118*0957b409SSimon J. Gerraty\ stack immediately before evaluating C1. 119*0957b409SSimon J. Gerraty\ 120*0957b409SSimon J. Gerraty\ If X and Y1 are not equal, flow proceeds to E2, to obtain a value Y2 to 121*0957b409SSimon J. Gerraty\ compare with X. And so on. 122*0957b409SSimon J. Gerraty\ 123*0957b409SSimon J. Gerraty\ If none of the 'of' clauses found a match, then CN is evaluated. When CN 124*0957b409SSimon J. Gerraty\ is evaluated, the X value is on the TOS, and CN must either leave it on 125*0957b409SSimon J. Gerraty\ the stack, or replace it with exactly one value; the 'endcase' word 126*0957b409SSimon J. Gerraty\ expects (and drops) one value. 127*0957b409SSimon J. Gerraty\ 128*0957b409SSimon J. Gerraty\ Implementation: this is mostly copied from ANS Forth specification, 129*0957b409SSimon J. Gerraty\ although simplified a bit because we know that our control-flow stack 130*0957b409SSimon J. Gerraty\ is independent of the data stack. During compilation, the number of 131*0957b409SSimon J. Gerraty\ clauses is maintained on the stack; each of..endof clause really is 132*0957b409SSimon J. Gerraty\ an 'if..else' that must be terminated with a matching 'then' in 'endcase'. 133*0957b409SSimon J. Gerraty 134*0957b409SSimon J. Gerraty: case 0 ; immediate 135*0957b409SSimon J. Gerraty: of 1+ postpone over postpone = postpone if postpone drop ; immediate 136*0957b409SSimon J. Gerraty: endof postpone else ; immediate 137*0957b409SSimon J. Gerraty: endcase 138*0957b409SSimon J. Gerraty postpone drop 139*0957b409SSimon J. Gerraty begin dup while 1- postpone then repeat drop ; immediate 140*0957b409SSimon J. Gerraty 141*0957b409SSimon J. Gerraty\ A simpler and more generic "case": there is no management for a value 142*0957b409SSimon J. Gerraty\ on the stack, and each test is supposed to come up with its own boolean 143*0957b409SSimon J. Gerraty\ value. 144*0957b409SSimon J. Gerraty: choice 0 ; immediate 145*0957b409SSimon J. Gerraty: uf 1+ postpone if ; immediate 146*0957b409SSimon J. Gerraty: ufnot 1+ postpone ifnot ; immediate 147*0957b409SSimon J. Gerraty: enduf postpone else ; immediate 148*0957b409SSimon J. Gerraty: endchoice begin dup while 1- postpone then repeat drop ; immediate 149*0957b409SSimon J. Gerraty 150*0957b409SSimon J. Gerraty\ C implementations for native words that can be used in generated code. 151*0957b409SSimon J. Gerratyadd-cc: co { T0_CO(); } 152*0957b409SSimon J. Gerratyadd-cc: execute { T0_ENTER(ip, rp, T0_POP()); } 153*0957b409SSimon J. Gerratyadd-cc: drop { (void)T0_POP(); } 154*0957b409SSimon J. Gerratyadd-cc: dup { T0_PUSH(T0_PEEK(0)); } 155*0957b409SSimon J. Gerratyadd-cc: swap { T0_SWAP(); } 156*0957b409SSimon J. Gerratyadd-cc: over { T0_PUSH(T0_PEEK(1)); } 157*0957b409SSimon J. Gerratyadd-cc: rot { T0_ROT(); } 158*0957b409SSimon J. Gerratyadd-cc: -rot { T0_NROT(); } 159*0957b409SSimon J. Gerratyadd-cc: roll { T0_ROLL(T0_POP()); } 160*0957b409SSimon J. Gerratyadd-cc: pick { T0_PICK(T0_POP()); } 161*0957b409SSimon J. Gerratyadd-cc: + { 162*0957b409SSimon J. Gerraty uint32_t b = T0_POP(); 163*0957b409SSimon J. Gerraty uint32_t a = T0_POP(); 164*0957b409SSimon J. Gerraty T0_PUSH(a + b); 165*0957b409SSimon J. Gerraty} 166*0957b409SSimon J. Gerratyadd-cc: - { 167*0957b409SSimon J. Gerraty uint32_t b = T0_POP(); 168*0957b409SSimon J. Gerraty uint32_t a = T0_POP(); 169*0957b409SSimon J. Gerraty T0_PUSH(a - b); 170*0957b409SSimon J. Gerraty} 171*0957b409SSimon J. Gerratyadd-cc: neg { 172*0957b409SSimon J. Gerraty uint32_t a = T0_POP(); 173*0957b409SSimon J. Gerraty T0_PUSH(-a); 174*0957b409SSimon J. Gerraty} 175*0957b409SSimon J. Gerratyadd-cc: * { 176*0957b409SSimon J. Gerraty uint32_t b = T0_POP(); 177*0957b409SSimon J. Gerraty uint32_t a = T0_POP(); 178*0957b409SSimon J. Gerraty T0_PUSH(a * b); 179*0957b409SSimon J. Gerraty} 180*0957b409SSimon J. Gerratyadd-cc: / { 181*0957b409SSimon J. Gerraty int32_t b = T0_POPi(); 182*0957b409SSimon J. Gerraty int32_t a = T0_POPi(); 183*0957b409SSimon J. Gerraty T0_PUSHi(a / b); 184*0957b409SSimon J. Gerraty} 185*0957b409SSimon J. Gerratyadd-cc: u/ { 186*0957b409SSimon J. Gerraty uint32_t b = T0_POP(); 187*0957b409SSimon J. Gerraty uint32_t a = T0_POP(); 188*0957b409SSimon J. Gerraty T0_PUSH(a / b); 189*0957b409SSimon J. Gerraty} 190*0957b409SSimon J. Gerratyadd-cc: % { 191*0957b409SSimon J. Gerraty int32_t b = T0_POPi(); 192*0957b409SSimon J. Gerraty int32_t a = T0_POPi(); 193*0957b409SSimon J. Gerraty T0_PUSHi(a % b); 194*0957b409SSimon J. Gerraty} 195*0957b409SSimon J. Gerratyadd-cc: u% { 196*0957b409SSimon J. Gerraty uint32_t b = T0_POP(); 197*0957b409SSimon J. Gerraty uint32_t a = T0_POP(); 198*0957b409SSimon J. Gerraty T0_PUSH(a % b); 199*0957b409SSimon J. Gerraty} 200*0957b409SSimon J. Gerratyadd-cc: < { 201*0957b409SSimon J. Gerraty int32_t b = T0_POPi(); 202*0957b409SSimon J. Gerraty int32_t a = T0_POPi(); 203*0957b409SSimon J. Gerraty T0_PUSH(-(uint32_t)(a < b)); 204*0957b409SSimon J. Gerraty} 205*0957b409SSimon J. Gerratyadd-cc: <= { 206*0957b409SSimon J. Gerraty int32_t b = T0_POPi(); 207*0957b409SSimon J. Gerraty int32_t a = T0_POPi(); 208*0957b409SSimon J. Gerraty T0_PUSH(-(uint32_t)(a <= b)); 209*0957b409SSimon J. Gerraty} 210*0957b409SSimon J. Gerratyadd-cc: > { 211*0957b409SSimon J. Gerraty int32_t b = T0_POPi(); 212*0957b409SSimon J. Gerraty int32_t a = T0_POPi(); 213*0957b409SSimon J. Gerraty T0_PUSH(-(uint32_t)(a > b)); 214*0957b409SSimon J. Gerraty} 215*0957b409SSimon J. Gerratyadd-cc: >= { 216*0957b409SSimon J. Gerraty int32_t b = T0_POPi(); 217*0957b409SSimon J. Gerraty int32_t a = T0_POPi(); 218*0957b409SSimon J. Gerraty T0_PUSH(-(uint32_t)(a >= b)); 219*0957b409SSimon J. Gerraty} 220*0957b409SSimon J. Gerratyadd-cc: = { 221*0957b409SSimon J. Gerraty uint32_t b = T0_POP(); 222*0957b409SSimon J. Gerraty uint32_t a = T0_POP(); 223*0957b409SSimon J. Gerraty T0_PUSH(-(uint32_t)(a == b)); 224*0957b409SSimon J. Gerraty} 225*0957b409SSimon J. Gerratyadd-cc: <> { 226*0957b409SSimon J. Gerraty uint32_t b = T0_POP(); 227*0957b409SSimon J. Gerraty uint32_t a = T0_POP(); 228*0957b409SSimon J. Gerraty T0_PUSH(-(uint32_t)(a != b)); 229*0957b409SSimon J. Gerraty} 230*0957b409SSimon J. Gerratyadd-cc: u< { 231*0957b409SSimon J. Gerraty uint32_t b = T0_POP(); 232*0957b409SSimon J. Gerraty uint32_t a = T0_POP(); 233*0957b409SSimon J. Gerraty T0_PUSH(-(uint32_t)(a < b)); 234*0957b409SSimon J. Gerraty} 235*0957b409SSimon J. Gerratyadd-cc: u<= { 236*0957b409SSimon J. Gerraty uint32_t b = T0_POP(); 237*0957b409SSimon J. Gerraty uint32_t a = T0_POP(); 238*0957b409SSimon J. Gerraty T0_PUSH(-(uint32_t)(a <= b)); 239*0957b409SSimon J. Gerraty} 240*0957b409SSimon J. Gerratyadd-cc: u> { 241*0957b409SSimon J. Gerraty uint32_t b = T0_POP(); 242*0957b409SSimon J. Gerraty uint32_t a = T0_POP(); 243*0957b409SSimon J. Gerraty T0_PUSH(-(uint32_t)(a > b)); 244*0957b409SSimon J. Gerraty} 245*0957b409SSimon J. Gerratyadd-cc: u>= { 246*0957b409SSimon J. Gerraty uint32_t b = T0_POP(); 247*0957b409SSimon J. Gerraty uint32_t a = T0_POP(); 248*0957b409SSimon J. Gerraty T0_PUSH(-(uint32_t)(a >= b)); 249*0957b409SSimon J. Gerraty} 250*0957b409SSimon J. Gerratyadd-cc: and { 251*0957b409SSimon J. Gerraty uint32_t b = T0_POP(); 252*0957b409SSimon J. Gerraty uint32_t a = T0_POP(); 253*0957b409SSimon J. Gerraty T0_PUSH(a & b); 254*0957b409SSimon J. Gerraty} 255*0957b409SSimon J. Gerratyadd-cc: or { 256*0957b409SSimon J. Gerraty uint32_t b = T0_POP(); 257*0957b409SSimon J. Gerraty uint32_t a = T0_POP(); 258*0957b409SSimon J. Gerraty T0_PUSH(a | b); 259*0957b409SSimon J. Gerraty} 260*0957b409SSimon J. Gerratyadd-cc: xor { 261*0957b409SSimon J. Gerraty uint32_t b = T0_POP(); 262*0957b409SSimon J. Gerraty uint32_t a = T0_POP(); 263*0957b409SSimon J. Gerraty T0_PUSH(a ^ b); 264*0957b409SSimon J. Gerraty} 265*0957b409SSimon J. Gerratyadd-cc: not { 266*0957b409SSimon J. Gerraty uint32_t a = T0_POP(); 267*0957b409SSimon J. Gerraty T0_PUSH(~a); 268*0957b409SSimon J. Gerraty} 269*0957b409SSimon J. Gerratyadd-cc: << { 270*0957b409SSimon J. Gerraty int c = (int)T0_POPi(); 271*0957b409SSimon J. Gerraty uint32_t x = T0_POP(); 272*0957b409SSimon J. Gerraty T0_PUSH(x << c); 273*0957b409SSimon J. Gerraty} 274*0957b409SSimon J. Gerratyadd-cc: >> { 275*0957b409SSimon J. Gerraty int c = (int)T0_POPi(); 276*0957b409SSimon J. Gerraty int32_t x = T0_POPi(); 277*0957b409SSimon J. Gerraty T0_PUSHi(x >> c); 278*0957b409SSimon J. Gerraty} 279*0957b409SSimon J. Gerratyadd-cc: u>> { 280*0957b409SSimon J. Gerraty int c = (int)T0_POPi(); 281*0957b409SSimon J. Gerraty uint32_t x = T0_POP(); 282*0957b409SSimon J. Gerraty T0_PUSH(x >> c); 283*0957b409SSimon J. Gerraty} 284*0957b409SSimon J. Gerratyadd-cc: data-get8 { 285*0957b409SSimon J. Gerraty size_t addr = T0_POP(); 286*0957b409SSimon J. Gerraty T0_PUSH(t0_datablock[addr]); 287*0957b409SSimon J. Gerraty} 288*0957b409SSimon J. Gerraty 289*0957b409SSimon J. Gerratyadd-cc: . { 290*0957b409SSimon J. Gerraty extern int printf(const char *fmt, ...); 291*0957b409SSimon J. Gerraty printf(" %ld", (long)T0_POPi()); 292*0957b409SSimon J. Gerraty} 293*0957b409SSimon J. Gerratyadd-cc: putc { 294*0957b409SSimon J. Gerraty extern int printf(const char *fmt, ...); 295*0957b409SSimon J. Gerraty printf("%c", (char)T0_POPi()); 296*0957b409SSimon J. Gerraty} 297*0957b409SSimon J. Gerratyadd-cc: puts { 298*0957b409SSimon J. Gerraty extern int printf(const char *fmt, ...); 299*0957b409SSimon J. Gerraty printf("%s", &t0_datablock[T0_POPi()]); 300*0957b409SSimon J. Gerraty} 301*0957b409SSimon J. Gerratyadd-cc: cr { 302*0957b409SSimon J. Gerraty extern int printf(const char *fmt, ...); 303*0957b409SSimon J. Gerraty printf("\n"); 304*0957b409SSimon J. Gerraty} 305*0957b409SSimon J. Gerratyadd-cc: eqstr { 306*0957b409SSimon J. Gerraty const void *b = &t0_datablock[T0_POPi()]; 307*0957b409SSimon J. Gerraty const void *a = &t0_datablock[T0_POPi()]; 308*0957b409SSimon J. Gerraty T0_PUSH(-(int32_t)(strcmp(a, b) == 0)); 309*0957b409SSimon J. Gerraty} 310