\ Shorthand for working with cell-aligned addresses : CELL+ ( addr1 -- addr2 ) CELL + ; : CELL- ( addr1 -- addr2 ) CELL - ; : CELLS ( n1 -- n2 ) CELL * ; : CELLS+ ( addr1 n -- addr2 ) CELL * + ; : CELLS- ( addr1 n -- addr2 ) CELL * - ; \ Round up to the next cell-aligned address : ALIGNED ( addr -- a-addr ) [ CELL 1- ] LITERAL + [ CELL NEGATE ] LITERAL AND ; \ Field accessors for execution tokens : >CFA ( xt -- a-addr ) ; : >DFA ( xt -- a-addr ) CELL+ ; : >LINK ( xt -- a-addr ) 2 CELLS+ ; : >FLAGS ( xt -- c-addr ) 3 CELLS+ ; : >NAME ( xt -- c-addr u ) >FLAGS DUP 1+ SWAP C@ F_LENMASK AND ; : >BODY ( xt -- a-addr ) >NAME + ALIGNED ; : IMMEDIATE? ( xt -- flag ) >FLAGS C@ F_IMMED AND 0<> ; : HIDDEN? ( xt -- flag ) >FLAGS C@ F_HIDDEN AND 0<> ; \ Set or clear the HIDDEN flag for word with the given execution token : (HIDE) ( xt -- ) >FLAGS DUP C@ F_HIDDEN OR SWAP C! ; : (UNHIDE) ( xt -- ) >FLAGS DUP C@ F_HIDDEN INVERT AND SWAP C! ; \ QUIT needs to be deferred so that it can refer to INTERPRET DEFER QUIT ( -- ) ' BAILOUT ' QUIT DEFER! \ Standard (ANS FORTH) THROW code assignments (-255 ... -1) -1 CONSTANT EXCP-ABORT -2 CONSTANT EXCP-FAIL -3 CONSTANT EXCP-STACK-OVERFLOW -4 CONSTANT EXCP-STACk-UNDERFLOW -5 CONSTANT EXCP-RETURN-OVERFLOW -6 CONSTANT EXCP-RETURN-UNDERFLOW -8 CONSTANT EXCP-DICTIONARY-OVERFLOW -13 CONSTANT EXCP-UNDEFINED-WORD -24 CONSTANT EXCP-BAD-NUMERIC-ARGUMENT -37 CONSTANT EXCP-FILE-IO \ Non-standard system error codes (-4095 ... -256) -256 CONSTANT EXCP-HEAP-OVERFLOW \ THROWN-STRING holds the address and size of the string passed to FAIL \ It may also be used to hold context strings for other system exception codes CREATE THROWN-STRING 0 , 0 , \ This is called by THROW when n is nonzero \ The initial value (DEFAULT-UNWIND) performs the function of ABORT \ CATCH saves and restores the current target and substitutes its own version DEFER THROW-UNWIND ( k*x n -- i*x ) \ If n is nonzero, return control to the nearest CATCH on the return stack \ If there is no CATCH, perform the function of ABORT (clear data stack and QUIT) \ Absent CATCH, whether a message is displayed depends on the value of n: \ -1 (ABORT) no message \ -2 (FAIL) the string passed to THROW-STRING \ otherwise message is implementation-dependent : THROW-STRING ( k*x n c-addr u -- k*x | i*x n ) THROWN-STRING 2! ?DUP IF THROW-UNWIND THEN ; \ Same but without the string (default to zero-length) : THROW ( k*x n c-addr u -- k*x | i*x n ) 0 0 THROW-STRING ; \ By default, clear the data stack and QUIT without any message \ This behavior can be overridden with CATCH : ABORT ( i*x -- ) ( R: j*x -- ) EXCP-ABORT THROW ; \ Display a message and ABORT \ This behavior can be overridden with CATCH : FAIL ( c-addr u -- | ) EXCP-FAIL -ROT THROW-STRING ; \ If flag is non-zero, display a message and ABORT \ This behavior can be overridden with CATCH : ?FAIL ( flag c-addr u -- | ) ROT IF FAIL ELSE 2DROP THEN ; \ Names for the standard file descriptor numbers 0 CONSTANT STDIN 1 CONSTANT STDOUT 2 CONSTANT STDERR \ Write one character to FD 1 (stdout) : EMIT ( c -- "c" ) SP@ 2DUP C! STDOUT SWAP 1 SYS_WRITE SYSCALL3 2DROP ; \ Decrement the array size and increment the address by the same amount : DROP-PREFIX ( c-addr u1 u2 -- c-addr+u2 u1-u2 ) TUCK - -ROT + SWAP ; \ Write a character array to the given file descriptor \ Repeat write syscall until entire string is written \ Abandon output on any error other than EINTR : TYPE-FD ( c-addr u fd -- "ccc" ) >R BEGIN ?DUP WHILE 2DUP R@ -ROT SYS_WRITE SYSCALL3 DUP 0<= IF ERRNO_EINTR NEGATE <> IF 2DROP RDROP EXIT THEN ELSE DROP-PREFIX THEN REPEAT DROP RDROP ; \ Specializations for output to stdout and stderr : TYPE ( c-addr u -- "ccc" ) STDOUT TYPE-FD ; : TYPE-ERR ( c-addr u -- "ccc" ) STDERR TYPE-FD ; \ Get and set the current compilation word list : GET-CURRENT ( -- wid ) CURRENT @ ; : SET-CURRENT ( wid -- ) CURRENT ! ; ' CURRENT (HIDE) \ Get the execution token of the most recent word in the compilation word list \ If the word list is empty the result will be zero : LATEST ( -- xt | 0 ) GET-CURRENT @ ; \ Set the latest defined word as immediate \ Note that IMMEDIATE is itself an immediate word : IMMEDIATE ( -- ) LATEST >FLAGS DUP C@ F_IMMED OR SWAP C! ; IMMEDIATE \ Switch from compiling to interpreting, or vice-versa : [ ( -- ) IMMEDIATE FALSE STATE ! ; : ] ( -- ) IMMEDIATE TRUE STATE ! ; \ Convert from a double-cell signed number to a single-cell signed number : D>S ( d -- n ) DROP ; \ Separate the division and modulus operators : /MOD ( n1 n2 -- n1%n2 n1/n2 ) >R S>D R> FM/MOD D>S ; : / ( n1 n2 -- n1/n2 ) >R S>D R> FM/MOD D>S NIP ; : MOD ( n1 n2 -- n1%n2 ) >R S>D R> FM/MOD 2DROP ; \ Single-cell unsigned division and modulus : U/MOD ( u1 u2 -- u1%u2 u1/u2 ) 0 SWAP UM/MOD DROP ; : U/ ( u1 u2 -- u1/u2 ) 0 SWAP UM/MOD DROP NIP ; : UMOD ( u1 u2 -- u1%u2 ) 0 SWAP UM/MOD 2DROP ; \ Symmetric division and remainder : SM/REM ( d1 n1 -- d1%n1 d1/n1 ) DUP >R FM/MOD DUP IF OVER 0< IF 1+ SWAP R> - SWAP ELSE RDROP THEN THEN ; \ Signed minimum and maximum : MIN 2DUP > IF NIP ELSE DROP THEN ; : MAX 2DUP < IF NIP ELSE DROP THEN ; \ Unsigned minimum and maximum : UMIN 2DUP U> IF NIP ELSE DROP THEN ; : UMAX 2DUP U< IF NIP ELSE DROP THEN ; \ Return -1, 0, or 1 if n is respectively negative, zero, or positive : SIGNUM ( n -- -1 | 0 | 1 ) DUP IF 0< 2 * 1+ THEN ; \ Double-cell versions of standard numeric words : DABS ( d -- +d ) 2DUP D0< IF DNEGATE THEN ; : DMIN ( d1 d2 -- d1|d2 ) 2OVER 2OVER D> IF 2SWAP THEN 2DROP ; : DMAX ( d1 d2 -- d1|d2 ) 2OVER 2OVER D< IF 2SWAP THEN 2DROP ; : DUMIN ( ud1 ud2 -- ud1|ud2 ) 2OVER 2OVER DU> IF 2SWAP THEN 2DROP ; : DUMAX ( ud1 ud2 -- ud1|ud2 ) 2OVER 2OVER DU< IF 2SWAP THEN 2DROP ; : DSIGNUM ( d -- -1 | 0 | 1 ) 2DUP D0= IF DROP ELSE D0< 2 * 1+ THEN ; \ Define names for the whitespace characters 8 CONSTANT HT \ Horizontal Tab 10 CONSTANT LF \ Line Feed (newline) 11 CONSTANT VT \ Vertical Tab 12 CONSTANT FF \ Form Feed 13 CONSTANT CR \ Carriage Return 32 CONSTANT BL \ BLank (space) \ Test whether the given character is whitespace (HT, LF, VT, FF, CR, or BL) \ Note that HT, LF, VT, FF, and CR together form the range 9 ... 13 inclusive : SPACE? ( c -- flag ) DUP BL = IF DROP TRUE EXIT THEN 9 - [ 13 9 - ] LITERAL U<= ; \ Emit a blank (space) character : SPACE ( -- "" ) BL EMIT ; \ Emit a horizontal tab character : TAB ( -- "" ) HT EMIT ; \ Emit an implementation-dependent End-of-Line sequence \ Here this is just a LF (Unix convention) but it could be CR (Mac) or CR+LF (DOS) : EOL ( -- "" ) LF EMIT ; \ Terminate the program, successfully \ This will never return, even if the system call does : BYE ( -- ) BEGIN 0 SYS_EXIT SYSCALL1 DROP AGAIN ; 80 CONSTANT PNO-BUFFER-BYTES CREATE PNO-BUFFER PNO-BUFFER-BYTES ALLOT PNO-BUFFER PNO-BUFFER-BYTES + CONSTANT PNO-BUFFER-END CREATE PNO-POINTER PNO-BUFFER-END , : <# ( -- ) PNO-BUFFER-END PNO-POINTER ! ; : HOLD ( char -- ) PNO-POINTER 1 OVER -! @ C! ; : #> ( xd -- c-addr u ) 2DROP PNO-BUFFER-END PNO-POINTER @ TUCK - ; ' PNO-BUFFER (HIDE) ' PNO-BUFFER-END (HIDE) ' PNO-POINTER (HIDE) : SIGN ( n -- ) 0< IF [CHAR] - HOLD THEN ; : #B ( ud1 u -- ud2 ) UM/MOD ROT DUP 10 >= IF 10 - [CHAR] A + ELSE [CHAR] 0 + THEN HOLD ; : # ( ud1 -- ud2 ) 10 #B ; : #SB ( ud u -- ) >R BEGIN R@ #B 2DUP D0= UNTIL RDROP ; : #S ( ud -- ) 10 #SB ; \ Display the unsigned number at the top of the stack : DU. ( ud -- "" ) <# #S #> TYPE ; : U. ( u -- "" ) 0 DU. ; \ Display the signed number at the top of the stack : D. ( d -- "" ) DUP -ROT DABS <# #S ROT SIGN #> TYPE ; : . ( n -- "" ) S>D D. ; \ Display the content of the data stack : .DS ( -- "" ) SP@ S0 CELL - 2DUP > IF 2DROP EXIT THEN DUP @ . BEGIN CELL - 2DUP > IF 2DROP EXIT THEN DUP @ SPACE . AGAIN ; \ Display the content of the return stack : .RS ( -- "" ) \ Skip the topmost cell, which is the return address for the call to .RS RSP@ CELL + R0 CELL - 2DUP > IF 2DROP EXIT THEN DUP @ . BEGIN CELL - 2DUP > IF 2DROP EXIT THEN DUP @ SPACE . AGAIN ; \ Return the next address in the compilation/data area : HERE ( -- addr ) CP @ ; \ When growing the data area, round the end address up to a multiple of this size 65536 CONSTANT DATA-SEGMENT-ALIGNMENT \ Allocate n consecutive bytes from the end of the data area \ If necessary use the brk system call to grow the data area \ The value n can be negative to release the most recently allocated space : ALLOT ( n -- ) DUP 0< IF DUP C0 HERE - < IF EXCP-BAD-NUMERIC-ARGUMENT THROW THEN ELSE DUP HERE INVERT U> IF EXCP-DICTIONARY-OVERFLOW THROW THEN THEN HERE + DUP BRK @ U> IF [ DATA-SEGMENT-ALIGNMENT 1- ] LITERAL 2DUP + SWAP INVERT AND DUP SYS_BRK SYSCALL1 OVER <> IF EXCP-DICTIONARY-OVERFLOW THROW THEN BRK ! THEN CP ! ; \ Allocate one character from the data area and fill it with the value on the stack : C, HERE 1 ALLOT C! ; \ Allocate one cell from the data area and fill it with the value on the stack : , HERE CELL ALLOT ! ; \ Allocate two cells from the data area and fill them with the values on the stack : 2, HERE [ 2 CELLS ] LITERAL ALLOT 2! ; \ Allocate bytes from the data area (less than one cell) to cell-align the address : ALIGN HERE ALIGNED HERE - BEGIN ?DUP WHILE 0 C, 1- REPEAT ; \ Append the effect of the token on top of the stack to the current definition. \ Here it's equivalent to , since words are just arrays of execution tokens. \ Once COMPILE, has been defined we can use POSTPONE for non-immediate words. : COMPILE, ( xt -- ) , ; \ Append the LIT xt and the topmost word on the stack to the current definition. : LITERAL ( Compilation: x -- ) ( Runtime: -- x ) IMMEDIATE POSTPONE LIT , ; \ Append the LITSTRING xt and a copy of the string passed on the stack. : SLITERAL ( Compilation: c-addr1 u -- ) ( Runtime: -- c-addr2 u ) IMMEDIATE POSTPONE LITSTRING DUP C, HERE SWAP DUP ALLOT CMOVE ALIGN ; : 2LITERAL ( Compilation: x1 x2 -- ) ( Runtime: -- x1 x2 ) IMMEDIATE POSTPONE 2LIT 2, ; \ Append the execution semantics of the current definition to the current definition : RECURSE ( -- ) IMMEDIATE LATEST COMPILE, ; \ Unhide the current definition so it can refer to itself by name : RECURSIVE ( -- ) IMMEDIATE LATEST (UNHIDE) ; \ Our first control-flow primitive: IF {ELSE } THEN \ \ IF compiles an unresolved conditional branch. \ AHEAD compiles an unconditional branch (same effect as TRUE IF). \ Both AHEAD and IF leave the address of the unresolved offset on the stack. \ \ THEN consumes the offset address and resolves it to the next code address. \ \ ELSE inserts an unconditional branch (to THEN) and also resolves the \ previous forward reference (from IF). \ : IF ( C: -- orig ) ( Runtime S: flag -- ) IMMEDIATE POSTPONE 0BRANCH HERE 0 , ; : AHEAD ( C: -- orig ) IMMEDIATE POSTPONE BRANCH HERE 0 , ; : THEN ( C: orig -- ) IMMEDIATE HERE OVER - SWAP ! ; : ELSE ( C: orig1 -- orig2 ) IMMEDIATE POSTPONE AHEAD SWAP POSTPONE THEN ; \ Short-circuit logical operators \ Examples: \ AND-THEN THEN \ OR-ELSE THEN : AND-THEN ( C: -- orig ) ( Runtime S: flag -- FALSE | ) IMMEDIATE POSTPONE DUP POSTPONE IF POSTPONE DROP ; : OR-ELSE ( C: -- orig ) ( Runtime S: flag -- nonzero-flag | ) IMMEDIATE POSTPONE ?DUP POSTPONE 0= POSTPONE IF ; \ Unbounded loop: BEGIN AGAIN \ BEGIN places the offset of the start of on the stack. \ AGAIN creates a relative branch back to the start of . : BEGIN ( C: -- dest ) IMMEDIATE HERE ; : AGAIN ( C: dest -- ) IMMEDIATE POSTPONE BRANCH HERE - , ; \ Simple conditional loop: BEGIN UNTIL \ UNTIL consumes the top of the stack and branches back to BEGIN if the value was zero. : UNTIL ( C: dest -- ) ( Runtime S: flag -- ) IMMEDIATE POSTPONE 0BRANCH HERE - , ; \ Alternate conditional loop: BEGIN WHILE REPEAT : WHILE ( C: dest -- orig dest ) ( Runtime S: flag -- ) IMMEDIATE POSTPONE IF SWAP ; : REPEAT ( C: orig dest -- ) IMMEDIATE POSTPONE AGAIN POSTPONE THEN ; \ Sequential equality tests: \ CASE \ OF ENDOF \ OF ENDOF \ ... \ ENDCASE \ \ When equals execute , when equals execute , etc. \ During compilation the stack holds a list of forward references to the ENDCASE, \ with the number of references on top. Inside OF ... ENDOF there is additionally \ a forward reference to the ENDOF (as with IF ... THEN) above the ENDCASE counter. \ \ Begin by creating a counter for the number of unresolved ENDOF forward references : CASE ( C: -- 0 ) IMMEDIATE 0 ; \ At runtime compare the values on the top of the stack; branch to ENDOF if unequal \ Keep the first value for the next OF if unequal, otherwise consume both : OF ( C: orign ... orig1 n -- orign ... orig1 n orig-of ) IMMEDIATE POSTPONE OVER POSTPONE = POSTPONE IF POSTPONE DROP ; \ Create a forward branch to ENDCASE and resolve the one from OF : ENDOF ( C: orign ... orig1 n orig-of -- orign ... orig1 orig0 n+1 ) IMMEDIATE POSTPONE AHEAD -ROT POSTPONE THEN 1+ ; \ Drop the value in case none of the OF...ENDOF clauses matched \ Resolve all the forward branches from ENDOF to the location after ENDCASE : ENDCASE ( C: orign ... orig1 n -- ) IMMEDIATE POSTPONE DROP BEGIN ?DUP WHILE 1- SWAP POSTPONE THEN REPEAT ; \ Range loop: DO LOOP \ DO +LOOP : UNLOOP POSTPONE 2RDROP ; IMMEDIATE : DO POSTPONE 2>R POSTPONE BEGIN ; IMMEDIATE : (+LOOP) ( step limit index -- flag limit index' ) ROT + 2DUP = -ROT ; : +LOOP IMMEDIATE POSTPONE 2R> POSTPONE (+LOOP) POSTPONE 2>R POSTPONE UNTIL POSTPONE 2RDROP ; ' (+LOOP) (HIDE) : LOOP IMMEDIATE 1 POSTPONE LITERAL POSTPONE +LOOP ; \ Return the current index value from the innermost or next-innermost loop. \ The loops must be directly nested with no other changes to the return stack : I 1 RPICK ; : J 3 RPICK ; \ This function defines what happens when THROW is used outside of any CATCH : DEFAULT-UNWIND ( k*x n -- i*x ) CASE EXCP-ABORT OF ENDOF EXCP-FAIL OF THROWN-STRING 2@ TYPE-ERR "\n" TYPE-ERR ENDOF EXCP-DICTIONARY-OVERFLOW OF "Dictionary overflow\n" TYPE-ERR ENDOF EXCP-UNDEFINED-WORD OF "Undefined word: " TYPE-ERR THROWN-STRING 2@ TYPE-ERR "\n" TYPE-ERR ENDOF EXCP-FILE-IO OF "I/O error\n" TYPE-ERR ENDOF "Uncaught exception: " TYPE-ERR DUP DUP S>D DABS <# #S ROT SIGN #> TYPE-ERR EOL ENDCASE S0 SP! QUIT ; ' DEFAULT-UNWIND ' THROW-UNWIND DEFER! ' DEFAULT-UNWIND (HIDE) \ Copy the bootstrap SOURCE values into variables to allow changing the input buffer SOURCE CREATE INPUT-BUFFER-SIZE , CREATE INPUT-BUFFER , \ The SOURCE-ID is -1 for a string (EVALUATE) or 0 for user input \ Any other values are implementation-defined, for example FD numbers for file input CREATE CURRENT-SOURCE-ID -1 , \ Report the current input buffer region and SOURCE-ID : SOURCE ( -- c-addr u ) INPUT-BUFFER @ INPUT-BUFFER-SIZE @ ; : SOURCE-ID ( -- 0 | -1 | +n ) CURRENT-SOURCE-ID @ ; \ Save and restore the input source parameters (e.g. file position) \ This does not include the input buffer (SOURCE) or the SOURCE-ID : SAVE-INPUT ( -- xu ... x1 u ) >IN @ 1 ; : RESTORE-INPUT ( xu ... x1 u -- flag ) OVER >IN ! NDROP TRUE ; : PARSE-AREA ( -- c-addr u ) SOURCE >IN @ DROP-PREFIX ; : PARSE-EMPTY? ( -- flag ) SOURCE NIP >IN @ = ; : PEEK-CHAR ( -- c ) PARSE-AREA 0= "Unexpected end of input" ?FAIL C@ ; : SKIP-CHAR ( -- ) 1 >IN +! ; : NEXT-CHAR ( -- c ) PEEK-CHAR SKIP-CHAR ; : SKIPSPACE ( "" -- ) BEGIN PARSE-EMPTY? 0= AND-THEN PEEK-CHAR SPACE? THEN WHILE SKIP-CHAR REPEAT ; \ Comments; ignore all characters until the next EOL or ) character, respectively : \ ( "ccc" -- ) IMMEDIATE BEGIN NEXT-CHAR LF = UNTIL ; : ( ( "ccc" -- ) IMMEDIATE BEGIN NEXT-CHAR [CHAR] ) = UNTIL ; \ Skip whitespace; read and return the next word delimited by whitespace \ The delimiting whitespace character is left in the parse area : WORD ( "ccc" -- c-addr u ) SKIPSPACE PARSE-AREA DROP BEGIN PARSE-EMPTY? OR-ELSE PEEK-CHAR SPACE? THEN 0= WHILE SKIP-CHAR REPEAT PARSE-AREA DROP OVER - ; : CREATE ( "ccc" -- ) ALIGN HERE DODATA , 0 , LATEST , WORD DUP C, HERE SWAP DUP ALLOT CMOVE ALIGN HERE OVER >DFA ! GET-CURRENT ! ; \ Called when a word using DOES> is executed (not compiled) to set \ the runtime behavior of the most recently defined word : (DOES) ( dfa -- ) LATEST DODOES OVER >CFA ! >DFA ! ; \ Append " (DOES) EXIT" to the current definition \ where is the next address after the "EXIT" as a literal number \ Stay in compilation mode for the body of the DOES> clause : DOES> ( -- ) IMMEDIATE POSTPONE LIT HERE 0 , POSTPONE (DOES) POSTPONE EXIT HERE SWAP ! ; ' (DOES) (HIDE) : (MARK) TYPE ": " TYPE .DS EOL ; : MARK IMMEDIATE WORD POSTPONE SLITERAL POSTPONE (MARK) ; ' (MARK) (HIDE) \ Define a threaded FORTH word \ The word is initially hidden so it can refer to a prior word with the same name \ The definition is terminated with the ; immediate word, which unhides the name : : ( "ccc" -- ) CREATE LATEST DUP (HIDE) DOCOL SWAP >CFA ! POSTPONE ] ; \ End a definition by appending EXIT and leaving compilation mode \ Unhide the name if it isn't empty (e.g. from :NONAME) : ; ( -- ) IMMEDIATE POSTPONE EXIT POSTPONE [ LATEST DUP >NAME NIP IF (UNHIDE) ELSE DROP THEN ; \ Define a named constant \ Execution: ( value "name" -- ) \ name Execution: ( -- value ) \ \ By default CREATEd words have codeword DODATA which returns the value \ of the DFA field, so store the constant value there \ \ Alternate definition: \ : CONSTANT : POSTPONE LITERAL POSTPONE ; ; : CONSTANT CREATE LATEST >DFA ! ; \ Same for double-cell constants; no DFA trick this time : 2CONSTANT : POSTPONE 2LITERAL POSTPONE ; ; \ Define a single-cell named variable which returns its data address when executed. \ The initial value is formally undefined. This implementation sets it to zero. \ Execution: ( "name" -- ) \ name Execution: ( -- a-addr ) : VARIABLE CREATE 0 , ; \ Same for double-cell variables (two-variables) : 2VARIABLE CREATE [ 0 0 ] 2LITERAL 2, ; \ Define a single-cell named value which returns its data (not address) when executed. \ Named values defined with VALUE can be modified with TO. \ Execution: ( x "name" -- ) \ name execution: ( -- value ) : VALUE CREATE , DOLOAD LATEST >CFA ! ; \ Define an array of n single-cell elements \ name Runtime: ( n -- a-addr ) Return the address of the cell at index n : ARRAY ( n "name" -- ) CREATE CELLS ALLOT DOES> SWAP [ CELL ] LITERAL * + ; \ Define an array of n double-cell elements \ name Runtime: ( n -- a-addr ) Return the address of the double-cell at index n : 2ARRAY ( n "name" -- ) CREATE CELLS 2* ALLOT DOES> SWAP [ 2 CELLS ] LITERAL * + ; \ Define a threaded word which also displays its name and the data stack when called : (TRACE) >NAME TYPE SPACE .DS EOL ; : :TRACE : LATEST POSTPONE LITERAL POSTPONE (TRACE) ; ' (TRACE) (HIDE) \ Like : but the definition has no name \ The zero-length name still included in the word list so LATEST can refer to it \ The execution token is left on the stack for use after the definition ends : :NONAME ( -- ) ALIGN HERE DOCOL , HERE 3 CELLS+ , LATEST , F_HIDDEN C, DUP GET-CURRENT ! ALIGN POSTPONE ] ; \ Fetch and store the target of the deferred word denoted by deferred-xt \ Note that this DEFER! can turn any word into a deferred word : DEFER@ ( deferred-xt -- xt ) >DFA @ ; : DEFER! ( xt deferred-xt -- ) DODEFER OVER >CFA ! >DFA ! ; \ Create a deferred word; the target is stored in the DFA field \ The default target throws an exception — replace it using DEFER! or IS : (DEFERRED-UNINIT) "Uninitialized deferred word" FAIL ; : DEFER ( "ccc" -- ) CREATE ['] (DEFERRED-UNINIT) LATEST DEFER! ; ' (DEFERRED-UNINIT) (HIDE) \ Inline :NONAME-style function literals. "{ }" has the runtime effect \ of placing the execution token for an anonymous function with the runtime \ effect of on the top of the data stack. A branch is emitted to skip \ over the memory used for the nested definition. If RECURSE is used in \ it will create a recursive call to the anonymous inner function. In the word \ list, after the }, the inner definition is ordered before the outer definition. \ LATEST always refers to the innermost enclosing definition. \ \ Example: \ > : TIMES 0 DO DUP EXECUTE LOOP DROP ; \ > : GREETINGS { "Hello" TYPE EOL } 3 TIMES ; \ > GREETINGS \ Hello \ Hello \ Hello \ \ Compilation effect: ( C: -- outer-xt orig inner-xt state ) \ Interpreter effect: ( S: -- inner-xt state ) \ Enters compilation mode if not already compiling : { ( -- {outer-xt orig} inner-xt state ) IMMEDIATE STATE @ DUP IF LATEST DUP >LINK @ GET-CURRENT ! 0 OVER >LINK ! POSTPONE AHEAD ROT POSTPONE [ THEN :NONAME SWAP ; \ Leave compilation mode if STATE was 0 before { was executed \ Otherwise: \ Resolve the forward branch over the inner function \ Add outer-xt back to the word list after inner-xt \ Generate a literal for inner-xt : } ( {outer-xt orig} inner-xt state -- {inner-xt} ) IMMEDIATE POSTPONE ; IF ( S: outer-xt orig inner-xt ) \ Resolve the forward branch over the inner definition -ROT POSTPONE THEN \ Re-append the outer definition to the word list LATEST OVER >LINK ! GET-CURRENT ! \ Return to compilation mode (was ended by ; ) POSTPONE ] \ Compile inner-xt as a literal in the outer definition POSTPONE LITERAL \ ELSE ( nothing to do ) ( S: inner-xt ) THEN ; 4096 CONSTANT PAGESIZE 0 CONSTANT PROT_NONE 1 CONSTANT PROT_READ 2 CONSTANT PROT_WRITE 4 CONSTANT PROT_EXEC 2 CONSTANT MAP_PRIVATE 32 CONSTANT MAP_ANONYMOUS 32 CONSTANT BUDDY-MIN-BYTES 18 CONSTANT BUDDY-ORDERS : BUDDY-ORDER-BYTES ( order -- n-bytes ) BUDDY-MIN-BYTES SWAP LSHIFT ; BUDDY-ORDERS 1- BUDDY-ORDER-BYTES CONSTANT BUDDY-MAX-BYTES BUDDY-ORDERS ARRAY BUDDY-HEADS : INIT-BUDDY-HEADS ( -- ) BUDDY-ORDERS 0 DO 0 I BUDDY-HEADS ! LOOP ; INIT-BUDDY-HEADS : BUDDY-FREE ( order a-addr -- ) OVER BUDDY-ORDERS U>= "order out of bounds" ?FAIL 2DUP SWAP BUDDY-ORDER-BYTES 1- AND "address is not naturally aligned" ?FAIL >R DUP BUDDY-HEADS BEGIN ( S: order head-addr ) ( R: a-addr ) DUP @ DUP 0= IF \ Append to end of list DROP 0 R@ ! R> SWAP ! DROP EXIT THEN ( S: order head-addr block-addr ) ( R: freed-addr ) 2 PICK 1+ BUDDY-ORDERS < AND-THEN DUP 3 PICK BUDDY-ORDER-BYTES XOR R@ = AND-THEN \ Found the buddy on the free list; coalesce @ SWAP ! \ Pick the lower (naturally aligned) block address DUP BUDDY-ORDER-BYTES INVERT R> AND >R \ Repeat process with the next-higher order 1+ DUP BUDDY-HEADS TRUE THEN THEN 0= IF \ Insert before first item with address >= this addr DUP R@ U>= IF R@ ! R> SWAP ! DROP EXIT THEN \ Otherwise advance to next block NIP THEN AGAIN ; : BUDDY-ALLOCATE ( order -- a-addr ) RECURSIVE DUP BUDDY-ORDERS U>= "order out of bounds" ?FAIL DUP BUDDY-HEADS @ ?DUP IF DUP @ ROT BUDDY-HEADS ! EXIT THEN DUP 1+ BUDDY-ORDERS >= IF EXCP-HEAP-OVERFLOW THROW THEN DUP 1+ BUDDY-ALLOCATE SWAP 2DUP BUDDY-ORDER-BYTES + BUDDY-FREE ; : BUDDY-ORDER-FROM-BYTES ( u-bytes -- order ) DUP 0= OR-ELSE DUP DUP 1- AND 0<> THEN "buddy allocator block size is not a power of two" ?FAIL DUP BUDDY-MIN-BYTES - [ BUDDY-MAX-BYTES BUDDY-MIN-BYTES - ] LITERAL U> "buddy allocator block size out of bounds" ?FAIL BUDDY-MIN-BYTES / 0 SWAP BEGIN 2/ ?DUP 0<> WHILE SWAP 1+ SWAP REPEAT ; : BUDDY-COUNT BUDDY-HEADS @ 0 SWAP BEGIN ?DUP WHILE @ SWAP 1+ SWAP REPEAT ; VARIABLE TOTAL : BUDDY-STATS ( -- ) 0 TOTAL ! BUDDY-ORDERS 0 DO I BUDDY-COUNT ?DUP IF DUP I BUDDY-ORDER-BYTES * TOTAL +! . "x" TYPE I BUDDY-ORDER-BYTES . SPACE THEN LOOP "total " TYPE TOTAL @ . EOL ; ' TOTAL (HIDE) : NATURALLY-ALIGNED ( u1 -- u2 ) 1- DUP U2/ OR DUP 2 RSHIFT OR DUP 4 RSHIFT OR DUP 8 RSHIFT OR DUP 16 RSHIFT OR 1+ ; : ALIGNED-TO ( addr1 u -- addr2 ) NATURALLY-ALIGNED TUCK 1- + SWAP NEGATE AND ; : ALIGN-TO ( u -- ) HERE SWAP ALIGNED-TO HERE - ALLOT ; 0 CONSTANT NULL : KB 10 LSHIFT ; : MB 20 LSHIFT ; : ALLOCATE ( size -- a-addr ) CELL+ DUP BUDDY-MAX-BYTES U> IF MARK A BEGIN NULL OVER PROT_READ PROT_WRITE OR MAP_PRIVATE MAP_ANONYMOUS OR -1 0 SYS_MMAP2 SYSCALL6 DUP -4095 U>= WHILE NEGATE ERRNO_EINTR <> IF EXCP-HEAP-OVERFLOW THROW THEN REPEAT TUCK ! CELL+ EXIT THEN MARK B NATURALLY-ALIGNED DUP BUDDY-MIN-BYTES U< IF DROP BUDDY-MIN-BYTES THEN BUDDY-ORDER-FROM-BYTES DUP BUDDY-ALLOCATE SWAP OVER ! CELL+ ; : FREE ( a-addr -- ) CELL- DUP @ DUP BUDDY-ORDERS U< IF SWAP BUDDY-FREE EXIT THEN BEGIN 2DUP SYS_MUNMAP SYSCALL2 ?DUP 0= IF 2DROP EXIT THEN NEGATE ERRNO_EINTR <> "munmap failed" ?FAIL AGAIN ; \ Read the next word and return the first character : CHAR ( "name" -- c ) WORD DROP C@ ; \ Like CHAR but generates a literal at compile-time. : [CHAR] ( Compilation: "ccc" -- ) ( Runtime: -- c ) IMMEDIATE CHAR POSTPONE LITERAL ; \ Return -1, 0, or 1 if the left string is respectively \ less than, equal to, or greater than the right string : COMPARE ( c-addr1 u1 c-addr2 u2 -- -1 | 0 | 1 ) BEGIN ROT ?DUP IF ( S: a1 a2 u2 u1 ) SWAP ?DUP IF ( S: a1 a2 u1 u2 ) 2SWAP 2DUP C@ SWAP C@ - DUP IF >R 4 NDROP R> SIGNUM EXIT ELSE DROP ( S: u1 u2 a1 a2 ) 1+ SWAP 1+ 2SWAP 1- SWAP 1- ( S: a2' a1' u2' u1' ) SWAP -ROT 2SWAP ( S: a1' u1' a2' u2' ) THEN ELSE \ Return 1 since first string is longer DROP 2DROP 1 EXIT THEN ELSE \ If u2 is also zero return 0; else return -1 since first string is shorter -ROT 2DROP 0<> EXIT THEN AGAIN ; \ Field accessors for the search order linked list : ORDER>LINK ( a-addr1 -- a-addr2 ) ; : ORDER>WID ( a-addr1 -- a-addr2 ) CELL+ ; \ When the search order is changed previously allocated entries that are not \ currently needed will be retained on this linked list for later reuse. VARIABLE ORDER-FREELIST 0 ORDER-FREELIST ! \ Return the current search order : GET-ORDER ( -- widn ... wid1 n ) 0 CURRENT-ORDER @ \ Traverse the linked list, placing identifiers on the return stack and counting BEGIN ?DUP WHILE DUP ORDER>WID @ >R ORDER>LINK @ SWAP 1+ SWAP REPEAT ( S: n ) ( R: wid1 ... widn ) \ Shift the search order list from the return stack back to the data stack DUP BEGIN ?DUP WHILE 1- R> -ROT REPEAT ( S: widn ... wid1 n ) ; \ Set the current search order : SET-ORDER ( widn ... wid1 n | -n -- ) DUP 0< IF DROP FORTH-WORDLIST 1 THEN \ Move all the previous search order entries to the free list CURRENT-ORDER @ BEGIN ( S: widn ... wid1 n entry ) ?DUP WHILE DUP ORDER>LINK @ SWAP ORDER-FREELIST @ OVER ORDER>LINK ! ORDER-FREELIST ! REPEAT \ Build the new search order linked list CURRENT-ORDER SWAP BEGIN ( S: widn ... wid1 tail n ) ?DUP WHILE -ROT ( S: widn ... wid2 n wid1 tail ) ORDER-FREELIST @ ?DUP IF \ Remove an entry from the free list DUP ORDER>LINK @ ORDER-FREELIST ! ELSE \ Allocate a new entry from the data area ALIGN HERE 2 CELLS ALLOT THEN \ Update the tail pointer with the address of this entry DUP ROT ! \ Store the word list identifier TUCK ORDER>WID ! \ Leave the address of the link field under n-1 for the next iteration ORDER>LINK SWAP 1- REPEAT \ Terminate the linked list 0 SWAP ! ; \ Abstract away the internals of the search order implementation ' CURRENT-ORDER (HIDE) ' ORDER-FREELIST (HIDE) ' ORDER>WID (HIDE) ' ORDER>LINK (HIDE) \ Create a new wordlist \ In this implementation a word list is just a pointer to the most recent word : WORDLIST ( -- wid ) ALIGN HERE 0 , ; \ Make the first list in the search order the current compilation word list : DEFINITIONS ( -- ) GET-ORDER SWAP SET-CURRENT 1- NDROP ; \ Run a function for each word in the given wordlist \ xt Execution: ( i*x word-xt -- stop-flag j*x ) : WITH-WORDLIST ( i*x wid xt -- j*x ) >R @ BEGIN ?DUP WHILE >R 2R@ SWAP EXECUTE IF RDROP 0 ELSE R> >LINK @ THEN REPEAT RDROP ; \ Like WITH-WORDLIST but only runs the function for visible (non-hidden) words : WITH-VISIBLE ( x*i wid xt -- x*j ) SWAP { DUP HIDDEN? IF DROP FALSE ELSE SWAP DUP >R EXECUTE R> SWAP THEN } WITH-WORDLIST DROP ; \ Display the name of each visible word in the given word list : SHOW-WORDLIST ( wid -- ) { >NAME TYPE SPACE FALSE } WITH-VISIBLE EOL ; \ Return the number of visible words in the given word list : COUNT-WORDLIST ( wid -- n ) 0 SWAP { DROP 1+ FALSE } WITH-VISIBLE ; \ Look up a name in a word list and return the execution token and immediate flag \ If the name is not found return the name with the status value 0 \ If the name is an immediate word return the execution token with status -1 \ Otherwise return the execution token with status 1 : SEARCH-WORDLIST ( c-addr u wid -- c-addr u 0 | xt 1 | xt -1 ) 0 SWAP { >R DROP 2DUP R@ >NAME COMPARE 0= IF 2DROP R> DUP IMMEDIATE? 1 OR TRUE ELSE RDROP 0 FALSE THEN } WITH-VISIBLE ; \ Search-Order extension words : ALSO ( -- ) GET-ORDER >R DUP R> 1+ SET-ORDER ; : FORTH ( -- ) GET-ORDER NIP FORTH-WORDLIST SWAP SET-ORDER ; : ONLY ( -- ) -1 SET-ORDER ; : ORDER ( -- ) "ORDER:" TYPE GET-ORDER BEGIN ?DUP WHILE 1- SWAP SPACE . REPEAT EOL "CURRENT: " TYPE GET-CURRENT . EOL ; : PREVIOUS ( -- ) GET-ORDER NIP 1- SET-ORDER ; \ Apply SEARCH-WORDLIST to each word list in the current search order : FIND ( c-addr u -- c-addr u 0 | xt 1 | xt -1 ) 2>R GET-ORDER BEGIN ?DUP WHILE 1- SWAP 2R> ROT SEARCH-WORDLIST ?DUP IF 2>R NDROP 2R> EXIT THEN 2>R REPEAT 2R> 0 ; \ Same as FIND except that unknown words are reported and result in a call to THROW : FIND-OR-THROW ( c-addr u -- xt 1 | xt -1 ) FIND ?DUP 0= IF EXCP-UNDEFINED-WORD -ROT THROW-STRING THEN ; \ Read a word from the input (during runtime) and return its execution token \ Aborts if the word is not found in the current (runtime) search order list : ' ( "ccc" -- xt ) WORD FIND-OR-THROW DROP ; \ Like ' but generates a literal at compile-time. : ['] ( Compilation: "ccc" -- ) ( Runtime: -- xt ) IMMEDIATE ' POSTPONE LITERAL ; \ Read a word and append its compilation semantics to the current definition. : POSTPONE ( "name" -- ) IMMEDIATE WORD FIND-OR-THROW 0< IF COMPILE, ELSE DUP [ ' BOOTSTRAP? COMPILE, ] IF "POSTPONE used on non-immediate bootstrap word: " TYPE TYPE EOL [ ' BAILOUT COMPILE, ] THEN POSTPONE LITERAL POSTPONE COMPILE, THEN ; \ Shorthand for { ' DEFER! } or { ['] DEFER! } depending on STATE \ If used during compilation, capture the name immediately but set target at runtime : IS ( Compilation: "ccc" -- ) ( Runtime: xt -- ) ( Interpreted: xt "ccc" -- ) ' STATE @ IF POSTPONE LITERAL POSTPONE DEFER! ELSE DEFER! THEN ; IMMEDIATE \ When compiling, append code to store to the data field area of the named value. \ When interpreting, store to the data field directly. \ An ambiguous condition exists if the name was not created with VALUE. : TO ( x "name" -- ) IMMEDIATE ' >BODY STATE @ IF POSTPONE LITERAL POSTPONE ! ELSE ! THEN ; \ Hide the named word: HIDE : HIDE ( "ccc" -- ) ' (HIDE) ; \ Begin a new colon definition; hide & redirect the previous word \ with the same name to the new definition : :REPLACE ( "ccc" -- ) : LATEST DUP >NAME FIND-OR-THROW DROP DUP (HIDE) DEFER! ; \ The size of this buffer will determine the maximum line length 4096 CONSTANT TERMINAL-BUFFER-SIZE CREATE TERMINAL-BUFFER TERMINAL-BUFFER-SIZE ALLOT \ If we read more than one line then these will refer to the rest of the data CREATE TIB-LEFTOVER 0 , CREATE TIB-LEFTOVER-SIZE 0 , : REFILL ( -- flag ) SOURCE-ID 0< IF FALSE EXIT THEN \ Shift any leftover characters after the previous line to the start of the buffer TIB-LEFTOVER @ TERMINAL-BUFFER TIB-LEFTOVER-SIZE @ CMOVE \ Look for the linefeed character which marks the end of the first line TIB-LEFTOVER-SIZE @ 0 BEGIN \ If at the end with room in the buffer, read more from the file descriptor 2DUP = IF DUP TERMINAL-BUFFER-SIZE U< IF \ SOURCE-ID is the file descriptor number to read from SOURCE-ID OVER DUP TERMINAL-BUFFER + SWAP TERMINAL-BUFFER-SIZE SWAP - ( S: length idx src-id buff buff-size ) \ Repeat read if interrupted by a signal (returns -EINTR) BEGIN SYS_READ SYSCALL3 DUP ERRNO_EINTR NEGATE <> UNTIL \ Any other negative (error) return value is fatal DUP 0< IF EXCP-FILE-IO THROW THEN ( S: length idx u-read ) \ Add the amount of data read to the length; index is unchanged ROT + SWAP THEN THEN \ At this point if index equals length then buffer is full or read returned 0 \ Either way, we won't be reading any more into the buffer 2DUP = OR-ELSE \ Check if the next character is a linefeed 1+ DUP 1- TERMINAL-BUFFER + C@ LF = THEN UNTIL ( S: length idx ) \ idx is the next location after the linefeed, if found, or else equal to length \ Save the rest, if any, for the next REFILL DUP TERMINAL-BUFFER + TIB-LEFTOVER ! TUCK - TIB-LEFTOVER-SIZE ! ( S: idx ) \ The new input buffer is the first idx characters of the terminal buffer TERMINAL-BUFFER INPUT-BUFFER ! DUP INPUT-BUFFER-SIZE ! DUP IF 0 >IN ! THEN 0<> ; HIDE TIB-LEFTOVER HIDE TIB-LEFTOVER-SIZE HIDE TERMINAL-BUFFER : ESCAPED-CHAR ( "" | "c" -- c ) NEXT-CHAR DUP [CHAR] \ = IF DROP NEXT-CHAR CASE [CHAR] 0 OF 0 ENDOF [CHAR] a OF 7 ENDOF [CHAR] b OF 8 ENDOF [CHAR] t OF 9 ENDOF [CHAR] n OF 10 ENDOF [CHAR] v OF 11 ENDOF [CHAR] f OF 12 ENDOF [CHAR] r OF 13 ENDOF [CHAR] " OF [CHAR] " ENDOF [CHAR] ' OF [CHAR] ' ENDOF [CHAR] \ OF [CHAR] \ ENDOF "Unknown escape sequence" FAIL ENDCASE THEN ; \ Read a literal character string up to the next double-quote character \ Unlike WORD the string is stored in contiguous *allocated* data space \ The delimiting double-quote character is removed from the input buffer \ Double-quote and backslash characters can be escaped with a backslash : READSTRING ( "ccc" -- c-addr u ) HERE BEGIN PEEK-CHAR [CHAR] " <> WHILE ESCAPED-CHAR C, REPEAT SKIP-CHAR HERE OVER - ; : PARSENUMBER ( c-addr u -- n TRUE | c-addr u FALSE ) DUP 0= IF FALSE EXIT THEN 2>R 2R@ DROP C@ [CHAR] - = 0 ( S: neg-flag accum ) ( R: c-addr u ) OVER IF R@ 1 = IF 2DROP 2R> FALSE EXIT THEN THEN OVER 2R@ ROT IF 1- SWAP 1+ SWAP THEN ( S: neg-flag accum c-addr' u' ) ( R: c-addr u ) BEGIN ?DUP WHILE OVER -ROT 2>R C@ [CHAR] 0 - ( S: neg-flag accum digit ) ( R: c-addr u c-addr' u' ) DUP 9 U> IF DROP 2DROP 2RDROP 2R> FALSE EXIT THEN SWAP 10 * + 2R> ( S: neg-flag accum' c-addr' u' ) ( R: c-addr u ) 1- SWAP 1+ SWAP REPEAT ( S: neg-flag accum c-addr' ) ( R: c-addr u ) 2RDROP DROP SWAP IF NEGATE THEN TRUE ; \ Read a word, number, or string and either execute it or compile it \ The stack effect depends on the input and the current value of STATE : INTERPRET ( i*x "ccc" -- j*x ) BEGIN SKIPSPACE PARSE-EMPTY? 0= WHILE PEEK-CHAR [CHAR] " = IF SKIP-CHAR STATE @ IF POSTPONE LITSTRING HERE 0 C, READSTRING NIP SWAP C! ALIGN ELSE READSTRING THEN ELSE WORD PARSENUMBER IF STATE @ IF POSTPONE LITERAL THEN ELSE FIND-OR-THROW \ -1 => immediate word; execute regardless of STATE \ 1 => read STATE; compile if true, execute if false 0< OR-ELSE STATE @ 0= THEN IF EXECUTE ELSE COMPILE, THEN THEN THEN REPEAT ; DEFER SHOW-PROMPT { "> " TYPE } IS SHOW-PROMPT \ Redefine QUIT as a non-deferred word; update deferred references to point here \ Empty the return stack, make stdin the input source, and enter interpretation state :REPLACE QUIT ( -- ) R0 RSP! 0 CURRENT-SOURCE-ID ! FALSE STATE ! BEGIN SHOW-PROMPT REFILL 0= IF EOL BYE THEN INTERPRET STATE @ 0= IF "OK\n" TYPE THEN AGAIN ; : EVALUATE ( i*x c-addr u -- j*x ) SAVE-INPUT N>R SOURCE 2>R SOURCE-ID >R INPUT-BUFFER-SIZE ! INPUT-BUFFER ! 0 >IN ! -1 CURRENT-SOURCE-ID ! INTERPRET R> CURRENT-SOURCE-ID ! 2R> INPUT-BUFFER-SIZE ! INPUT-BUFFER ! NR> RESTORE-INPUT DROP ; 0 VALUE EXCEPTION-STACK \ Called when THROW is called inside of CATCH \ Restore the input source specification, stack point, and return stack pointer \ Push the error code from THROW onto the data stack \ Return to the code that called CATCH : CATCH-UNWIND ( k*x n -- i*x ) EXCEPTION-STACK RSP! R> TO EXCEPTION-STACK R> ['] THROW-UNWIND DEFER! R> CURRENT-SOURCE-ID ! 2R> INPUT-BUFFER-SIZE ! INPUT-BUFFER ! NR> RESTORE-INPUT DROP R> SWAP >R SP! R> ; \ Run xt while trapping calls to THROW, ABORT, FAIL, etc. \ On success has the effect of xt and also leaves the value 0 on top of the stack \ On failure the stacks and input source are reverted and the THROW code is pushed : CATCH ( i*x xt -- j*x 0 | i*x n ) \ Get original RSP to be saved on return stack later, after the exception frame RSP@ \ Don't include the xt or RSP when saving the stack pointer 2>R SP@ 2R> ROT >R \ Save the input source specification SAVE-INPUT N>R SOURCE 2>R SOURCE-ID >R \ We'll need these to revert the effect of CATCH, with or without THROW ['] THROW-UNWIND DEFER@ >R EXCEPTION-STACK >R \ Push the new exception stack frame RSP@ TO EXCEPTION-STACK \ Arrange for THROW to call CATCH-UNWIND instead of DEFAULT-UNWIND ['] CATCH-UNWIND IS THROW-UNWIND \ Save the original return stack so we can quickly free the exception frame ( RSP@ from start of CATCH ) >R \ Run the function; if THROW is called then EXECUTE won't return \ If it does return then push 0 to indicate success EXECUTE 0 R> R> R> \ Revert THROW-UNWIND and EXCEPTION-STACK using data from exception frame ['] THROW-UNWIND DEFER! TO EXCEPTION-STACK \ We don't need the rest so just reset the RSP to where it was on entering CATCH RSP! ; HIDE EXCEPTION-STACK HIDE CATCH-UNWIND HIDE THROW-UNWIND HIDE CURRENT-SOURCE-ID HIDE INPUT-BUFFER HIDE INPUT-BUFFER-SIZE HIDE (HIDE) HIDE (UNHIDE) HIDE ESCAPED-CHAR HIDE READSTRING HIDE PARSENUMBER \ Switch to the interpreter defined in this startup file { R0 RSP! BEGIN INTERPRET AGAIN } EXECUTE HIDE INTERPRET \ Remove the bootstrap word list from the search order HIDE BOOTSTRAP-WORDLIST FORTH-WORDLIST 1 SET-ORDER DEFINITIONS \ ***************************************************************************** \ Bootstrapping is complete \ From this point on we only execute threaded FORTH words defined in this file \ ***************************************************************************** \ Return the number of words on the data stack : DEPTH ( -- n ) SP@ S0 SWAP - CELL / ; \ Return TRUE if the given address is the execution token of a word in \ the current search order or compilation word list, or FALSE otherwise \ The word's name may be hidden or shadowed by another definition : WORD? ( addr -- flag ) >R GET-ORDER 1+ GET-CURRENT SWAP BEGIN ?DUP WHILE 1- SWAP R@ FALSE ROT ( S: widn ... wid1 n addr FALSE wid ) ( R: addr ) \ Inner function: ( addr FALSE xt -- addr FALSE FALSE | addr TRUE TRUE ) { NIP OVER = DUP } WITH-WORDLIST NIP IF RDROP NDROP TRUE EXIT THEN REPEAT RDROP FALSE ; \ Display the top of the stack as a word name if possible, or a number otherwise \ Words with zero-length names (e.g. from :NONAME) are displayed as numbers : .W ( addr -- "" | "" ) DUP WORD? IF \ Some kind of word; is the name zero-length (:NONAME)? DUP >NAME DUP IF \ Is the name hidden? 2 PICK HIDDEN? IF "⌀" TYPE ELSE \ Does FIND with the same name fail to return the same word? 2DUP FIND AND-THEN 3 PICK = ELSE NIP NIP THEN 0= IF "¤" TYPE THEN THEN TYPE DROP ELSE 2DROP "∷" TYPE U. THEN ELSE \ Not a word in the current search order or compilation word list . THEN ; \ Read one cell and increment : @(+) ( a-addr1 -- a-addr2 x ) DUP CELL+ SWAP @ ; \ Display a string in escaped (double-quoted) format, without the delimiters : TYPE-ESCAPED ( c-addr u -- "" ) 0 DO DUP 1+ SWAP C@ CASE 0 OF "\\0" TYPE ENDOF 7 OF "\\a" TYPE ENDOF 8 OF "\\b" TYPE ENDOF 9 OF "\\t" TYPE ENDOF 10 OF "\\n" TYPE ENDOF 11 OF "\\v" TYPE ENDOF 12 OF "\\f" TYPE ENDOF 13 OF "\\r" TYPE ENDOF [CHAR] " OF "\\\"" TYPE ENDOF \ escape sequence not needed in strings \ [CHAR] ' OF "\\\'" TYPE ENDOF [CHAR] \ OF "\\\\" TYPE ENDOF DUP 32 < OR-ELSE DUP 127 = THEN IF "⌷" TYPE ELSE DUP EMIT THEN ENDCASE LOOP DROP ; \ Recognize the pattern BRANCH a:{c-a} b:{word} {code…} c:LIT d:{b} \ This pattern is generated by the { … } inline :NONAME syntax : NONAME-LITERAL? ( a-addr -- flag ) @(+) ['] BRANCH = AND-THEN @(+) DUP 0> AND-THEN ( S: addr-b offset-c-a ) OVER CELL- + @(+) ['] LIT = AND-THEN ( S: addr-b addr-d ) @ OVER = AND-THEN DUP WORD? THEN ELSE NIP THEN ELSE NIP THEN THEN NIP ; \ Display the threaded code which starts at a-addr \ Continues until it encounters a reference to EXIT beyond any forward branches \ Numeric, string, and { … } literals are decoded, plus offsets for branches : UNTHREAD ( a-addr -- ) RECURSIVE DUP >R BEGIN @(+) DUP ['] EXIT = AND-THEN OVER R@ U> THEN IF 2DROP RDROP EXIT THEN CASE ['] LIT OF @(+) DUP WORD? IF "['] " TYPE .W ELSE . THEN SPACE ENDOF ['] 2LIT OF "[ " TYPE @(+) U. SPACE @(+) . " ] 2LITERAL " TYPE ENDOF ['] LITSTRING OF DUP 1+ SWAP C@ 2DUP "\"" TYPE TYPE-ESCAPED "\" " TYPE + ALIGNED ENDOF OVER CELL- NONAME-LITERAL? IF DROP DUP @ OVER + 2 CELLS+ DUP R> UMAX >R SWAP "{ " TYPE CELL+ >DFA @ UNTHREAD "} " TYPE ELSE DUP ['] BRANCH = OR-ELSE DUP ['] 0BRANCH = THEN IF >NAME TYPE SPACE @(+) DUP "{" TYPE DUP 0> IF "+" TYPE THEN . "} " TYPE OVER CELL- + R> UMAX >R ELSE DUP WORD? AND-THEN DUP IMMEDIATE? THEN IF "POSTPONE " TYPE THEN .W SPACE THEN THEN DUP \ placeholder to be dropped by ENDCASE since we consumed the xt ENDCASE AGAIN ; HIDE NONAME-LITERAL? : SEE ( "name" -- ) ' DUP >CFA @ CASE DOCOL OF ": " TYPE DUP >NAME TYPE " " TYPE DUP IMMEDIATE? IF "IMMEDIATE " TYPE THEN >DFA @ UNTHREAD ";\n" TYPE ENDOF DODEFER OF "DEFER " TYPE DUP >NAME TYPE EOL DUP >DFA @ DUP WORD? IF "' " TYPE .W ELSE U. THEN " IS " TYPE >NAME TYPE EOL ENDOF DODATA OF DUP EXECUTE . " CONSTANT " TYPE >NAME TYPE EOL ENDOF DOLOAD OF DUP EXECUTE . " VALUE " TYPE >NAME TYPE EOL ENDOF DODOES OF "CREATE " TYPE DUP >NAME TYPE " … DOES> " TYPE >DFA @ UNTHREAD ";\n" TYPE ENDOF \ Anything else can be assumed to be implemented in assembly SWAP "CREATE " TYPE >NAME TYPE " … ;CODE … END-CODE\n" TYPE ENDCASE ; HIDE UNTHREAD : BANNER "JumpForth version " TYPE VERSION . ", by Jesse McDonald\n" TYPE ; BANNER QUIT