diff --git a/startup.4th b/startup.4th index 1b47601..19d2fe7 100644 --- a/startup.4th +++ b/startup.4th @@ -31,9 +31,13 @@ : (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! +\ 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 ! ; + +\ Decrement the array size and increment the address by the same amount +: /STRING ( c-addr u1 u2 -- c-addr+u2 u1-u2 ) TUCK - -ROT + SWAP ; \ Standard (ANS FORTH) THROW code assignments (-255 ... -1) -1 CONSTANT EXCP-ABORT @@ -99,9 +103,6 @@ DEFER THROW-UNWIND ( k*x n -- i*x ) : 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 -: /STRING ( 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 @@ -133,6 +134,7 @@ DEFER THROW-UNWIND ( k*x n -- i*x ) \ 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 @ ; +: LATEST! ( xt -- ) GET-CURRENT ! ; \ Set the latest defined word as immediate \ Note that IMMEDIATE is itself an immediate word @@ -213,6 +215,7 @@ DEFER THROW-UNWIND ( k*x n -- i*x ) \ With 32-bit cells, a double-cell number has 64 bits \ Space is reserved for binary output with a leading minus sign and a trailing space \ The minimum pictured numeric output buffer size is thus 66 bytes +\ The PNO buffer may be used for transient data like interpreted string literals 80 CONSTANT PNO-BUFFER-BYTES CREATE PNO-BUFFER PNO-BUFFER-BYTES ALLOT @@ -223,8 +226,6 @@ CREATE PNO-POINTER PNO-BUFFER-END , : 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 ; @@ -285,13 +286,14 @@ CREATE DISPLAY-ITEM-LIMIT 6 , THEN HERE + DUP BRK @ U> IF [ DATA-SEGMENT-ALIGNMENT 1- ] LITERAL 2DUP + SWAP INVERT AND - DUP - SYS_BRK SYSCALL1 + BEGIN + DUP SYS_BRK SYSCALL1 + DUP [ ERRNO_EINTR NEGATE ] LITERAL <> DUP IF NIP THEN + UNTIL OVER <> IF EXCP-DICTIONARY-OVERFLOW THROW THEN BRK ! THEN - CP ! -; + CP ! ; \ Allocate one character from the data area and fill it with the value on the stack : C, HERE 1 ALLOT C! ; @@ -474,6 +476,26 @@ CREATE LEAVE-ORIG 0 , LOOP 2DROP R> SIGNUM ; +\ Copy the bootstrap SOURCE values into variables to allow changing the input buffer +CREATE INPUT-BUFFER SOURCE 2, + +\ 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 2@ ; +: 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 ; + +\ QUIT needs to be deferred so that it can refer to INTERPRET +DEFER QUIT ( -- ) +' BAILOUT ' QUIT DEFER! + \ This function defines what happens when THROW is used outside of any CATCH : DEFAULT-UNWIND ( k*x n -- i*x ) CASE @@ -498,21 +520,55 @@ CREATE LEAVE-ORIG 0 , ' DEFAULT-UNWIND ' THROW-UNWIND DEFER! ' DEFAULT-UNWIND (HIDE) -\ Copy the bootstrap SOURCE values into variables to allow changing the input buffer -CREATE INPUT-BUFFER SOURCE 2, +CREATE EXCEPTION-STACK 0 , -\ 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 , +\ 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> EXCEPTION-STACK ! + R> ['] THROW-UNWIND DEFER! + R> CURRENT-SOURCE-ID ! + 2R> INPUT-BUFFER 2! + NR> RESTORE-INPUT DROP + R> SWAP >R SP! R> ; -\ Report the current input buffer region and SOURCE-ID -: SOURCE ( -- c-addr u ) INPUT-BUFFER 2@ ; -: SOURCE-ID ( -- 0 | -1 | +n ) CURRENT-SOURCE-ID @ ; +\ 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@ EXCEPTION-STACK ! + \ Arrange for THROW to call CATCH-UNWIND instead of DEFAULT-UNWIND + ['] CATCH-UNWIND ['] THROW-UNWIND DEFER! + \ 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! + EXCEPTION-STACK ! + \ We don't need the rest so just reset the RSP to where it was on entering CATCH + RSP! ; -\ 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 ; +' EXCEPTION-STACK (HIDE) +' CATCH-UNWIND (HIDE) +' THROW-UNWIND (HIDE) : PARSE-AREA ( -- c-addr u ) SOURCE >IN @ /STRING ; @@ -525,63 +581,6 @@ CREATE CURRENT-SOURCE-ID -1 , : NEXT-CHAR ( -- c ) PEEK-CHAR SKIP-CHAR ; -\ 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 , - -\ Attempt to replace the parse area with the next line from the current source -\ Return TRUE if the parse area was refilled, or FALSE otherwise -\ REFILL always fails if the current source is a string (from EVALUATE) -: 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 OVER INPUT-BUFFER 2! - DUP IF 0 >IN ! THEN - 0<> ; - -' TIB-LEFTOVER (HIDE) -' TIB-LEFTOVER-SIZE (HIDE) -' TERMINAL-BUFFER (HIDE) - : SKIP-SPACES ( "" -- ) BEGIN PARSE-EMPTY? OR-ELSE PEEK-CHAR SPACE? DUP IF SKIP-CHAR THEN 0= THEN UNTIL ; @@ -589,6 +588,10 @@ CREATE TIB-LEFTOVER-SIZE 0 , : \ ( "ccc" -- ) IMMEDIATE BEGIN NEXT-CHAR LF = UNTIL ; : ( ( "ccc" -- ) IMMEDIATE BEGIN NEXT-CHAR [CHAR] ) = UNTIL ; +\ Placeholder to be replaced before switching to terminal input +DEFER REFILL +' FALSE ' REFILL DEFER! + \ 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 ) @@ -611,7 +614,7 @@ CREATE TIB-LEFTOVER-SIZE 0 , DODATA , 0 , LATEST , WORD DUP C, HERE SWAP DUP ALLOT CMOVE ALIGN HERE OVER >DFA ! - GET-CURRENT ! ; + LATEST! ; \ Called when a word using DOES> is executed (not compiled) to set \ the runtime behavior of the most recently defined word @@ -690,12 +693,7 @@ CREATE TIB-LEFTOVER-SIZE 0 , \ 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 ! ; + DUP LATEST! ALIGN POSTPONE ] ; \ Create a deferred word; the target is stored in the DFA field \ The default target throws an exception — replace it using DEFER! or IS @@ -727,7 +725,7 @@ CREATE TIB-LEFTOVER-SIZE 0 , STATE @ DUP IF LATEST - DUP >LINK @ GET-CURRENT ! + DUP >LINK @ LATEST! 0 OVER >LINK ! POSTPONE AHEAD ROT @@ -747,7 +745,7 @@ CREATE TIB-LEFTOVER-SIZE 0 , \ 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 ! + LATEST OVER >LINK ! LATEST! \ Return to compilation mode (was ended by ; ) POSTPONE ] \ Compile inner-xt as a literal in the outer definition @@ -798,232 +796,6 @@ CREATE TIB-LEFTOVER-SIZE 0 , : [CHAR] ( Compilation: "ccc" -- ) ( Runtime: -- c ) IMMEDIATE CHAR POSTPONE LITERAL ; -\ 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) ; - -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> IS THROW-UNWIND - R> CURRENT-SOURCE-ID ! - 2R> INPUT-BUFFER 2! - 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 - 32 CONSTANT BUDDY-MIN-BYTES 18 CONSTANT BUDDY-ORDERS : BUDDY-ORDER-BYTES ( order -- n-bytes ) BUDDY-MIN-BYTES SWAP LSHIFT ; @@ -1090,7 +862,7 @@ VARIABLE TOTAL . "x" TYPE I BUDDY-ORDER-BYTES . SPACE THEN LOOP "total " TYPE TOTAL @ . EOL ; -HIDE TOTAL +' TOTAL (HIDE) 0 CONSTANT NULL @@ -1170,11 +942,226 @@ HIDE TOTAL ( S: obj-addr1 obj-addr2 copy-size R: obj-addr1 obj-addr2 ) CMOVE R> R> FREE ; +\ Field accessors for the search order linked list +: ORDER>LINK ( a-addr1 -- a-addr2 ) ; +: ORDER>WID ( a-addr1 -- a-addr2 ) CELL+ ; +2 CELLS CONSTANT ORDER-ENTRY-BYTES + +VARIABLE CURRENT-ORDER +0 CURRENT-ORDER ! + +\ 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 + \ Free the previous search order linked list + 0 CURRENT-ORDER XCHG BEGIN ?DUP WHILE DUP ORDER>LINK @ SWAP FREE REPEAT + \ Build the new search order linked list + CURRENT-ORDER SWAP + BEGIN + ( S: widn ... wid1 tail n ) + ?DUP + WHILE + 1- -ROT + ( S: widn ... wid1 n wid0 tail ) + ORDER-ENTRY-BYTES ALLOCATE + DUP ROT ! \ Update the tail pointer with the address of this entry + TUCK ORDER>WID ! \ Store the word list identifier + ORDER>LINK SWAP \ Leave link field address under n for next iteration + REPEAT + \ Terminate the linked list + 0 SWAP ! ; + +\ Prepare the initial search order +FORTH-WORDLIST 1 SET-ORDER + +\ Abstract away the internals of the search order implementation +' CURRENT-ORDER (HIDE) +' ORDER-ENTRY-BYTES (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 0 ?DO SPACE U. LOOP EOL + "CURRENT: " TYPE GET-CURRENT U. EOL ; +: PREVIOUS ( -- ) GET-ORDER ?DUP IF NIP 1- SET-ORDER THEN ; + +\ Add the word list wid as the first word list in the search order +: PUSH-ORDER ( wid -- ) >R GET-ORDER R> SWAP 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 + 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-BYTES +TERMINAL-BUFFER-BYTES ALLOCATE CONSTANT TERMINAL-BUFFER + +\ If we read more than one line then these will refer to the rest of the data +CREATE TIB-LEFTOVER 0 , +CREATE TIB-LEFTOVER-BYTES 0 , + +\ Attempt to replace the parse area with the next line from the current source +\ Return TRUE if the parse area was refilled, or FALSE otherwise +\ REFILL always fails if the current source is a string (from EVALUATE) +:REPLACE 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-BYTES @ CMOVE + \ Look for the linefeed character which marks the end of the first line + TIB-LEFTOVER-BYTES @ 0 BEGIN + \ If at the end with room in the buffer, read more from the file descriptor + 2DUP = IF + DUP TERMINAL-BUFFER-BYTES U< IF + \ SOURCE-ID is the file descriptor number to read from + SOURCE-ID OVER TERMINAL-BUFFER TERMINAL-BUFFER-BYTES ROT /STRING + ( 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-BYTES ! + ( S: idx ) + \ The new input buffer is the first idx characters of the terminal buffer + TERMINAL-BUFFER OVER INPUT-BUFFER 2! + DUP IF 0 >IN ! THEN + 0<> ; + +HIDE TIB-LEFTOVER +HIDE TIB-LEFTOVER-BYTES +HIDE TERMINAL-BUFFER + : ESCAPED-CHAR ( "" | "c" -- c ) NEXT-CHAR DUP [CHAR] \ = IF DROP NEXT-CHAR CASE @@ -1257,8 +1244,17 @@ HIDE TOTAL THEN REPEAT ; -DEFER SHOW-PROMPT -{ "> " TYPE } IS SHOW-PROMPT +: EVALUATE ( i*x c-addr u -- j*x ) + SAVE-INPUT N>R + SOURCE 2>R + SOURCE-ID >R + INPUT-BUFFER 2! + 0 >IN ! + -1 CURRENT-SOURCE-ID ! + INTERPRET + R> CURRENT-SOURCE-ID ! + 2R> INPUT-BUFFER 2! + NR> RESTORE-INPUT DROP ; 36 CONSTANT STRUCT-TERMIOS-BYTES 21505 CONSTANT IOCTL_TCGETS @@ -1276,7 +1272,7 @@ STDIN TTY? CONSTANT INTERACTIVE? 0 CURRENT-SOURCE-ID ! FALSE STATE ! BEGIN - [ INTERACTIVE? ] [IF] SHOW-PROMPT [THEN] + [ INTERACTIVE? ] [IF] "> " TYPE [THEN] REFILL 0= IF BYE THEN INTERPRET [ INTERACTIVE? ] [IF] @@ -1284,17 +1280,10 @@ STDIN TTY? CONSTANT INTERACTIVE? [THEN] AGAIN ; -: EVALUATE ( i*x c-addr u -- j*x ) - SAVE-INPUT N>R - SOURCE 2>R - SOURCE-ID >R - INPUT-BUFFER 2! - 0 >IN ! - -1 CURRENT-SOURCE-ID ! - INTERPRET - R> CURRENT-SOURCE-ID ! - 2R> INPUT-BUFFER 2! - NR> RESTORE-INPUT DROP ; +HIDE BOOTSTRAP-WORDLIST + +HIDE PNO-BUFFER +HIDE PNO-BUFFER-END HIDE CURRENT-SOURCE-ID HIDE INPUT-BUFFER @@ -1302,15 +1291,11 @@ HIDE INPUT-BUFFER 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 +\ Switch to the interpreter defined in this startup file +\ Process the rest of the startup file and then switch to terminal input +{ PARSE-AREA EVALUATE QUIT } EXECUTE \ ***************************************************************************** \ Bootstrapping is complete