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