use ALLOCATE for the terminal input buffer and search order entries
This commit is contained in:
parent
9cf133a715
commit
4b98e19304
661
startup.4th
661
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 ( -- <noreturn> )
|
||||
' 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 <noreturn> )
|
|||
: 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 <noreturn> )
|
|||
\ 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 <noreturn> )
|
|||
\ 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 ( -- <noreturn> )
|
||||
' BAILOUT ' QUIT DEFER!
|
||||
|
||||
\ This function defines what happens when THROW is used outside of any CATCH
|
||||
: DEFAULT-UNWIND ( k*x n -- i*x <noreturn> )
|
||||
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 <noreturn> )
|
||||
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 ( "<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<eol>" -- ) IMMEDIATE BEGIN NEXT-CHAR LF = UNTIL ;
|
||||
: ( ( "ccc<closeparen>" -- ) 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 ( "<spaces>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: "<spaces>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
|
||||
: ' ( "<spaces>ccc" -- xt ) WORD FIND-OR-THROW DROP ;
|
||||
|
||||
\ Like ' but generates a literal at compile-time.
|
||||
: ['] ( Compilation: "<spaces>ccc" -- ) ( Runtime: -- xt ) IMMEDIATE
|
||||
' POSTPONE LITERAL ;
|
||||
|
||||
\ Read a word and append its compilation semantics to the current definition.
|
||||
: POSTPONE ( "<spaces>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 { ' <name> DEFER! } or { ['] <name> DEFER! } depending on STATE
|
||||
\ If used during compilation, capture the name immediately but set target at runtime
|
||||
: IS ( Compilation: "<spaces>ccc" -- )
|
||||
( Runtime: xt -- )
|
||||
( Interpreted: xt "<spaces>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 "<spaces>name" -- ) IMMEDIATE
|
||||
' >BODY STATE @ IF POSTPONE LITERAL POSTPONE ! ELSE ! THEN ;
|
||||
|
||||
\ Hide the named word: HIDE <name>
|
||||
: HIDE ( "<spaces>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 <noreturn> )
|
||||
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
|
||||
: ' ( "<spaces>ccc" -- xt ) WORD FIND-OR-THROW DROP ;
|
||||
|
||||
\ Like ' but generates a literal at compile-time.
|
||||
: ['] ( Compilation: "<spaces>ccc" -- ) ( Runtime: -- xt ) IMMEDIATE
|
||||
' POSTPONE LITERAL ;
|
||||
|
||||
\ Read a word and append its compilation semantics to the current definition.
|
||||
: POSTPONE ( "<spaces>name" -- ) IMMEDIATE
|
||||
WORD FIND-OR-THROW 0< IF
|
||||
COMPILE,
|
||||
ELSE
|
||||
POSTPONE LITERAL
|
||||
POSTPONE COMPILE,
|
||||
THEN ;
|
||||
|
||||
\ Shorthand for { ' <name> DEFER! } or { ['] <name> DEFER! } depending on STATE
|
||||
\ If used during compilation, capture the name immediately but set target at runtime
|
||||
: IS ( Compilation: "<spaces>ccc" -- )
|
||||
( Runtime: xt -- )
|
||||
( Interpreted: xt "<spaces>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 "<spaces>name" -- ) IMMEDIATE
|
||||
' >BODY STATE @ IF POSTPONE LITERAL POSTPONE ! ELSE ! THEN ;
|
||||
|
||||
\ Hide the named word: HIDE <name>
|
||||
: HIDE ( "<spaces>ccc" -- ) ' (HIDE) ;
|
||||
|
||||
\ Begin a new colon definition; hide & redirect the previous word
|
||||
\ with the same name to the new definition
|
||||
: :REPLACE ( "<spaces>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 ( "<escapeseq>" | "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
|
||||
|
|
|
|||
Loading…
Reference in New Issue