\ 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! \ 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 ?FAIL \ otherwise message is implementation-dependent : THROW ( k*x n -- k*x | i*x n ) ?DUP IF THROW-UNWIND THEN ; \ By default, clear the data stack and QUIT without any message \ This behavior can be overridden with CATCH : ABORT ( i*x -- ) ( R: j*x -- ) -1 THROW ; \ 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 , \ If flag is non-zero, display a message and ABORT \ This behavior can be overridden with CATCH : ?FAIL ( flag c-addr u -- | ) ROT IF THROWN-STRING 2! -2 THROW 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 ! ; \ Separate the division and modulus operators : /MOD ( n1 n2 -- n1%n2 n1/n2 ) >R S>D R> SM/REM ; : / ( n1 n2 -- n1/n2 ) >R S>D R> SM/REM NIP ; : MOD ( n1 n2 -- n1%n2 ) >R S>D R> SM/REM DROP ; \ Single-cell unsigned division and modulus : U/MOD ( u1 u2 -- u1%u2 u1/u2 ) 0 SWAP UM/MOD ; : U/ ( u1 u2 -- u1/u2 ) 0 SWAP UM/MOD NIP ; : UMOD ( u1 u2 -- u1%u2 ) 0 SWAP UM/MOD DROP ; \ Flooring division and modulus (n1%n2 >= 0) : FM/MOD ( d1 n1 -- d1%n1 d1/n1 ) DUP >R SM/REM OVER 0< IF 1- SWAP R> + SWAP ELSE RDROP THEN ; : MIN 2DUP > IF NIP ELSE DROP THEN ; : MAX 2DUP < IF NIP ELSE DROP 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 ; \ Display the unsigned number at the top of the stack : U. ( u -- "" ) \ Start with the highest place-value on the left 1000000000 \ Skip place-values that would be larger than the input BEGIN 2DUP U< OVER 1 U> AND WHILE 10 U/ REPEAT \ Emit the remaining digits down to the units' place BEGIN TUCK U/MOD [CHAR] 0 + EMIT SWAP DUP 1 U<= IF 2DROP EXIT THEN 10 U/ AGAIN ; \ Display the signed number at the top of the stack : . ( n -- "" ) DUP 0< IF [CHAR] - EMIT NEGATE THEN U. ; \ 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 -24 THROW THEN ELSE DUP HERE INVERT U> IF -8 THROW THEN THEN HERE + DUP BRK @ U> IF [ DATA-SEGMENT-ALIGNMENT 1- ] LITERAL 2DUP + SWAP INVERT AND DUP SYS_BRK SYSCALL1 OVER <> IF -8 THROW THEN BRK ! THEN CP ! ; \ Allocate one cell from the data area and fill it with the value on the stack : , HERE CELL ALLOT ! ; \ Allocate one character from the data area and fill it with the value on the stack : C, HERE 1 ALLOT C! ; \ 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 ; \ 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 -1 OF ENDOF -2 OF THROWN-STRING 2@ TYPE-ERR "\n" TYPE-ERR ENDOF -8 OF "Out of memory\n" TYPE-ERR ENDOF -13 OF "Undefined word: " TYPE-ERR THROWN-STRING 2@ TYPE-ERR "\n" TYPE-ERR ENDOF -37 OF "I/O error\n" TYPE-ERR ENDOF "Uncaught exception\n" TYPE-ERR 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) \ 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 ! ; \ 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 , ; \ 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 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 ] ; \ 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 ] ; \ 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 ; \ 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) TRUE "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: \ OK> : TIMES 0 DO DUP EXECUTE LOOP DROP ; \ OK> : GREETINGS { "Hello" TYPE EOL } 3 TIMES ; \ OK> 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 ; \ 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 n is respectively negative, zero, or positive : SIGNUM ( n -- -1 | 0 | 1 ) DUP IF 0< 2 * 1+ THEN ; \ 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 THROWN-STRING 2! -13 THROW 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 -37 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 TRUE "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 ; \ 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 REFILL 0= IF EOL BYE THEN INTERPRET STATE @ 0= IF "OK> " 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 @ ; : 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 ; : UNTHREAD ( a-addr -- ) DUP >R BEGIN @(+) DUP ['] EXIT = AND-THEN OVER R@ U> THEN IF 2DROP RDROP EXIT THEN DUP ['] LIT = IF DROP @(+) DUP WORD? IF "['] " TYPE .W ELSE . THEN SPACE ELSE DUP ['] LITSTRING = IF DROP DUP C@ OVER 1+ OVER "\"" TYPE TYPE-ESCAPED "\"" TYPE SPACE + ALIGNED ELSE DUP ['] BRANCH = OR-ELSE DUP ['] 0BRANCH = THEN IF >NAME TYPE SPACE @(+) DUP "{" TYPE . "}" TYPE SPACE OVER + R> MAX >R ELSE DUP WORD? AND-THEN DUP IMMEDIATE? THEN IF "POSTPONE " TYPE THEN .W SPACE THEN THEN THEN AGAIN ; : SEE ( "name" -- ) ' DUP >CFA @ CASE DOCOL OF ": " TYPE DUP >NAME TYPE DUP IMMEDIATE? IF " IMMEDIATE" TYPE THEN " " TYPE >DFA @ UNTHREAD ";\n" TYPE ENDOF DODEFER OF "DEFER " TYPE DUP >NAME TYPE " ' " TYPE DUP >DFA @ .W " IS " >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 " " 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\nOK> " TYPE ; BANNER QUIT