\ Get and set the current compilation word list : GET-CURRENT ( -- wid ) CURRENT @ ; : SET-CURRENT ( wid -- ) CURRENT ! ; \ 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 @ ; \ 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 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 ; \ 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 ; \ Write a character array to stdout \ Repeat write syscall until entire string is written \ Abandon output on any error other than EINTR : TYPE ( c-addr u -- "ccc" ) BEGIN ?DUP WHILE 2DUP STDOUT -ROT SYS_WRITE SYSCALL3 DUP 0<= IF ERRNO_EINTR NEGATE <> IF 2DROP EXIT THEN ELSE \ Decrement the array size and increment the \ address by the number of bytes written TUCK - -ROT + SWAP THEN REPEAT DROP ; \ 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 ; \ Terminate the program with a fatal error (SIGABRT) : FATAL-ERROR ( -- ) BEGIN \ A full version would also unmask SIGABRT and restore the default handler \ For now we assume the mask and handler are already at default settings SYS_GETPID SYSCALL0 SYS_GETTID SYSCALL0 SIGABRT SYS_TGKILL SYSCALL3 DROP AGAIN ; \ Return the next address in the compilation/data area : HERE ( -- addr ) CP @ ; : ALLOT-BOUNDS "Allocation out of bounds!" TYPE EOL FATAL-ERROR ; : ALLOT-OOM "Out of memory!" TYPE EOL FATAL-ERROR ; \ When growing the data area, round the end address up to a multiple of this size 65536 CONSTANT DATA-SEGMENT-ALIGNMENT : ALLOT ( n -- ) DUP 0< IF DUP C0 HERE - < IF ALLOT-BOUNDS THEN ELSE DUP HERE INVERT U> IF ALLOT-BOUNDS THEN THEN HERE + DUP BRK @ U> IF [ DATA-SEGMENT-ALIGNMENT 1- ] LITERAL 2DUP + SWAP INVERT AND DUP SYS_BRK SYSCALL1 OVER <> IF ALLOT-OOM THEN BRK ! THEN CP ! ; : , HERE CELL ALLOT ! ; : C, HERE 1 ALLOT C! ; : 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 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 >FLAGS DUP C@ F_HIDDEN INVERT AND SWAP C! ; \ 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 ; \ 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 ; \ 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 POSTPONE 2R> POSTPONE (+LOOP) POSTPONE 2>R POSTPONE UNTIL POSTPONE 2RDROP ; IMMEDIATE : LOOP 1 POSTPONE LITERAL POSTPONE +LOOP ; IMMEDIATE \ 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 ; \ 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 0 DO POSTPONE THEN LOOP ; \ If the input buffer is empty, refill it from stdin \ Return the next character from the input buffer : KEY CURRKEY @ DUP BUFFTOP @ >= IF DROP BUFFER 0 OVER BUFFER_SIZE SYS_READ SYSCALL3 DUP 0<= IF 2DROP BYE THEN OVER + BUFFTOP ! THEN DUP 1+ CURRKEY ! C@ ; \ Puts the most recently read key back in the input buffer \ CAUTION: Can only safely be used ONCE after each call to KEY! \ This takes advantage of the fact that the key is still in the buffer : PUTBACK CURRKEY @ 1- CURRKEY ! ; : SKIPSPACE BEGIN KEY SPACE? INVERT UNTIL PUTBACK ; \ Skip whitespace; read and return the next word delimited by whitespace \ The word is stored in contiguous but *unallocated* data space \ The delimiting whitespace character is left in the input buffer : WORD ( "ccc" -- c-addr u ) SKIPSPACE HERE BEGIN KEY DUP SPACE? 0= WHILE C, REPEAT DROP PUTBACK HERE OVER - OVER CP ! ; : CREATE ( "ccc" -- ) ALIGN HERE DODATA , 0 , LATEST , HERE 0 C, WORD NIP DUP ALLOT ALIGN SWAP C! 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 ! ; \ 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 , DOES> @ ; \ 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 >FLAGS DUP C@ F_HIDDEN OR SWAP C! DOCOL SWAP >CFA ! POSTPONE ] ; \ 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 ] LITERAL + , LATEST , F_HIDDEN C, ALIGN DUP GET-CURRENT ! POSTPONE ] ; \ End a definition by appending EXIT, leaving compilation mode, and unhiding the name \ As an optimization, zero-length names (from :NONAME) are left hidden : ; ( -- ) IMMEDIATE POSTPONE EXIT POSTPONE [ LATEST >FLAGS DUP C@ DUP F_LENMASK AND IF \ Length is not zero; clear the F_HIDDEN flag F_HIDDEN INVERT AND SWAP C! ELSE 2DROP THEN ; \ Create a deferred word \ At present a deferred word is just an ordinary threaded function \ DEFER! and IS update which word is called by overwriting the threaded code \ The explicit EXIT is just a placeholder to be overwritten by DEFER! or IS \ A future version might use a special codeword with the target in the DFA field : DEFER ( "ccc" -- ) : POSTPONE EXIT POSTPONE ; ; \ Fetch and store the target of the deferred word denoted by deferred-xt : DEFER@ ( deferred-xt -- xt ) >DFA @ @ ; : DEFER! ( xt deferred-xt -- ) >DFA @ ! ; \ 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, which is removed from the \ current word list upon completion. If RECURSE is used in it will \ create a recursive call to the anonymous inner function. \ \ Example: \ OK> : TIMES 0 DO DUP EXECUTE LOOP DROP ; \ OK> : GREETINGS { "Hello" TYPE EOL } 3 TIMES ; \ OK> GREETINGS \ Hello \ Hello \ Hello \ \ Compilation effect: ( C: -- latest orig state ) \ Interpreter effect: ( S: -- latest state ) \ Enters compilation mode if not already compiling : { ( -- latest {orig} state ) IMMEDIATE LATEST STATE @ DUP IF POSTPONE AHEAD SWAP POSTPONE [ THEN :NONAME ; \ Resolve the forward branch over the inner function \ Leave compilation mode if STATE was 0 before { was executed : } ( C: latest {orig} state -- ) IMMEDIATE POSTPONE ; SWAP IF -ROT POSTPONE THEN GET-CURRENT ! POSTPONE LITERAL POSTPONE ] ELSE SWAP GET-CURRENT ! 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 ; \ 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. ; \ 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 ! ; \ 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 ; \ ABORT needs to be deferred so that it can refer to QUIT and INTERPRET \ The initial target of FATAL-ERROR terminates the program with SIGABRT DEFER ABORT ( -- ) ' FATAL-ERROR ' ABORT DEFER! \ Same as FIND except that unknown words are reported and result in a call to ABORT : FIND-OR-ABORT ( c-addr u -- xt 1 | xt -1 ) FIND ?DUP IF EXIT THEN "UNKNOWN WORD: " TYPE TYPE EOL ABORT ; \ 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-ABORT 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-ABORT 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" -- ) ' >FLAGS DUP C@ F_HIDDEN OR SWAP C! ; \ Hide internal utility functions HIDE ALLOT-BOUNDS HIDE ALLOT-OOM HIDE (DOES) \ Abstract away the internals of the search order implementation HIDE CURRENT HIDE CURRENT-ORDER HIDE ORDER-FREELIST HIDE ORDER>WID HIDE ORDER>LINK \ 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 KEY DUP [CHAR] \ = IF DROP KEY TRUE ELSE DUP [CHAR] " <> THEN WHILE C, REPEAT DROP 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 ) SKIPSPACE KEY [CHAR] " = IF STATE @ IF POSTPONE LITSTRING HERE 0 C, READSTRING NIP SWAP C! ALIGN ELSE READSTRING THEN ELSE PUTBACK 64 ALLOT WORD -64 ALLOT PARSENUMBER IF STATE @ IF POSTPONE LITERAL THEN ELSE FIND-OR-ABORT \ -1 => immediate word; execute regardless of STATE \ 1 => read STATE; compile if true, execute if false 0< IF EXECUTE EXIT THEN STATE @ IF COMPILE, EXIT THEN EXECUTE THEN THEN ; \ Comments; ignore all characters until the next EOL or ) character, respectively : \ ( "ccc" -- ) IMMEDIATE BEGIN KEY LF = UNTIL ; : ( ( "ccc" -- ) IMMEDIATE BEGIN KEY [CHAR] ) = UNTIL ; \ Empty the return stack and enter interpretation state : QUIT ( -- ) R0 RSP! FALSE STATE ! BEGIN INTERPRET AGAIN ; \ Redefine ABORT as a non-deferred word; update deferred references to point here \ Empty the data stack and then perform the function of QUIT without any message ' ABORT HIDE ABORT : ABORT ( -- ) S0 SP! QUIT ; ' ABORT SWAP DEFER! \ Remove the bootstrap word list from the search order \ Switch to the interpreter defined in this startup file FORTH-WORDLIST 1 SET-ORDER DEFINITIONS QUIT \ ***************************************************************************** \ 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 / ; \ 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 ; \ Attempt to locate a visible word whose execution token matches the given address \ If found return the word name and TRUE; otherwise just return FALSE : LOOKUP ( addr -- c-addr u TRUE | FALSE ) >R GET-ORDER BEGIN ?DUP WHILE 1- SWAP R@ FALSE ROT ( S: widn ... wid1 n addr FALSE wid ) ( R: addr ) { ( addr FALSE xt -- addr FALSE FALSE | c-addr u TRUE TRUE ) NIP OVER = IF >NAME TRUE ELSE FALSE THEN DUP } WITH-VISIBLE ?DUP IF RDROP EXIT THEN DROP 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 LOOKUP IF TYPE DROP ELSE . THEN ; \ Display the first `u` words in the body of the given execution token with .W : UNTHREAD ( xt u -- ) SWAP >DFA @ SWAP BEGIN ?DUP WHILE SWAP DUP @ .W SPACE CELL + SWAP 1- REPEAT DROP ; : BANNER "JumpForth version " TYPE VERSION . ", by Jesse McDonald" TYPE EOL ; BANNER