qemu/roms/SLOF/slof/engine.in

   1 /******************************************************************************
   2  * Copyright (c) 2004, 2008 IBM Corporation
   3  * All rights reserved.
   4  * This program and the accompanying materials
   5  * are made available under the terms of the BSD License
   6  * which accompanies this distribution, and is available at
   7  * http://www.opensource.org/licenses/bsd-license.php
   8  *
   9  * Contributors:
  10  *     IBM Corporation - initial implementation
  11  *****************************************************************************/
  12 // ============================================================================
  13 // ============================================================================
  14
  15
  16 //
  17 // Copyright 2002,2003,2004  Segher Boessenkool  <segher@kernel.crashing.org>
  18 //
  19
  20 // This is the core engine of Paflof.  It is almost ANS Forth compatible.
  21 // There are two possibilities why an aspect would not be:
  22 //   a) Open Firmware requires different semantics;
  23 //   b) bugs.
  24 // Most of the "extended" semantics defined in the OF specification are
  25 // not implemented; just the bare essentials.  For example, you can't
  26 // use structural words (IF, THEN, BEGIN, etc.) or return-stack
  27 // manipulation words (R> etc.) in the interpreter.
  28
  29 // The data stack pointer.
  30 raw(HERE DOVAL _A(the_mem))
  31
  32 // Some common constant numbers; smaller and faster if they are defined
  33 // as constants, than when inlined as a literal.
  34 con(-1 -1)
  35 con(0 0)
  36 con(1 1)
  37 con(2 2)
  38 con(3 3)
  39 con(4 4)
  40 con(8 8)
  41 con(H#10 0x10)
  42 con(H#20 0x20)
  43 con(H#FF 0xff)
  44 con(H#FFFF 0xffff)
  45 con(H#FFFFFFFF 0xffffffff)
  46 con(D#10 0x0a)
  47
  48
  49 // Manipulating different kinds of addresses.
  50 con(/C 1)
  51 con(/W 2)
  52 con(/L 4)
  53 con(/X 8)
  54 con(/N CELLSIZE)
  55 con(CELL CELLSIZE)
  56 col(/C* /C *)
  57 col(/W* /W *)
  58 col(/L* /L *)
  59 col(/X* /X *)
  60 col(/N* /N *)
  61 col(CA+ /C* +)
  62 col(WA+ /W* +)
  63 col(LA+ /L* +)
  64 col(XA+ /X* +)
  65 col(NA+ /N* +)
  66 col(CA1+ /C +)
  67 col(WA1+ /W +)
  68 col(LA1+ /L +)
  69 col(XA1+ /X +)
  70 col(NA1+ /N +)
  71 col(CHAR+ CA1+)
  72 col(CELL+ NA1+)
  73 col(CHAR- /C -)
  74 col(CELL- /N -)
  75 col(CHARS /C*)
  76 col(CELLS /N*)
  77 col(CHARS+ CA+)
  78 col(CELLS+ NA+)
  79
  80
  81 // Run-time words for TO and for string literals.
  82 col(DOTO R> CELL+ DUP >R @ CELL+ !)
  83 col(SLITERAL R> CELL+ DUP DUP C@ + LIT(-CELLSIZE) AND >R)
  84
  85
  86 // Stack manipulation.
  87 col(?DUP DUP 0BRANCH(1) DUP)
  88 col(TUCK SWAP OVER)
  89 col(2DUP OVER OVER)
  90 col(3DUP 2 PICK 2 PICK 2 PICK)
  91 col(2OVER 3 PICK 3 PICK)
  92 col(2DROP DROP DROP)
  93 col(3DROP DROP DROP DROP)
  94 col(NIP SWAP DROP)
  95 col(CLEAR 0 DEPTH!)
  96 col(ROT >R SWAP R> SWAP)
  97 col(-ROT SWAP >R SWAP R>)
  98 col(2SWAP >R -ROT R> -ROT)
  99 col(2ROT >R >R 2SWAP R> R> 2SWAP)
 100 col(ROLL DUP ?DUP 0BRANCH(6) ROT >R 1 - BRANCH(-9) ?DUP 0BRANCH(6) R> -ROT 1 - BRANCH(-9))
 101 col(-ROLL DUP ?DUP 0BRANCH(9) >R ROT R> SWAP >R 1 - BRANCH(-12) ?DUP 0BRANCH(6) R> SWAP 1 - BRANCH(-9))
 102 col(2>R R> ROT >R SWAP >R >R)
 103 col(2R> R> R> R> ROT >R SWAP)
 104 col(2R@ R> R> R@ OVER >R ROT >R SWAP)
 105 cod(?PICK)
 106
 107 // Arithmetic.
 108 col(2* 1 LSHIFT)
 109 col(U2/ 1 RSHIFT)
 110 col(2/ 1 ASHIFT)
 111 col(<< LSHIFT)
 112 col(>> RSHIFT)
 113 col(>>A ASHIFT)
 114 col(INVERT -1 XOR)
 115 col(NOT INVERT)
 116
 117
 118 // Booleans.
 119 con(TRUE -1)
 120 con(FALSE 0)
 121
 122
 123 // Comparisons.
 124 col(> SWAP <)
 125 col(U> SWAP U<)
 126 col(<= > 0=)
 127 col(<> = 0=)
 128 col(>= < 0=)
 129 col(0<= 0 <=)
 130 col(0<> 0 <>)
 131 col(0> 0 >)
 132 col(0>= 0 >=)
 133 col(U<= U> 0=)
 134 col(U>= U< 0=)
 135 col(WITHIN ROT DUP ROT >= 0BRANCH(3) 2DROP FALSE EXIT > 0BRANCH(2) FALSE EXIT TRUE)
 136 col(BETWEEN 1 + WITHIN)
 137
 138 // Double-cell single-bit shifts.
 139 col(D2* 2* OVER 0< - >R 2* R>)
 140 col(UD2/ >R U2/ R@ LIT(8*CELLSIZE-1) LSHIFT OR R> U2/)
 141 col(D2/ >R U2/ R@ LIT(8*CELLSIZE-1) LSHIFT OR R> 2/)
 142
 143
 144 // More arithmetic.
 145 col(NEGATE 0 SWAP -)
 146 col(ABS DUP 0< 0BRANCH(1) NEGATE)
 147 col(MAX 2DUP < 0BRANCH(1) SWAP DROP)
 148 col(MIN 2DUP > 0BRANCH(1) SWAP DROP)
 149 col(U* *)
 150 col(1+ 1 +)
 151 col(1- 1 -)
 152 col(2+ 2 +)
 153 col(2- 2 -)
 154 col(EVEN 1+ -1 AND)
 155 col(BOUNDS OVER + SWAP)
 156
 157
 158 // Double-cell and mixed-size arithmetic.
 159 col(S>D DUP 0<)
 160 col(DNEGATE INVERT >R NEGATE DUP 0= R> SWAP -)
 161 col(DABS DUP 0< 0BRANCH(1) DNEGATE)
 162 col(M+ SWAP >R DUP >R + DUP R> U< R> SWAP -)
 163 col(D+ >R M+ R> +)
 164 col(D- DNEGATE D+)
 165 col(*' >R DUP 0< >R D2* R> 0BRANCH(2) R@ M+ R>)
 166 col(UM* 0 -ROT LIT(8*CELLSIZE) 0 DODO *' DOLOOP(-3) DROP)
 167 col(M* 2DUP XOR >R >R ABS R> ABS UM* R> 0< 0BRANCH(1) DNEGATE)
 168 col(/' >R DUP 0< >R D2* R> OVER R@ U>= OR 0BRANCH(6) >R 1 OR R> R@ - R>)
 169 col(UM/MOD LIT(8*CELLSIZE) 0 DODO /' DOLOOP(-3) DROP SWAP)
 170 col(SM/REM OVER >R >R DABS R@ ABS UM/MOD R> 0< 0BRANCH(1) NEGATE R> 0< 0BRANCH(4) NEGATE SWAP NEGATE SWAP)
 171 col(FM/MOD DUP >R 2DUP XOR 0< >R SM/REM OVER 0<> R> AND 0BRANCH(6) 1- SWAP R> + SWAP EXIT R> DROP)
 172
 173
 174 // Division.
 175 col(U/MOD 0 SWAP UM/MOD)
 176 col(/MOD >R S>D R> FM/MOD)
 177 col(/ /MOD NIP)
 178 col(MOD /MOD DROP)
 179 col(*/MOD >R M* R> FM/MOD)
 180 col(*/ */MOD NIP)
 181
 182
 183 // Splitting, joining, flipping the components of a number.
 184 col(WBSPLIT DUP H#FF AND SWAP 8 RSHIFT)
 185 col(LWSPLIT DUP H#FFFF AND SWAP H#10 RSHIFT)
 186 col(XLSPLIT DUP H#FFFFFFFF AND SWAP H#20 RSHIFT)
 187 col(LBSPLIT LWSPLIT >R WBSPLIT R> WBSPLIT)
 188 col(XWSPLIT XLSPLIT >R LWSPLIT R> LWSPLIT)
 189 col(XBSPLIT XLSPLIT >R LBSPLIT R> LBSPLIT)
 190 col(BWJOIN 8 LSHIFT OR)
 191 col(WLJOIN H#10 LSHIFT OR)
 192 col(BLJOIN BWJOIN >R BWJOIN R> WLJOIN)
 193 col(WBFLIP WBSPLIT SWAP BWJOIN)
 194 col(LWFLIP LWSPLIT SWAP WLJOIN)
 195 col(LXJOIN H#20 LSHIFT OR)
 196 col(XLFLIP XLSPLIT SWAP LXJOIN)
 197 col(LBFLIP LBSPLIT SWAP 2SWAP SWAP BLJOIN)
 198 col(WXJOIN WLJOIN >R WLJOIN R> LXJOIN)
 199 col(XWFLIP XWSPLIT SWAP 2SWAP SWAP WXJOIN)
 200 col(BXJOIN BLJOIN >R BLJOIN R> LXJOIN)
 201 col(XBFLIP XLSPLIT LBFLIP SWAP LBFLIP LXJOIN)
 202
 203 // Aligning to cell size.
 204 col(ALIGNED /N 1- + /N NEGATE AND)
 205
 206
 207 // Counted loop stuff.
 208 col(I R> R@ SWAP >R)
 209 col(J R> R> R> R@ SWAP >R SWAP >R SWAP >R)
 210 col(UNLOOP R> R> R> 2DROP >R)
 211
 212
 213 // Memory accesses.
 214 col(+! TUCK @ + SWAP !)
 215 cod(COMP)
 216 col(OFF FALSE SWAP !)
 217 col(ON TRUE SWAP !)
 218 col(<W@ W@ DUP LIT(0x8000) >= 0BRANCH(3) LIT(0x10000) -)
 219 col(2@ DUP CELL+ @ SWAP @)
 220 col(2! DUP >R ! R> CELL+ !)
 221 col(WBFLIPS BOUNDS DO?DO(8) I W@ WBFLIP I W! /W DO+LOOP(-8))
 222 col(LWFLIPS BOUNDS DO?DO(8) I L@ LWFLIP I L! /L DO+LOOP(-8))
 223 col(LBFLIPS BOUNDS DO?DO(8) I L@ LBFLIP I L! /L DO+LOOP(-8))
 224 col(XBFLIPS BOUNDS DO?DO(8) I X@ XBFLIP I X! /X DO+LOOP(-8))
 225 col(XWFLIPS BOUNDS DO?DO(8) I X@ XWFLIP I X! /X DO+LOOP(-8))
 226 col(XLFLIPS BOUNDS DO?DO(8) I X@ XLFLIP I X! /X DO+LOOP(-8))
 227 cod(FILL)
 228 col(BLANK LIT(0x20) FILL)
 229 col(ERASE LIT(0x00) FILL)
 230
 231
 232 // Exception handling.
 233 var(CATCHER 0)
 234 var(ABORT"-STR 0)
 235 col(CATCH DEPTH >R CATCHER @ >R RDEPTH CATCHER ! EXECUTE R> CATCHER ! R> DROP 0)
 236 col(THROW ?DUP 0BRANCH(12) CATCHER @ RDEPTH! R> CATCHER ! R> SWAP >R DEPTH! DROP R>)
 237 col(ABORT -1 THROW)
 238
 239
 240 // Text input.
 241 var(#TIB TIBSIZE)
 242 val(IB 0)
 243 var(#IB 0)
 244 val(SOURCE-ID 0)
 245 col(SOURCE IB #IB @)
 246 var(>IN 0)
 247 col(TERMINAL TIB DOTO IB #TIB @ #IB ! 0 DOTO SOURCE-ID)
 248
 249
 250 // ASCII codes.
 251 con(BL 0x20)
 252 con(BELL 7)
 253 con(BS 8)
 254 con(CARRET 0x0d)
 255 con(LINEFEED 0x0a)
 256
 257
 258 // Text output.
 259 dfr(EMIT)
 260 dfr(CR)
 261 col(TYPE BOUNDS DO?DO(5) I C@ EMIT DOLOOP(-5))
 262 col(LL-CR CARRET EMIT LINEFEED EMIT)
 263 col(SPACE BL EMIT)
 264 col(SPACES 0 DO?DO(3) SPACE DOLOOP(-3))
 265
 266
 267 // Text manipulation.
 268 col(COUNT DUP CHAR+ SWAP C@)
 269 col(PACK DUP >R 1+ SWAP DUP R@ C! MOVE R>)
 270 col(UPC DUP LIT('a') LIT('z') BETWEEN 0BRANCH(3) LIT(0x20) - )
 271 col(LCC DUP LIT('A') LIT('Z') BETWEEN 0BRANCH(3) LIT(0x20) + )
 272
 273
 274 // Text input.
 275 dfr(KEY)
 276 dfr(KEY?)
 277 dfr(ACCEPT)
 278 var(SPAN 0)
 279 col(EXPECT ACCEPT SPAN !)
 280 col(REFILL SOURCE-ID 0= 0BRANCH(7) SOURCE EXPECT 0 >IN ! TRUE EXIT SOURCE-ID -1 = 0BRANCH(2) FALSE EXIT LIT(0x6502) THROW)
 281
 282
 283 // Number base.
 284 var(BASE 16)
 285 col(DECIMAL D#10 BASE !)
 286 col(HEX H#10 BASE !)
 287 col(OCTAL 8 BASE !)
 288
 289
 290 // Pictured numeric output.
 291 col(PAD HERE LIT(256) +)
 292 col(TODIGIT DUP LIT(9) > 0BRANCH(3) LIT(0x27) + LIT(0x30) +)
 293 col(MU/MOD DUP >R U/MOD R> SWAP >R UM/MOD R>)
 294 col(<# PAD DUP !)
 295 col(HOLD PAD DUP @ 1- TUCK SWAP ! C!)
 296 col(SIGN 0< 0BRANCH(3) LIT('-') HOLD)
 297 col(# BASE @ MU/MOD ROT TODIGIT HOLD)
 298 col(#S # 2DUP OR 0BRANCH(2) BRANCH(-7))
 299 col(#> 2DROP PAD DUP @ TUCK -)
 300 col((.) <# DUP >R ABS 0 #S R> SIGN #>)
 301 col(U# BASE @ U/MOD SWAP TODIGIT HOLD)
 302 col(U#S U# DUP 0BRANCH(2) BRANCH(-6))
 303 col(U#> DROP PAD DUP @ TUCK -)
 304 col((U.) <# U#S U#>)
 305 col(. (.) TYPE SPACE)
 306 col(S. .)
 307 col(U. (U.) TYPE SPACE)
 308 col(.R SWAP (.) ROT 2DUP < 0BRANCH(5) OVER - SPACES BRANCH(1) DROP TYPE)
 309 col(U.R SWAP (U.) ROT 2DUP < 0BRANCH(5) OVER - SPACES BRANCH(1) DROP TYPE)
 310 col(.D BASE @ SWAP DECIMAL . BASE !)
 311 col(.H BASE @ SWAP HEX . BASE !)
 312 col(.S DEPTH DUP 0< 0BRANCH(2) DROP EXIT 0 DO?DO(8) DEPTH I - 1- PICK . DOLOOP(-8))
 313 col(? @ .)
 314
 315
 316 // Numeric input.
 317 col(DIGIT OVER UPC DUP LIT('A') LIT('Z') BETWEEN 0BRANCH(3) LIT(7) - LIT(0x30) - DUP ROT 0 SWAP WITHIN 0BRANCH(4) NIP TRUE BRANCH(2) DROP FALSE)
 318 col(>NUMBER DUP 0= 0BRANCH(1) EXIT OVER C@ BASE @ DIGIT 0BRANCH(23) SWAP >R SWAP >R >R BASE @ U* SWAP BASE @ UM* ROT + R> 0 D+ R> CHAR+ R> 1- BRANCH(-35) DROP)
 319 col($NUMBER DUP 0= 0BRANCH(4) DROP DROP TRUE EXIT >R DUP >R C@ LIT('-') = DUP 0BRANCH(15) R> CHAR+ R> 1- DUP 0= 0BRANCH(5) DROP DROP DROP TRUE EXIT >R >R 0 0 R> R> >NUMBER NIP 0= 0BRANCH(7) DROP SWAP 0BRANCH(1) NEGATE FALSE EXIT DROP DROP DROP TRUE)
 320
 321
 322 // Data space allocation.
 323 col(ALLOT HERE + DOTO HERE)
 324 col(, HERE ! /N ALLOT)
 325 col(C, HERE C! /C ALLOT)
 326 col(W, HERE W! /W ALLOT)
 327 col(L, HERE L! /L ALLOT)
 328 col(X, HERE X! /X ALLOT)
 329 col(ALIGN HERE /N 1- AND 0BRANCH(4) 0 C, BRANCH(-10))
 330 col(PLACE 2DUP C! CHAR+ SWAP CHARS BOUNDS DO?DO(9) DUP C@ I C! CHAR+ 1 CHARS DO+LOOP(-9) DROP)
 331 col(STRING, HERE OVER 1+ CHARS ALLOT PLACE)
 332
 333
 334 // Every language needs a no-op.
 335 col(NOOP)
 336
 337
 338 // Now it gets ugly: search-order and word-lisst infrastructure.
 339
 340 raw(FORTH-WORDLIST DODOES _A(xt_NOOP+2+(8/sizeof(long))) _A(0) _A(0))
 341         // Engine initialisation will set this last cell to the xt of LASTWORD.
 342
 343 // compilation dictionary
 344 raw(CURRENT DOVAL _A(xt_FORTH_X2d_WORDLIST+3+(16/sizeof(long))))
 345         // +7 for 32-bit, +5 for 64-bit
 346
 347 col(LAST CURRENT CELL+)
 348
 349 // for context dictionaries
 350 raw(SEARCH-ORDER DOVAR _A(xt_FORTH_X2d_WORDLIST+3+(16/sizeof(long))) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0))
 351         // +7 for 32-bit, +5 for 64-bit
 352 // for context dictionaries
 353 //raw(SEARCH-ORDER DOVAR _A(xt_FORTH_X2d_WORDLIST+3+(sizeof("  FORTH-WORDLIST")/sizeof(long))) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0) _A(0))
 354 // +7 for 32-bit, +5 for 64-bit
 355 raw(CONTEXT DOVAL _A(xt_SEARCH_X2d_ORDER+2+(16/sizeof(long))))
 356 //raw(CONTEXT DOVAL _A(xt_SEARCH_X2d_ORDER+6))
 357 // +6 for 32-bit, +4 for 64-bit
 358
 359 // Dictionary structure.
 360 col(LINK>NAME CELL+)
 361 col(NAME> CHAR+ DUP C@ 1+ CHARS+ ALIGNED)
 362 col(LINK> LINK>NAME NAME>)
 363 col(NAME>STRING CHAR+ COUNT)
 364
 365 // Creating word headers.
 366 var(LATEST 0)
 367 dfr((REVEAL))
 368 col(HEADER ALIGN HERE LAST @ , LATEST ! 0 C, STRING, ALIGN)
 369 col(REVEAL   LATEST @ LINK>NAME NAME>STRING (REVEAL) LATEST @ LAST !)
 370
 371
 372 // Finding words.
 373 cod(STRING=CI)
 374 // (find) ( str len head -- 0 | link )
 375 dfr((FIND))
 376 col(((FIND)) DUP 0BRANCH(15) >R 2DUP R@ LINK>NAME NAME>STRING STRING=CI 0BRANCH(3) 2DROP R> EXIT R> @ BRANCH(-18) 3DROP FALSE)
 377 col((FIND-ORDER) CONTEXT DUP >R SEARCH-ORDER U>= 0BRANCH(18) 2DUP R@ @ CELL+ @ (FIND) ?DUP 0BRANCH(5) NIP NIP R> DROP EXIT R> CELL- BRANCH(-24) R> 3DROP 0)
 378 col(($FIND) (FIND-ORDER) DUP 0BRANCH(6) LINK>NAME DUP NAME> SWAP C@ TRUE)
 379 col($FIND 2DUP ($FIND) 0BRANCH(6) DROP NIP NIP TRUE BRANCH(1) FALSE)
 380
 381 // Flags on words.
 382 con('IMMEDIATE 1)
 383 col(IMMEDIATE? 'IMMEDIATE AND 0<>)
 384 col(IMMEDIATE LAST @ CELL+ DUP C@ 'IMMEDIATE OR SWAP C!)
 385
 386 // Parsing.
 387 col(FINDCHAR SWAP 0 DO?DO(24) OVER I + C@ OVER DUP BL = 0BRANCH(3) <= BRANCH(1) = 0BRANCH(6) I UNLOOP NIP NIP TRUE EXIT DOLOOP(-24) DROP DROP FALSE)
 388 col(PARSE >R IB >IN @ + SPAN @ >IN @ - 2DUP R> FINDCHAR 0BRANCH(6) NIP DUP 1 + BRANCH(1) DUP >IN +!)
 389 col(SKIPWS IB SPAN @ DUP >IN @ > 0BRANCH(14) OVER >IN @ + C@ BL <= 0BRANCH(5) 1 >IN +! BRANCH(-20) DROP DROP)
 390 col(PARSE-WORD SKIPWS BL PARSE)
 391 var(WHICHPOCKET 0)
 392 // We reserved 0x1000 for the pockets. So we have 16 pockets a 0x100
 393 col(POCKET POCKETS WHICHPOCKET @ LIT(POCKETSIZE) * + WHICHPOCKET @ 1 + DUP LIT(NUMPOCKETS) = 0BRANCH(2) DROP 0 WHICHPOCKET !)
 394
 395 col(WORD POCKET >R PARSE DUP R@ C! BOUNDS R> DUP 2SWAP DO?DO(7) CHAR+ I C@ OVER C! DOLOOP(-7) DROP)
 396
 397 // Some simple parsing words.
 398 col(CHAR PARSE-WORD DROP C@)
 399 imm(( LIT(')') PARSE 2DROP)
 400 // Removing comments out of the code, the code from the backslash to the next \n is removed.
 401 // We need to start from cursor -1 (the backslash) to handle the case backslash+linefeed correctly 0x5c0a
 402 imm(\ >IN @ 1- >IN ! LINEFEED PARSE 2DROP)
 403
 404 // The compiler infrastructure.
 405 var(STATE 0)
 406 imm([ STATE OFF)
 407 col(] LIT(0x100) STATE !)
 408 col(?COMP STATE @ 0BRANCH(1) EXIT LIT(-134) THROW)
 409
 410 col(COMPILE, ,)
 411 col(: PARSE-WORD HEADER DOTICK DOCOL COMPILE, ])
 412 col(:NONAME ALIGN HERE DOTICK DOCOL COMPILE, ])
 413 imm(; ?COMP DOTICK SEMICOLON COMPILE, REVEAL [)
 414
 415 // Compiling strings.
 416 imm(C" ?COMP LIT('"') PARSE DOTICK SLITERAL COMPILE, DUP C, BOUNDS DO?DO(5) I C@ C, DOLOOP(-5) ALIGN)
 417 imm(S" STATE @ 0BRANCH(5) C" DOTICK COUNT COMPILE, EXIT LIT('"') PARSE DUP >R POCKET DUP >R SWAP MOVE R> R>)
 418 imm(Z" S" 2DUP + 0 SWAP C! DROP)
 419 imm(." STATE @ 0BRANCH(5) S" DOTICK TYPE COMPILE, EXIT  LIT('"') PARSE TYPE)
 420 imm(.( LIT(')') PARSE TYPE)
 421
 422 col(COMPILE R> CELL+ DUP @ COMPILE, >R)
 423
 424 var(THERE 0)
 425 col(+COMP STATE @ 1 STATE +! 0BRANCH(1) EXIT HERE THERE ! COMP-BUFFER DOTO HERE COMPILE DOCOL)
 426 col(-COMP -1 STATE +! STATE @ 0BRANCH(1) EXIT COMPILE EXIT THERE @ DOTO HERE COMP-BUFFER EXECUTE)
 427
 428 // Structure words.
 429 col(RESOLVE-ORIG HERE OVER CELL+ - SWAP !)
 430 imm(AHEAD +COMP DOTICK DOBRANCH COMPILE, HERE 0 COMPILE,)
 431 imm(IF +COMP DOTICK DO0BRANCH COMPILE, HERE 0 COMPILE,)
 432 imm(THEN ?COMP RESOLVE-ORIG -COMP)
 433 imm(ELSE ?COMP DOTICK DOBRANCH COMPILE, HERE 0 COMPILE, SWAP RESOLVE-ORIG)
 434
 435 imm(CASE +COMP 0)
 436 imm(ENDCASE ?COMP DOTICK DROP COMPILE, ?DUP 0BRANCH(5) 1- SWAP THEN BRANCH(-8) -COMP)
 437 imm(OF ?COMP 1+ >R DOTICK OVER COMPILE, DOTICK = COMPILE, IF DOTICK DROP COMPILE, R>)
 438 imm(ENDOF ?COMP >R ELSE R>)
 439
 440 col(RESOLVE-DEST HERE CELL+ - COMPILE,)
 441 imm(BEGIN +COMP HERE)
 442 imm(AGAIN ?COMP DOTICK DOBRANCH COMPILE, RESOLVE-DEST -COMP)
 443 imm(UNTIL ?COMP DOTICK DO0BRANCH COMPILE, RESOLVE-DEST -COMP)
 444 imm(WHILE ?COMP IF SWAP)
 445 imm(REPEAT ?COMP AGAIN THEN)
 446
 447 // Counted loops.
 448 var(LEAVES 0)
 449 col(RESOLVE-LOOP LEAVES @ ?DUP 0BRANCH(10) DUP @ SWAP HERE OVER - SWAP ! BRANCH(-13) HERE - COMPILE, LEAVES !)
 450 imm(DO +COMP LEAVES @ HERE DOTICK DODO COMPILE, 0 LEAVES !)
 451 imm(?DO +COMP LEAVES @ DOTICK DODO?DO COMPILE, HERE HERE LEAVES ! 0 COMPILE,)
 452 imm(LOOP ?COMP DOTICK DODOLOOP COMPILE, RESOLVE-LOOP -COMP)
 453 imm(+LOOP ?COMP DOTICK DODO+LOOP COMPILE, RESOLVE-LOOP -COMP)
 454 imm(LEAVE ?COMP DOTICK DODOLEAVE COMPILE, LEAVES @ HERE LEAVES ! COMPILE,)
 455 imm(?LEAVE ?COMP DOTICK DODO?LEAVE COMPILE, LEAVES @ HERE LEAVES ! COMPILE,)
 456
 457 // Interpreter nesting.
 458 col(SAVE-SOURCE R> IB >R #IB @ >R SOURCE-ID >R SPAN @ >R >IN @ >R >R)
 459 col(RESTORE-SOURCE R> R> >IN ! R> SPAN ! R> DOTO SOURCE-ID R> #IB ! R> DOTO IB >R)
 460
 461 // System replies.
 462 str(OK-STR "ok")
 463 str(ABORTED-STR "Aborted")
 464 str(EXCEPTION-STR "Exception #")
 465 str(UNKNOWN-STR "Undefined word")
 466 dfr(HW-EXCEPTION-HANDLER)
 467 val(SHOW-STACK? 0)
 468 col(SHOWSTACK -1 DOTO  SHOW-STACK?)
 469 col(NOSHOWSTACK 0 DOTO  SHOW-STACK?)
 470 col(PRINT-STACK SHOW-STACK? 0BRANCH(5) >R >R .S R> R> )
 471 col(PRINT-EXCEPTION DUP LIT(-99) = 0BRANCH(7) DOTICK UNKNOWN-STR COUNT TYPE CR DROP EXIT DUP LIT(0x100) = 0BRANCH(2) DROP EXIT HW-EXCEPTION-HANDLER )
 472 col(PRINT-STATUS SPACE DUP 0= 0BRANCH(5) PRINT-STACK DOTICK OK-STR BRANCH(7) DUP -1 = 0BRANCH(6) DOTICK ABORTED-STR COUNT TYPE BRANCH(10) DUP LIT(-2) = 0BRANCH(7) ABORT"-STR @ COUNT TYPE DROP BRANCH(1) PRINT-EXCEPTION CR)
 473
 474 // The compiler and interpreter.
 475 col(COMPILE-WORD 2DUP ($FIND) 0BRANCH(10) IMMEDIATE? 0BRANCH(4) NIP NIP EXECUTE EXIT COMPILE, 2DROP EXIT 2DUP $NUMBER 0BRANCH(4) TYPE LIT(-99) THROW DOTICK DOLIT COMPILE, COMPILE, 2DROP)
 476 col(INTERPRET-WORD 2DUP ($FIND) 0BRANCH(5) DROP NIP NIP EXECUTE EXIT 2DUP $NUMBER 0BRANCH(4) TYPE LIT(-99) THROW >R 2DROP R>)
 477 col(INTERPRET 0 >IN ! PARSE-WORD DUP 0BRANCH(10) STATE @ 0BRANCH(3) COMPILE-WORD BRANCH(1) INTERPRET-WORD BRANCH(-14) 2DROP)
 478
 479 // Evaluate, the one word to rule them all.  It is evil, btw.
 480 col(EVALUATE SAVE-SOURCE -1 DOTO SOURCE-ID DUP #IB ! SPAN ! DOTO IB DOTICK INTERPRET CATCH RESTORE-SOURCE THROW)
 481 col(EVAL EVALUATE)
 482
 483 // Abort with a message.
 484 col(DOABORT" SWAP 0BRANCH(5) ABORT"-STR ! LIT(-2) THROW DROP)
 485 imm(ABORT" C" DOTICK DOABORT" COMPILE,)
 486
 487 // Tick.
 488 str(UNDEFINED-STR "undefined word ")
 489 col(SET-UNDEFINED-WORD POCKET >R DOTICK UNDEFINED-STR DUP C@ 1+ R@ SWAP MOVE R@ DUP C@ 1+ + SWAP DUP R@ C@ + R@ C! MOVE R>)
 490 col(' PARSE-WORD $FIND 0= 0BRANCH(4) SET-UNDEFINED-WORD TRUE SWAP DOABORT")
 491
 492 // The outer interpreter.
 493 col(QUIT 0 RDEPTH! [ TERMINAL DEPTH . LIT('>') EMIT SPACE REFILL 0BRANCH(10) SPACE DOTICK INTERPRET CATCH DUP PRINT-STATUS 0BRANCH(-17) BRANCH(-23))
 494
 495 // Reading and writing to/from file; including files.
 496 dfr(MAP-FILE)
 497 dfr(UNMAP-FILE)
 498 dfr(WRITE-FILE)
 499 col(INCLUDED MAP-FILE 2DUP >R >R BOUNDS DO?DO(21) R> R@ SWAP >R R@ - R@ SWAP 2DUP LINEFEED FINDCHAR 0BRANCH(1) NIP DUP >R EVALUATE R> 1+ DO+LOOP(-21) R> R> UNMAP-FILE)
 500 col(INCLUDE PARSE-WORD INCLUDED)
 501
 502 // CREATE ... DOES> ...
 503 col($CREATE HEADER DOTICK DODOES COMPILE, DOTICK NOOP CELL+ COMPILE, REVEAL)
 504 col(CREATE PARSE-WORD $CREATE)
 505 col(DODOES> R> CELL+ LATEST @ LINK> CELL+ !)
 506 imm(DOES> DOTICK DODOES> COMPILE,)
 507
 508 // Defining words.
 509 col(CONSTANT PARSE-WORD HEADER DOTICK DOCON COMPILE, COMPILE, REVEAL)
 510 col(VALUE PARSE-WORD HEADER DOTICK DOVAL COMPILE, COMPILE, REVEAL)
 511 col(VARIABLE PARSE-WORD HEADER DOTICK DOVAR COMPILE, 0 COMPILE, REVEAL)
 512 col(BUFFER: PARSE-WORD HEADER DOTICK DOBUFFER: COMPILE, ALLOT REVEAL)
 513 col(DEFER PARSE-WORD HEADER DOTICK DODEFER COMPILE, DOTICK ABORT COMPILE, REVEAL)
 514 col(ALIAS PARSE-WORD HEADER DOTICK DOALIAS COMPILE, ' COMPILE, REVEAL)
 515 col(STRUCT 0)
 516 col(END-STRUCT DROP)
 517 col(FIELD PARSE-WORD HEADER DOTICK DOFIELD COMPILE, OVER , + REVEAL)
 518
 519 // Words with (mostly) non-standard compilation behaviour.
 520 imm(LITERAL DOTICK DOLIT COMPILE, COMPILE,)
 521 imm([COMPILE] ' COMPILE,)
 522 imm(POSTPONE PARSE-WORD 2DUP ($FIND) 0= 0BRANCH(4) SET-UNDEFINED-WORD TRUE SWAP DOABORT" IMMEDIATE? 0= 0BRANCH(6) DOTICK DOTICK COMPILE, COMPILE, DOTICK COMPILE, COMPILE, 2DROP)
 523 imm([CHAR] CHAR LITERAL)
 524 imm(['] ' DOTICK DOTICK COMPILE, COMPILE,)
 525
 526 // FIND.
 527 col(FIND DUP COUNT ($FIND) 0BRANCH(9) ROT DROP TRUE SWAP IMMEDIATE? 0BRANCH(1) NEGATE EXIT FALSE EXIT)
 528
 529 // Accessing data in CREATE'd words.
 530 imm(TO ' STATE @ 0BRANCH(5) DOTICK DOTO COMPILE, COMPILE, EXIT CELL+ !)
 531 col(BEHAVIOR CELL+ @)
 532 col(>BODY 2 CELLS +)
 533 col(BODY> 2 CELLS -)
 534
 535 // Making words recursive.
 536 imm(RECURSIVE REVEAL)
 537 imm(RECURSE LATEST @ LINK> COMPILE,)
 538
 539 // Numeric input.
 540 imm(d# PARSE-WORD BASE @ >R DECIMAL EVALUATE R> BASE !)
 541 imm(h# PARSE-WORD BASE @ >R HEX EVALUATE R> BASE !)
 542 imm(o# PARSE-WORD BASE @ >R OCTAL EVALUATE R> BASE !)