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! ;
|
: (HIDE) ( xt -- ) >FLAGS DUP C@ F_HIDDEN OR SWAP C! ;
|
||||||
: (UNHIDE) ( xt -- ) >FLAGS DUP C@ F_HIDDEN INVERT AND 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
|
\ Fetch and store the target of the deferred word denoted by deferred-xt
|
||||||
DEFER QUIT ( -- <noreturn> )
|
\ Note that this DEFER! can turn any word into a deferred word
|
||||||
' BAILOUT ' QUIT DEFER!
|
: 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)
|
\ Standard (ANS FORTH) THROW code assignments (-255 ... -1)
|
||||||
-1 CONSTANT EXCP-ABORT
|
-1 CONSTANT EXCP-ABORT
|
||||||
|
|
@ -99,9 +103,6 @@ DEFER THROW-UNWIND ( k*x n -- i*x <noreturn> )
|
||||||
: EMIT ( c -- "c" )
|
: EMIT ( c -- "c" )
|
||||||
SP@ 2DUP C! STDOUT SWAP 1 SYS_WRITE SYSCALL3 2DROP ;
|
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
|
\ Write a character array to the given file descriptor
|
||||||
\ Repeat write syscall until entire string is written
|
\ Repeat write syscall until entire string is written
|
||||||
\ Abandon output on any error other than EINTR
|
\ 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
|
\ 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
|
\ If the word list is empty the result will be zero
|
||||||
: LATEST ( -- xt | 0 ) GET-CURRENT @ ;
|
: LATEST ( -- xt | 0 ) GET-CURRENT @ ;
|
||||||
|
: LATEST! ( xt -- ) GET-CURRENT ! ;
|
||||||
|
|
||||||
\ Set the latest defined word as immediate
|
\ Set the latest defined word as immediate
|
||||||
\ Note that IMMEDIATE is itself an immediate word
|
\ 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
|
\ 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
|
\ 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 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
|
80 CONSTANT PNO-BUFFER-BYTES
|
||||||
|
|
||||||
CREATE PNO-BUFFER PNO-BUFFER-BYTES ALLOT
|
CREATE PNO-BUFFER PNO-BUFFER-BYTES ALLOT
|
||||||
|
|
@ -223,8 +226,6 @@ CREATE PNO-POINTER PNO-BUFFER-END ,
|
||||||
: HOLD ( char -- ) PNO-POINTER 1 OVER -! @ C! ;
|
: HOLD ( char -- ) PNO-POINTER 1 OVER -! @ C! ;
|
||||||
: #> ( xd -- c-addr u ) 2DROP PNO-BUFFER-END PNO-POINTER @ TUCK - ;
|
: #> ( xd -- c-addr u ) 2DROP PNO-BUFFER-END PNO-POINTER @ TUCK - ;
|
||||||
|
|
||||||
' PNO-BUFFER (HIDE)
|
|
||||||
' PNO-BUFFER-END (HIDE)
|
|
||||||
' PNO-POINTER (HIDE)
|
' PNO-POINTER (HIDE)
|
||||||
|
|
||||||
: SIGN ( n -- ) 0< IF [CHAR] - HOLD THEN ;
|
: SIGN ( n -- ) 0< IF [CHAR] - HOLD THEN ;
|
||||||
|
|
@ -285,13 +286,14 @@ CREATE DISPLAY-ITEM-LIMIT 6 ,
|
||||||
THEN
|
THEN
|
||||||
HERE + DUP BRK @ U> IF
|
HERE + DUP BRK @ U> IF
|
||||||
[ DATA-SEGMENT-ALIGNMENT 1- ] LITERAL 2DUP + SWAP INVERT AND
|
[ DATA-SEGMENT-ALIGNMENT 1- ] LITERAL 2DUP + SWAP INVERT AND
|
||||||
DUP
|
BEGIN
|
||||||
SYS_BRK SYSCALL1
|
DUP SYS_BRK SYSCALL1
|
||||||
|
DUP [ ERRNO_EINTR NEGATE ] LITERAL <> DUP IF NIP THEN
|
||||||
|
UNTIL
|
||||||
OVER <> IF EXCP-DICTIONARY-OVERFLOW THROW THEN
|
OVER <> IF EXCP-DICTIONARY-OVERFLOW THROW THEN
|
||||||
BRK !
|
BRK !
|
||||||
THEN
|
THEN
|
||||||
CP !
|
CP ! ;
|
||||||
;
|
|
||||||
|
|
||||||
\ Allocate one character from the data area and fill it with the value on the stack
|
\ Allocate one character from the data area and fill it with the value on the stack
|
||||||
: C, HERE 1 ALLOT C! ;
|
: C, HERE 1 ALLOT C! ;
|
||||||
|
|
@ -474,6 +476,26 @@ CREATE LEAVE-ORIG 0 ,
|
||||||
LOOP
|
LOOP
|
||||||
2DROP R> SIGNUM ;
|
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
|
\ This function defines what happens when THROW is used outside of any CATCH
|
||||||
: DEFAULT-UNWIND ( k*x n -- i*x <noreturn> )
|
: DEFAULT-UNWIND ( k*x n -- i*x <noreturn> )
|
||||||
CASE
|
CASE
|
||||||
|
|
@ -498,21 +520,55 @@ CREATE LEAVE-ORIG 0 ,
|
||||||
' DEFAULT-UNWIND ' THROW-UNWIND DEFER!
|
' DEFAULT-UNWIND ' THROW-UNWIND DEFER!
|
||||||
' DEFAULT-UNWIND (HIDE)
|
' DEFAULT-UNWIND (HIDE)
|
||||||
|
|
||||||
\ Copy the bootstrap SOURCE values into variables to allow changing the input buffer
|
CREATE EXCEPTION-STACK 0 ,
|
||||||
CREATE INPUT-BUFFER SOURCE 2,
|
|
||||||
|
|
||||||
\ The SOURCE-ID is -1 for a string (EVALUATE) or 0 for user input
|
\ Called when THROW is called inside of CATCH
|
||||||
\ Any other values are implementation-defined, for example FD numbers for file input
|
\ Restore the input source specification, stack point, and return stack pointer
|
||||||
CREATE CURRENT-SOURCE-ID -1 ,
|
\ 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
|
\ Run xt while trapping calls to THROW, ABORT, FAIL, etc.
|
||||||
: SOURCE ( -- c-addr u ) INPUT-BUFFER 2@ ;
|
\ On success has the effect of xt and also leaves the value 0 on top of the stack
|
||||||
: SOURCE-ID ( -- 0 | -1 | +n ) CURRENT-SOURCE-ID @ ;
|
\ 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)
|
' EXCEPTION-STACK (HIDE)
|
||||||
\ This does not include the input buffer (SOURCE) or the SOURCE-ID
|
' CATCH-UNWIND (HIDE)
|
||||||
: SAVE-INPUT ( -- xu ... x1 u ) >IN @ 1 ;
|
' THROW-UNWIND (HIDE)
|
||||||
: RESTORE-INPUT ( xu ... x1 u -- flag ) OVER >IN ! NDROP TRUE ;
|
|
||||||
|
|
||||||
: PARSE-AREA ( -- c-addr u ) SOURCE >IN @ /STRING ;
|
: PARSE-AREA ( -- c-addr u ) SOURCE >IN @ /STRING ;
|
||||||
|
|
||||||
|
|
@ -525,63 +581,6 @@ CREATE CURRENT-SOURCE-ID -1 ,
|
||||||
|
|
||||||
: NEXT-CHAR ( -- c ) PEEK-CHAR SKIP-CHAR ;
|
: 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?>" -- )
|
: SKIP-SPACES ( "<spaces?>" -- )
|
||||||
BEGIN PARSE-EMPTY? OR-ELSE PEEK-CHAR SPACE? DUP IF SKIP-CHAR THEN 0= THEN UNTIL ;
|
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<eol>" -- ) IMMEDIATE BEGIN NEXT-CHAR LF = UNTIL ;
|
||||||
: ( ( "ccc<closeparen>" -- ) IMMEDIATE BEGIN NEXT-CHAR [CHAR] ) = 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
|
\ Skip whitespace; read and return the next word delimited by whitespace
|
||||||
\ The delimiting whitespace character is left in the parse area
|
\ The delimiting whitespace character is left in the parse area
|
||||||
: WORD ( "<spaces>ccc" -- c-addr u )
|
: WORD ( "<spaces>ccc" -- c-addr u )
|
||||||
|
|
@ -611,7 +614,7 @@ CREATE TIB-LEFTOVER-SIZE 0 ,
|
||||||
DODATA , 0 , LATEST ,
|
DODATA , 0 , LATEST ,
|
||||||
WORD DUP C, HERE SWAP DUP ALLOT CMOVE
|
WORD DUP C, HERE SWAP DUP ALLOT CMOVE
|
||||||
ALIGN HERE OVER >DFA !
|
ALIGN HERE OVER >DFA !
|
||||||
GET-CURRENT ! ;
|
LATEST! ;
|
||||||
|
|
||||||
\ Called when a word using DOES> is executed (not compiled) to set
|
\ Called when a word using DOES> is executed (not compiled) to set
|
||||||
\ the runtime behavior of the most recently defined word
|
\ 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
|
\ The execution token is left on the stack for use after the definition ends
|
||||||
: :NONAME ( -- )
|
: :NONAME ( -- )
|
||||||
ALIGN HERE DOCOL , HERE 3 CELLS+ , LATEST , F_HIDDEN C,
|
ALIGN HERE DOCOL , HERE 3 CELLS+ , LATEST , F_HIDDEN C,
|
||||||
DUP GET-CURRENT ! ALIGN POSTPONE ] ;
|
DUP LATEST! ALIGN POSTPONE ] ;
|
||||||
|
|
||||||
\ Fetch and store the target of the deferred word denoted by deferred-xt
|
|
||||||
\ Note that this DEFER! can turn any word into a deferred word
|
|
||||||
: DEFER@ ( deferred-xt -- xt ) >DFA @ ;
|
|
||||||
: DEFER! ( xt deferred-xt -- ) DODEFER OVER >CFA ! >DFA ! ;
|
|
||||||
|
|
||||||
\ Create a deferred word; the target is stored in the DFA field
|
\ Create a deferred word; the target is stored in the DFA field
|
||||||
\ The default target throws an exception — replace it using DEFER! or IS
|
\ The default target throws an exception — replace it using DEFER! or IS
|
||||||
|
|
@ -727,7 +725,7 @@ CREATE TIB-LEFTOVER-SIZE 0 ,
|
||||||
STATE @
|
STATE @
|
||||||
DUP IF
|
DUP IF
|
||||||
LATEST
|
LATEST
|
||||||
DUP >LINK @ GET-CURRENT !
|
DUP >LINK @ LATEST!
|
||||||
0 OVER >LINK !
|
0 OVER >LINK !
|
||||||
POSTPONE AHEAD
|
POSTPONE AHEAD
|
||||||
ROT
|
ROT
|
||||||
|
|
@ -747,7 +745,7 @@ CREATE TIB-LEFTOVER-SIZE 0 ,
|
||||||
\ Resolve the forward branch over the inner definition
|
\ Resolve the forward branch over the inner definition
|
||||||
-ROT POSTPONE THEN
|
-ROT POSTPONE THEN
|
||||||
\ Re-append the outer definition to the word list
|
\ 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 ; )
|
\ Return to compilation mode (was ended by ; )
|
||||||
POSTPONE ]
|
POSTPONE ]
|
||||||
\ Compile inner-xt as a literal in the outer definition
|
\ 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] ( Compilation: "<spaces>ccc" -- ) ( Runtime: -- c ) IMMEDIATE
|
||||||
CHAR POSTPONE LITERAL ;
|
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
|
32 CONSTANT BUDDY-MIN-BYTES
|
||||||
18 CONSTANT BUDDY-ORDERS
|
18 CONSTANT BUDDY-ORDERS
|
||||||
: BUDDY-ORDER-BYTES ( order -- n-bytes ) BUDDY-MIN-BYTES SWAP LSHIFT ;
|
: BUDDY-ORDER-BYTES ( order -- n-bytes ) BUDDY-MIN-BYTES SWAP LSHIFT ;
|
||||||
|
|
@ -1090,7 +862,7 @@ VARIABLE TOTAL
|
||||||
. "x" TYPE I BUDDY-ORDER-BYTES . SPACE
|
. "x" TYPE I BUDDY-ORDER-BYTES . SPACE
|
||||||
THEN
|
THEN
|
||||||
LOOP "total " TYPE TOTAL @ . EOL ;
|
LOOP "total " TYPE TOTAL @ . EOL ;
|
||||||
HIDE TOTAL
|
' TOTAL (HIDE)
|
||||||
|
|
||||||
0 CONSTANT NULL
|
0 CONSTANT NULL
|
||||||
|
|
||||||
|
|
@ -1170,11 +942,226 @@ HIDE TOTAL
|
||||||
( S: obj-addr1 obj-addr2 copy-size R: obj-addr1 obj-addr2 )
|
( S: obj-addr1 obj-addr2 copy-size R: obj-addr1 obj-addr2 )
|
||||||
CMOVE R> R> FREE ;
|
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
|
\ Begin a new colon definition; hide & redirect the previous word
|
||||||
\ with the same name to the new definition
|
\ with the same name to the new definition
|
||||||
: :REPLACE ( "<spaces>ccc" -- )
|
: :REPLACE ( "<spaces>ccc" -- )
|
||||||
: LATEST DUP >NAME FIND-OR-THROW DROP DUP (HIDE) DEFER! ;
|
: 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 )
|
: ESCAPED-CHAR ( "<escapeseq>" | "c" -- c )
|
||||||
NEXT-CHAR DUP [CHAR] \ = IF
|
NEXT-CHAR DUP [CHAR] \ = IF
|
||||||
DROP NEXT-CHAR CASE
|
DROP NEXT-CHAR CASE
|
||||||
|
|
@ -1257,8 +1244,17 @@ HIDE TOTAL
|
||||||
THEN
|
THEN
|
||||||
REPEAT ;
|
REPEAT ;
|
||||||
|
|
||||||
DEFER SHOW-PROMPT
|
: EVALUATE ( i*x c-addr u -- j*x )
|
||||||
{ "> " TYPE } IS SHOW-PROMPT
|
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
|
36 CONSTANT STRUCT-TERMIOS-BYTES
|
||||||
21505 CONSTANT IOCTL_TCGETS
|
21505 CONSTANT IOCTL_TCGETS
|
||||||
|
|
@ -1276,7 +1272,7 @@ STDIN TTY? CONSTANT INTERACTIVE?
|
||||||
0 CURRENT-SOURCE-ID !
|
0 CURRENT-SOURCE-ID !
|
||||||
FALSE STATE !
|
FALSE STATE !
|
||||||
BEGIN
|
BEGIN
|
||||||
[ INTERACTIVE? ] [IF] SHOW-PROMPT [THEN]
|
[ INTERACTIVE? ] [IF] "> " TYPE [THEN]
|
||||||
REFILL 0= IF BYE THEN
|
REFILL 0= IF BYE THEN
|
||||||
INTERPRET
|
INTERPRET
|
||||||
[ INTERACTIVE? ] [IF]
|
[ INTERACTIVE? ] [IF]
|
||||||
|
|
@ -1284,17 +1280,10 @@ STDIN TTY? CONSTANT INTERACTIVE?
|
||||||
[THEN]
|
[THEN]
|
||||||
AGAIN ;
|
AGAIN ;
|
||||||
|
|
||||||
: EVALUATE ( i*x c-addr u -- j*x )
|
HIDE BOOTSTRAP-WORDLIST
|
||||||
SAVE-INPUT N>R
|
|
||||||
SOURCE 2>R
|
HIDE PNO-BUFFER
|
||||||
SOURCE-ID >R
|
HIDE PNO-BUFFER-END
|
||||||
INPUT-BUFFER 2!
|
|
||||||
0 >IN !
|
|
||||||
-1 CURRENT-SOURCE-ID !
|
|
||||||
INTERPRET
|
|
||||||
R> CURRENT-SOURCE-ID !
|
|
||||||
2R> INPUT-BUFFER 2!
|
|
||||||
NR> RESTORE-INPUT DROP ;
|
|
||||||
|
|
||||||
HIDE CURRENT-SOURCE-ID
|
HIDE CURRENT-SOURCE-ID
|
||||||
HIDE INPUT-BUFFER
|
HIDE INPUT-BUFFER
|
||||||
|
|
@ -1302,15 +1291,11 @@ HIDE INPUT-BUFFER
|
||||||
HIDE ESCAPED-CHAR
|
HIDE ESCAPED-CHAR
|
||||||
HIDE READSTRING
|
HIDE READSTRING
|
||||||
HIDE PARSENUMBER
|
HIDE PARSENUMBER
|
||||||
|
|
||||||
\ Switch to the interpreter defined in this startup file
|
|
||||||
{ R0 RSP! BEGIN INTERPRET AGAIN } EXECUTE
|
|
||||||
HIDE INTERPRET
|
HIDE INTERPRET
|
||||||
|
|
||||||
\ Remove the bootstrap word list from the search order
|
\ Switch to the interpreter defined in this startup file
|
||||||
HIDE BOOTSTRAP-WORDLIST
|
\ Process the rest of the startup file and then switch to terminal input
|
||||||
FORTH-WORDLIST 1 SET-ORDER
|
{ PARSE-AREA EVALUATE QUIT } EXECUTE
|
||||||
DEFINITIONS
|
|
||||||
|
|
||||||
\ *****************************************************************************
|
\ *****************************************************************************
|
||||||
\ Bootstrapping is complete
|
\ Bootstrapping is complete
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue