contrib/bearssl/T0/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 }