815 lines
26 KiB
Forth
815 lines
26 KiB
Forth
\ Get and set the current compilation word list
|
|
: GET-CURRENT ( -- wid ) CURRENT @ ;
|
|
: SET-CURRENT ( wid -- ) CURRENT ! ;
|
|
|
|
\ Get the execution token of the most recent word in the compilation word list
|
|
\ If the word list is empty the result will be zero
|
|
: LATEST ( -- xt | 0 ) GET-CURRENT @ ;
|
|
|
|
\ Shorthand for working with cell-aligned addresses
|
|
: CELL+ ( addr1 -- addr2 ) CELL + ;
|
|
: CELL- ( addr1 -- addr2 ) CELL - ;
|
|
: CELLS ( n1 -- n2 ) CELL * ;
|
|
: CELLS+ ( addr1 n -- addr2 ) CELL * + ;
|
|
: CELLS- ( addr1 n -- addr2 ) CELL * - ;
|
|
|
|
\ Round up to the next cell-aligned address
|
|
: ALIGNED ( addr -- a-addr )
|
|
[ CELL 1- ] LITERAL + [ CELL NEGATE ] LITERAL AND ;
|
|
|
|
\ Field accessors for execution tokens
|
|
: >CFA ( xt -- a-addr ) ;
|
|
: >DFA ( xt -- a-addr ) CELL+ ;
|
|
: >LINK ( xt -- a-addr ) 2 CELLS+ ;
|
|
: >FLAGS ( xt -- c-addr ) 3 CELLS+ ;
|
|
: >NAME ( xt -- c-addr u ) >FLAGS DUP 1+ SWAP C@ F_LENMASK AND ;
|
|
: >BODY ( xt -- a-addr ) >NAME + ALIGNED ;
|
|
|
|
: IMMEDIATE? ( xt -- flag ) >FLAGS C@ F_IMMED AND 0<> ;
|
|
: HIDDEN? ( xt -- flag ) >FLAGS C@ F_HIDDEN AND 0<> ;
|
|
|
|
\ Set the latest defined word as immediate
|
|
\ Note that IMMEDIATE is itself an immediate word
|
|
: IMMEDIATE ( -- ) LATEST >FLAGS DUP C@ F_IMMED OR SWAP C! ; IMMEDIATE
|
|
|
|
\ Switch from compiling to interpreting, or vice-versa
|
|
: [ ( -- ) IMMEDIATE FALSE STATE ! ;
|
|
: ] ( -- ) IMMEDIATE TRUE STATE ! ;
|
|
|
|
\ Separate the division and modulus operators
|
|
: /MOD ( n1 n2 -- n1%n2 n1/n2 ) >R S>D R> SM/REM ;
|
|
: / ( n1 n2 -- n1/n2 ) >R S>D R> SM/REM NIP ;
|
|
: MOD ( n1 n2 -- n1%n2 ) >R S>D R> SM/REM DROP ;
|
|
|
|
\ Single-cell unsigned division and modulus
|
|
: U/MOD ( u1 u2 -- u1%u2 u1/u2 ) 0 SWAP UM/MOD ;
|
|
: U/ ( u1 u2 -- u1/u2 ) 0 SWAP UM/MOD NIP ;
|
|
: UMOD ( u1 u2 -- u1%u2 ) 0 SWAP UM/MOD DROP ;
|
|
|
|
\ Flooring division and modulus (n1%n2 >= 0)
|
|
: FM/MOD ( d1 n1 -- d1%n1 d1/n1 )
|
|
DUP >R SM/REM OVER 0< IF 1- SWAP R> + SWAP ELSE RDROP THEN ;
|
|
|
|
\ Names for the standard file descriptor numbers
|
|
0 CONSTANT STDIN
|
|
1 CONSTANT STDOUT
|
|
2 CONSTANT STDERR
|
|
|
|
\ Write one character to FD 1 (stdout)
|
|
: EMIT ( c -- "c" )
|
|
SP@ 2DUP C! STDOUT SWAP 1 SYS_WRITE SYSCALL3 2DROP ;
|
|
|
|
\ Write a character array to stdout
|
|
\ Repeat write syscall until entire string is written
|
|
\ Abandon output on any error other than EINTR
|
|
: TYPE ( c-addr u -- "ccc" )
|
|
BEGIN
|
|
?DUP
|
|
WHILE
|
|
2DUP STDOUT -ROT SYS_WRITE SYSCALL3
|
|
DUP 0<= IF
|
|
ERRNO_EINTR NEGATE <> IF
|
|
2DROP EXIT
|
|
THEN
|
|
ELSE
|
|
\ Decrement the array size and increment the
|
|
\ address by the number of bytes written
|
|
TUCK - -ROT + SWAP
|
|
THEN
|
|
REPEAT
|
|
DROP ;
|
|
|
|
\ Define names for the whitespace characters
|
|
8 CONSTANT HT \ Horizontal Tab
|
|
10 CONSTANT LF \ Line Feed (newline)
|
|
11 CONSTANT VT \ Vertical Tab
|
|
12 CONSTANT FF \ Form Feed
|
|
13 CONSTANT CR \ Carriage Return
|
|
32 CONSTANT BL \ BLank (space)
|
|
|
|
\ Test whether the given character is whitespace (HT, LF, VT, FF, CR, or BL)
|
|
\ Note that HT, LF, VT, FF, and CR together form the range 9 ... 13 inclusive
|
|
: SPACE? ( c -- flag )
|
|
DUP BL = IF DROP TRUE EXIT THEN
|
|
9 - [ 13 9 - ] LITERAL U<= ;
|
|
|
|
\ Emit a blank (space) character
|
|
: SPACE ( -- "<space>" ) BL EMIT ;
|
|
|
|
\ Emit a horizontal tab character
|
|
: TAB ( -- "<tab>" ) HT EMIT ;
|
|
|
|
\ Emit an implementation-dependent End-of-Line sequence
|
|
\ Here this is just a LF (Unix convention) but it could be CR (Mac) or CR+LF (DOS)
|
|
: EOL ( -- "<eol>" ) LF EMIT ;
|
|
|
|
\ Terminate the program, successfully
|
|
\ This will never return, even if the system call does
|
|
: BYE ( -- <noreturn> )
|
|
BEGIN 0 SYS_EXIT SYSCALL1 DROP AGAIN ;
|
|
|
|
\ Terminate the program with a fatal error (SIGABRT)
|
|
: FATAL-ERROR ( -- <noreturn> )
|
|
BEGIN
|
|
\ A full version would also unmask SIGABRT and restore the default handler
|
|
\ For now we assume the mask and handler are already at default settings
|
|
SYS_GETPID SYSCALL0 SYS_GETTID SYSCALL0 SIGABRT SYS_TGKILL SYSCALL3 DROP
|
|
AGAIN ;
|
|
|
|
\ Return the next address in the compilation/data area
|
|
: HERE ( -- addr ) CP @ ;
|
|
|
|
: ALLOT-BOUNDS "Allocation out of bounds!" TYPE EOL FATAL-ERROR ;
|
|
: ALLOT-OOM "Out of memory!" TYPE EOL FATAL-ERROR ;
|
|
|
|
\ When growing the data area, round the end address up to a multiple of this size
|
|
65536 CONSTANT DATA-SEGMENT-ALIGNMENT
|
|
|
|
: ALLOT ( n -- )
|
|
DUP 0< IF
|
|
DUP C0 HERE - < IF ALLOT-BOUNDS THEN
|
|
ELSE
|
|
DUP HERE INVERT U> IF ALLOT-BOUNDS THEN
|
|
THEN
|
|
HERE + DUP BRK @ U> IF
|
|
[ DATA-SEGMENT-ALIGNMENT 1- ] LITERAL 2DUP + SWAP INVERT AND
|
|
DUP
|
|
SYS_BRK SYSCALL1
|
|
OVER <> IF ALLOT-OOM THEN
|
|
BRK !
|
|
THEN
|
|
CP !
|
|
;
|
|
|
|
: , HERE CELL ALLOT ! ;
|
|
|
|
: C, HERE 1 ALLOT C! ;
|
|
|
|
: ALIGN HERE ALIGNED HERE - BEGIN ?DUP WHILE 0 C, 1- REPEAT ;
|
|
|
|
\ Append the effect of the token on top of the stack to the current definition.
|
|
\ Here it's equivalent to , since words are just arrays of execution tokens.
|
|
\ Once COMPILE, has been defined we can use POSTPONE for non-immediate words.
|
|
: COMPILE, ( xt -- ) , ;
|
|
|
|
\ Append the LIT xt and the topmost word on the stack to the current definition.
|
|
: LITERAL ( Compilation: x -- ) ( Runtime: -- x ) IMMEDIATE
|
|
POSTPONE LIT , ;
|
|
|
|
\ Append the execution semantics of the current definition to the current definition
|
|
: RECURSE ( -- ) IMMEDIATE
|
|
LATEST COMPILE, ;
|
|
|
|
\ Unhide the current definition so it can refer to itself by name
|
|
: RECURSIVE ( -- ) IMMEDIATE
|
|
LATEST >FLAGS DUP C@ F_HIDDEN INVERT AND SWAP C! ;
|
|
|
|
\ Our first control-flow primitive: <cond> IF <true> {ELSE <false>} THEN
|
|
\
|
|
\ IF compiles an unresolved conditional branch.
|
|
\ AHEAD compiles an unconditional branch (same effect as TRUE IF).
|
|
\ Both AHEAD and IF leave the address of the unresolved offset on the stack.
|
|
\
|
|
\ THEN consumes the offset address and resolves it to the next code address.
|
|
\
|
|
\ ELSE inserts an unconditional branch (to THEN) and also resolves the
|
|
\ previous forward reference (from IF).
|
|
\
|
|
: IF ( C: -- orig ) ( Runtime S: flag -- ) IMMEDIATE
|
|
POSTPONE 0BRANCH HERE 0 , ;
|
|
: AHEAD ( C: -- orig ) IMMEDIATE
|
|
POSTPONE BRANCH HERE 0 , ;
|
|
: THEN ( C: orig -- ) IMMEDIATE
|
|
HERE OVER - SWAP ! ;
|
|
: ELSE ( C: orig1 -- orig2 ) IMMEDIATE
|
|
POSTPONE AHEAD SWAP POSTPONE THEN ;
|
|
|
|
\ Unbounded loop: BEGIN <body> AGAIN
|
|
\ BEGIN places the offset of the start of <code> on the stack.
|
|
\ AGAIN creates a relative branch back to the start of <code>.
|
|
: BEGIN ( C: -- dest ) IMMEDIATE
|
|
HERE ;
|
|
: AGAIN ( C: dest -- ) IMMEDIATE
|
|
POSTPONE BRANCH HERE - , ;
|
|
|
|
\ Simple conditional loop: BEGIN <body> UNTIL
|
|
\ UNTIL consumes the top of the stack and branches back to BEGIN if the value was zero.
|
|
: UNTIL ( C: dest -- ) ( Runtime S: flag -- ) IMMEDIATE
|
|
POSTPONE 0BRANCH HERE - , ;
|
|
|
|
\ Alternate conditional loop: BEGIN <condition> WHILE <body> REPEAT
|
|
: WHILE ( C: dest -- orig dest ) ( Runtime S: flag -- ) IMMEDIATE
|
|
POSTPONE IF SWAP ;
|
|
: REPEAT ( C: orig dest -- ) IMMEDIATE
|
|
POSTPONE AGAIN POSTPONE THEN ;
|
|
|
|
\ Range loop: <limit> <index> DO <code> LOOP
|
|
\ <limit> <index> DO <code> <step> +LOOP
|
|
: UNLOOP POSTPONE 2RDROP ; IMMEDIATE
|
|
: DO POSTPONE 2>R POSTPONE BEGIN ; IMMEDIATE
|
|
: (+LOOP) ( step limit index -- flag limit index' )
|
|
ROT + 2DUP = -ROT ;
|
|
: +LOOP
|
|
POSTPONE 2R> POSTPONE (+LOOP) POSTPONE 2>R
|
|
POSTPONE UNTIL POSTPONE 2RDROP
|
|
; IMMEDIATE
|
|
: LOOP 1 POSTPONE LITERAL POSTPONE +LOOP ; IMMEDIATE
|
|
|
|
\ Return the current index value from the innermost or next-innermost loop.
|
|
\ The loops must be directly nested with no other changes to the return stack
|
|
: I 1 RPICK ;
|
|
: J 3 RPICK ;
|
|
|
|
\ Sequential equality tests:
|
|
\ <x> CASE
|
|
\ <x0> OF <code0> ENDOF
|
|
\ <x1> OF <code1> ENDOF
|
|
\ ...
|
|
\ ENDCASE
|
|
\
|
|
\ When <x> equals <x0> execute <code0>, when <x> equals <x1> execute <code1>, etc.
|
|
\ During compilation the stack holds a list of forward references to the ENDCASE,
|
|
\ with the number of references on top. Inside OF ... ENDOF there is additionally
|
|
\ a forward reference to the ENDOF (as with IF ... THEN) above the ENDCASE counter.
|
|
\
|
|
\ Begin by creating a counter for the number of unresolved ENDOF forward references
|
|
: CASE ( C: -- 0 ) IMMEDIATE
|
|
0 ;
|
|
\ At runtime compare the values on the top of the stack; branch to ENDOF if unequal
|
|
\ Keep the first value for the next OF if unequal, otherwise consume both
|
|
: OF ( C: orign ... orig1 n -- orign ... orig1 n orig-of ) IMMEDIATE
|
|
POSTPONE OVER POSTPONE = POSTPONE IF POSTPONE DROP ;
|
|
\ Create a forward branch to ENDCASE and resolve the one from OF
|
|
: ENDOF ( C: orign ... orig1 n orig-of -- orign ... orig1 orig0 n+1 ) IMMEDIATE
|
|
POSTPONE AHEAD -ROT POSTPONE THEN 1+ ;
|
|
\ Drop the <x> value in case none of the OF...ENDOF clauses matched
|
|
\ Resolve all the forward branches from ENDOF to the location after ENDCASE
|
|
: ENDCASE ( C: orign ... orig1 n -- ) IMMEDIATE
|
|
POSTPONE DROP 0 DO POSTPONE THEN LOOP ;
|
|
|
|
\ If the input buffer is empty, refill it from stdin
|
|
\ Return the next character from the input buffer
|
|
: KEY
|
|
CURRKEY @
|
|
DUP BUFFTOP @ >= IF
|
|
DROP BUFFER 0 OVER BUFFER_SIZE SYS_READ SYSCALL3
|
|
DUP 0<= IF
|
|
2DROP
|
|
BYE
|
|
THEN
|
|
OVER + BUFFTOP !
|
|
THEN
|
|
DUP 1+ CURRKEY ! C@
|
|
;
|
|
|
|
\ Puts the most recently read key back in the input buffer
|
|
\ CAUTION: Can only safely be used ONCE after each call to KEY!
|
|
\ This takes advantage of the fact that the key is still in the buffer
|
|
: PUTBACK CURRKEY @ 1- CURRKEY ! ;
|
|
|
|
: SKIPSPACE BEGIN KEY SPACE? INVERT UNTIL PUTBACK ;
|
|
|
|
\ Skip whitespace; read and return the next word delimited by whitespace
|
|
\ The word is stored in contiguous but *unallocated* data space
|
|
\ The delimiting whitespace character is left in the input buffer
|
|
: WORD ( "<spaces>ccc" -- c-addr u )
|
|
SKIPSPACE
|
|
HERE
|
|
BEGIN
|
|
KEY DUP SPACE? 0=
|
|
WHILE
|
|
C,
|
|
REPEAT
|
|
DROP
|
|
PUTBACK
|
|
HERE OVER -
|
|
OVER CP ! ;
|
|
|
|
: CREATE ( "<spaces>ccc" -- )
|
|
ALIGN HERE
|
|
DODATA , 0 , LATEST ,
|
|
HERE 0 C, WORD
|
|
NIP DUP ALLOT ALIGN SWAP C!
|
|
HERE OVER >DFA !
|
|
GET-CURRENT !
|
|
;
|
|
|
|
\ Called when a word using DOES> is executed (not compiled) to set
|
|
\ the runtime behavior of the most recently defined word
|
|
: (DOES) ( dfa -- ) LATEST DODOES OVER >CFA ! >DFA ! ;
|
|
|
|
\ Append "<addr> (DOES) EXIT" to the current definition
|
|
\ where <addr> is the next address after the "EXIT" as a literal number
|
|
\ Stay in compilation mode for the body of the DOES> clause
|
|
: DOES> ( -- ) IMMEDIATE
|
|
POSTPONE LIT HERE 0 , POSTPONE (DOES) POSTPONE EXIT
|
|
HERE SWAP ! ;
|
|
|
|
\ Define a named constant
|
|
\ Execution: ( value "<spaces>name" -- )
|
|
\ name Execution: ( -- value )
|
|
\
|
|
\ By default CREATEd words have codeword DODATA which returns the value
|
|
\ of the DFA field, so store the constant value there
|
|
\
|
|
\ Alternate definition:
|
|
\ : CONSTANT : POSTPONE LITERAL POSTPONE ; ;
|
|
: CONSTANT CREATE LATEST >DFA ! ;
|
|
|
|
\ Define a single-cell named variable which returns its data address when executed.
|
|
\ The initial value is formally undefined. This implementation sets it to zero.
|
|
\ Execution: ( "<spaces>name" -- )
|
|
\ name Execution: ( -- a-addr )
|
|
: VARIABLE CREATE 0 , ;
|
|
|
|
\ Define a single-cell named value which returns its data (not address) when executed.
|
|
\ Named values defined with VALUE can be modified with TO.
|
|
\ Execution: ( x "<spaces>name" -- )
|
|
\ name execution: ( -- value )
|
|
: VALUE CREATE , DOES> @ ;
|
|
|
|
\ Define a threaded FORTH word
|
|
\ The word is initially hidden so it can refer to a prior word with the same name
|
|
\ The definition is terminated with the ; immediate word, which unhides the name
|
|
: : ( "<spaces>ccc" -- )
|
|
CREATE LATEST
|
|
DUP >FLAGS DUP C@ F_HIDDEN OR SWAP C!
|
|
DOCOL SWAP >CFA !
|
|
POSTPONE ] ;
|
|
|
|
\ Like : but the definition has no name
|
|
\ The zero-length name still included in the word list so LATEST can refer to it
|
|
\ The execution token is left on the stack for use after the definition ends
|
|
: :NONAME ( -- )
|
|
ALIGN HERE
|
|
DOCOL ,
|
|
HERE [ 3 CELLS ] LITERAL + ,
|
|
LATEST ,
|
|
F_HIDDEN C, ALIGN
|
|
DUP GET-CURRENT !
|
|
POSTPONE ] ;
|
|
|
|
\ End a definition by appending EXIT, leaving compilation mode, and unhiding the name
|
|
\ As an optimization, zero-length names (from :NONAME) are left hidden
|
|
: ; ( -- ) IMMEDIATE
|
|
POSTPONE EXIT POSTPONE [
|
|
LATEST >FLAGS DUP C@
|
|
DUP F_LENMASK AND IF
|
|
\ Length is not zero; clear the F_HIDDEN flag
|
|
F_HIDDEN INVERT AND SWAP C!
|
|
ELSE
|
|
2DROP
|
|
THEN ;
|
|
|
|
\ Create a deferred word
|
|
\ At present a deferred word is just an ordinary threaded function
|
|
\ DEFER! and IS update which word is called by overwriting the threaded code
|
|
\ The explicit EXIT is just a placeholder to be overwritten by DEFER! or IS
|
|
\ A future version might use a special codeword with the target in the DFA field
|
|
: DEFER ( "<spaces>ccc" -- ) : POSTPONE EXIT POSTPONE ; ;
|
|
|
|
\ Fetch and store the target of the deferred word denoted by deferred-xt
|
|
: DEFER@ ( deferred-xt -- xt ) >DFA @ @ ;
|
|
: DEFER! ( xt deferred-xt -- ) >DFA @ ! ;
|
|
|
|
\ Inline :NONAME-style function literals. "{ <code> }" has the runtime effect
|
|
\ of placing the execution token for an anonymous function with the runtime
|
|
\ effect of <code> on the top of the data stack. A branch is emitted to skip
|
|
\ over the memory used for the nested definition, which is removed from the
|
|
\ current word list upon completion. If RECURSE is used in <code> it will
|
|
\ create a recursive call to the anonymous inner function.
|
|
\
|
|
\ Example:
|
|
\ OK> : TIMES 0 DO DUP EXECUTE LOOP DROP ;
|
|
\ OK> : GREETINGS { "Hello" TYPE EOL } 3 TIMES ;
|
|
\ OK> GREETINGS
|
|
\ Hello
|
|
\ Hello
|
|
\ Hello
|
|
\
|
|
\ Compilation effect: ( C: -- latest orig state )
|
|
\ Interpreter effect: ( S: -- latest state )
|
|
\ Enters compilation mode if not already compiling
|
|
: { ( -- latest {orig} state ) IMMEDIATE
|
|
LATEST
|
|
STATE @
|
|
DUP IF
|
|
POSTPONE AHEAD
|
|
SWAP
|
|
POSTPONE [
|
|
THEN
|
|
:NONAME ;
|
|
|
|
\ Resolve the forward branch over the inner function
|
|
\ Leave compilation mode if STATE was 0 before { was executed
|
|
: } ( C: latest {orig} state -- ) IMMEDIATE
|
|
POSTPONE ; SWAP IF
|
|
-ROT
|
|
POSTPONE THEN
|
|
GET-CURRENT !
|
|
POSTPONE LITERAL
|
|
POSTPONE ]
|
|
ELSE
|
|
SWAP GET-CURRENT !
|
|
THEN ;
|
|
|
|
\ Read the next word and return the first character
|
|
: CHAR ( "<spaces>name" -- c )
|
|
WORD DROP C@ ;
|
|
|
|
\ Like CHAR but generates a literal at compile-time.
|
|
: [CHAR] ( Compilation: "<spaces>ccc" -- ) ( Runtime: -- c ) IMMEDIATE
|
|
CHAR POSTPONE LITERAL ;
|
|
|
|
\ Return -1, 0, or 1 if n is respectively negative, zero, or positive
|
|
: SIGNUM ( n -- -1 | 0 | 1 ) DUP IF 0< 2 * 1+ THEN ;
|
|
|
|
\ Return -1, 0, or 1 if the left string is respectively
|
|
\ less than, equal to, or greater than the right string
|
|
: COMPARE ( c-addr1 u1 c-addr2 u2 -- -1 | 0 | 1 )
|
|
BEGIN
|
|
ROT ?DUP IF
|
|
( S: a1 a2 u2 u1 )
|
|
SWAP ?DUP IF
|
|
( S: a1 a2 u1 u2 )
|
|
2SWAP 2DUP C@ SWAP C@ - DUP IF
|
|
>R 4 NDROP R> SIGNUM EXIT
|
|
ELSE
|
|
DROP
|
|
( S: u1 u2 a1 a2 )
|
|
1+ SWAP 1+ 2SWAP 1- SWAP 1-
|
|
( S: a2' a1' u2' u1' )
|
|
SWAP -ROT 2SWAP
|
|
( S: a1' u1' a2' u2' )
|
|
THEN
|
|
ELSE
|
|
\ Return 1 since first string is longer
|
|
DROP 2DROP 1 EXIT
|
|
THEN
|
|
ELSE
|
|
\ If u2 is also zero return 0; else return -1 since first string is shorter
|
|
-ROT 2DROP 0<> EXIT
|
|
THEN
|
|
AGAIN ;
|
|
|
|
\ Display the unsigned number at the top of the stack
|
|
: U. ( u -- "<digits>" )
|
|
\ Start with the highest place-value on the left
|
|
1000000000
|
|
\ Skip place-values that would be larger than the input
|
|
BEGIN 2DUP U< OVER 1 U> AND WHILE 10 U/ REPEAT
|
|
\ Emit the remaining digits down to the units' place
|
|
BEGIN
|
|
TUCK U/MOD [CHAR] 0 + EMIT SWAP
|
|
DUP 1 U<= IF 2DROP EXIT THEN
|
|
10 U/
|
|
AGAIN ;
|
|
|
|
\ Display the signed number at the top of the stack
|
|
: . ( n -- "<minus?><digits>" )
|
|
DUP 0< IF [CHAR] - EMIT NEGATE THEN U. ;
|
|
|
|
\ Field accessors for the search order linked list
|
|
: ORDER>LINK ( a-addr1 -- a-addr2 ) ;
|
|
: ORDER>WID ( a-addr1 -- a-addr2 ) CELL+ ;
|
|
|
|
\ When the search order is changed previously allocated entries that are not
|
|
\ currently needed will be retained on this linked list for later reuse.
|
|
VARIABLE ORDER-FREELIST
|
|
0 ORDER-FREELIST !
|
|
|
|
\ Return the current search order
|
|
: GET-ORDER ( -- widn ... wid1 n )
|
|
0 CURRENT-ORDER @
|
|
\ Traverse the linked list, placing identifiers on the return stack and counting
|
|
BEGIN ?DUP WHILE DUP ORDER>WID @ >R ORDER>LINK @ SWAP 1+ SWAP REPEAT
|
|
( S: n ) ( R: wid1 ... widn )
|
|
\ Shift the search order list from the return stack back to the data stack
|
|
DUP BEGIN ?DUP WHILE 1- R> -ROT REPEAT
|
|
( S: widn ... wid1 n )
|
|
;
|
|
|
|
\ Set the current search order
|
|
: SET-ORDER ( widn ... wid1 n | -n -- )
|
|
DUP 0< IF DROP FORTH-WORDLIST 1 THEN
|
|
\ Move all the previous search order entries to the free list
|
|
CURRENT-ORDER @
|
|
BEGIN
|
|
( S: widn ... wid1 n entry )
|
|
?DUP
|
|
WHILE
|
|
DUP ORDER>LINK @ SWAP
|
|
ORDER-FREELIST @ OVER ORDER>LINK !
|
|
ORDER-FREELIST !
|
|
REPEAT
|
|
\ Build the new search order linked list
|
|
CURRENT-ORDER SWAP
|
|
BEGIN
|
|
( S: widn ... wid1 tail n )
|
|
?DUP
|
|
WHILE
|
|
-ROT
|
|
( S: widn ... wid2 n wid1 tail )
|
|
ORDER-FREELIST @ ?DUP IF
|
|
\ Remove an entry from the free list
|
|
DUP ORDER>LINK @ ORDER-FREELIST !
|
|
ELSE
|
|
\ Allocate a new entry from the data area
|
|
ALIGN HERE 2 CELLS ALLOT
|
|
THEN
|
|
\ Update the tail pointer with the address of this entry
|
|
DUP ROT !
|
|
\ Store the word list identifier
|
|
TUCK ORDER>WID !
|
|
\ Leave the address of the link field under n-1 for the next iteration
|
|
ORDER>LINK SWAP 1-
|
|
REPEAT
|
|
\ Terminate the linked list
|
|
0 SWAP !
|
|
;
|
|
|
|
\ Create a new wordlist
|
|
\ In this implementation a word list is just a pointer to the most recent word
|
|
: WORDLIST ( -- wid )
|
|
ALIGN HERE 0 ,
|
|
;
|
|
|
|
\ Make the first list in the search order the current compilation word list
|
|
: DEFINITIONS ( -- ) GET-ORDER SWAP SET-CURRENT 1- NDROP ;
|
|
|
|
\ Run a function for each word in the given wordlist
|
|
\ xt Execution: ( i*x word-xt -- stop-flag j*x )
|
|
: WITH-WORDLIST ( i*x wid xt -- j*x )
|
|
>R @
|
|
BEGIN
|
|
?DUP
|
|
WHILE
|
|
>R 2R@ SWAP EXECUTE IF
|
|
RDROP 0
|
|
ELSE
|
|
R> >LINK @
|
|
THEN
|
|
REPEAT
|
|
RDROP ;
|
|
|
|
\ Like WITH-WORDLIST but only runs the function for visible (non-hidden) words
|
|
: WITH-VISIBLE ( x*i wid xt -- x*j )
|
|
SWAP { DUP HIDDEN? IF DROP FALSE ELSE SWAP DUP >R EXECUTE R> SWAP THEN }
|
|
WITH-WORDLIST DROP ;
|
|
|
|
\ Display the name of each visible word in the given word list
|
|
: SHOW-WORDLIST ( wid -- ) { >NAME TYPE SPACE FALSE } WITH-VISIBLE EOL ;
|
|
|
|
\ Return the number of visible words in the given word list
|
|
: COUNT-WORDLIST ( wid -- n ) 0 SWAP { DROP 1+ FALSE } WITH-VISIBLE ;
|
|
|
|
\ Look up a name in a word list and return the execution token and immediate flag
|
|
\ If the name is not found return the name with the status value 0
|
|
\ If the name is an immediate word return the execution token with status -1
|
|
\ Otherwise return the execution token with status 1
|
|
: SEARCH-WORDLIST ( c-addr u wid -- c-addr u 0 | xt 1 | xt -1 )
|
|
0 SWAP {
|
|
>R DROP 2DUP R@ >NAME COMPARE 0= IF
|
|
2DROP R> DUP IMMEDIATE? 1 OR TRUE
|
|
ELSE
|
|
RDROP 0 FALSE
|
|
THEN
|
|
} WITH-VISIBLE ;
|
|
|
|
\ Search-Order extension words
|
|
: ALSO ( -- ) GET-ORDER >R DUP R> 1+ SET-ORDER ;
|
|
: FORTH ( -- ) GET-ORDER NIP FORTH-WORDLIST SWAP SET-ORDER ;
|
|
: ONLY ( -- ) -1 SET-ORDER ;
|
|
: ORDER ( -- )
|
|
"ORDER:" TYPE GET-ORDER BEGIN ?DUP WHILE 1- SWAP SPACE . REPEAT EOL
|
|
"CURRENT: " TYPE GET-CURRENT . EOL ;
|
|
: PREVIOUS ( -- ) GET-ORDER NIP 1- SET-ORDER ;
|
|
|
|
\ Apply SEARCH-WORDLIST to each word list in the current search order
|
|
: FIND ( c-addr u -- c-addr u 0 | xt 1 | xt -1 )
|
|
2>R GET-ORDER
|
|
BEGIN
|
|
?DUP
|
|
WHILE
|
|
1- SWAP
|
|
2R> ROT SEARCH-WORDLIST
|
|
?DUP IF 2>R NDROP 2R> EXIT THEN
|
|
2>R
|
|
REPEAT
|
|
2R> 0 ;
|
|
|
|
\ ABORT needs to be deferred so that it can refer to QUIT and INTERPRET
|
|
\ The initial target of FATAL-ERROR terminates the program with SIGABRT
|
|
DEFER ABORT ( -- <noreturn> )
|
|
' FATAL-ERROR ' ABORT DEFER!
|
|
|
|
\ Same as FIND except that unknown words are reported and result in a call to ABORT
|
|
: FIND-OR-ABORT ( c-addr u -- xt 1 | xt -1 )
|
|
FIND ?DUP IF EXIT THEN
|
|
"UNKNOWN WORD: " TYPE TYPE EOL ABORT ;
|
|
|
|
\ Read a word from the input (during runtime) and return its execution token
|
|
\ Aborts if the word is not found in the current (runtime) search order list
|
|
: ' ( "<spaces>ccc" -- xt ) WORD FIND-OR-ABORT 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-ABORT 0< IF
|
|
COMPILE,
|
|
ELSE
|
|
DUP [ ' BOOTSTRAP? COMPILE, ] IF
|
|
"POSTPONE used on non-immediate bootstrap word: " TYPE TYPE EOL
|
|
[ ' BAILOUT COMPILE, ]
|
|
THEN
|
|
POSTPONE LITERAL
|
|
POSTPONE COMPILE,
|
|
THEN ;
|
|
|
|
\ Shorthand for { ' <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" -- )
|
|
' >FLAGS DUP C@ F_HIDDEN OR SWAP C! ;
|
|
|
|
\ Hide internal utility functions
|
|
HIDE ALLOT-BOUNDS
|
|
HIDE ALLOT-OOM
|
|
HIDE (DOES)
|
|
|
|
\ Abstract away the internals of the search order implementation
|
|
HIDE CURRENT
|
|
HIDE CURRENT-ORDER
|
|
HIDE ORDER-FREELIST
|
|
HIDE ORDER>WID
|
|
HIDE ORDER>LINK
|
|
|
|
\ Read a literal character string up to the next double-quote character
|
|
\ Unlike WORD the string is stored in contiguous *allocated* data space
|
|
\ The delimiting double-quote character is removed from the input buffer
|
|
\ Double-quote and backslash characters can be escaped with a backslash
|
|
: READSTRING ( "ccc<doublequote>" -- c-addr u )
|
|
HERE
|
|
BEGIN
|
|
KEY
|
|
DUP [CHAR] \ = IF
|
|
DROP KEY TRUE
|
|
ELSE
|
|
DUP [CHAR] " <>
|
|
THEN
|
|
WHILE
|
|
C,
|
|
REPEAT
|
|
DROP HERE OVER -
|
|
;
|
|
|
|
: PARSENUMBER ( c-addr u -- n TRUE | c-addr u FALSE )
|
|
DUP 0= IF FALSE EXIT THEN
|
|
2>R 2R@ DROP C@ [CHAR] - = 0
|
|
( S: neg-flag accum ) ( R: c-addr u )
|
|
OVER IF R@ 1 = IF 2DROP 2R> FALSE EXIT THEN THEN
|
|
OVER 2R@ ROT IF 1- SWAP 1+ SWAP THEN
|
|
( S: neg-flag accum c-addr' u' ) ( R: c-addr u )
|
|
BEGIN ?DUP WHILE
|
|
OVER -ROT 2>R C@ [CHAR] 0 -
|
|
( S: neg-flag accum digit ) ( R: c-addr u c-addr' u' )
|
|
DUP 9 U> IF DROP 2DROP 2RDROP 2R> FALSE EXIT THEN
|
|
SWAP 10 * + 2R>
|
|
( S: neg-flag accum' c-addr' u' ) ( R: c-addr u )
|
|
1- SWAP 1+ SWAP
|
|
REPEAT
|
|
( S: neg-flag accum c-addr' ) ( R: c-addr u )
|
|
2RDROP DROP SWAP IF NEGATE THEN
|
|
TRUE
|
|
;
|
|
|
|
\ Read a word, number, or string and either execute it or compile it
|
|
\ The stack effect depends on the input and the current value of STATE
|
|
: INTERPRET ( i*x "<spaces>ccc" -- j*x )
|
|
SKIPSPACE
|
|
KEY
|
|
[CHAR] " = IF
|
|
STATE @ IF
|
|
POSTPONE LITSTRING
|
|
HERE 0 C,
|
|
READSTRING NIP SWAP C! ALIGN
|
|
ELSE
|
|
READSTRING
|
|
THEN
|
|
ELSE
|
|
PUTBACK 64 ALLOT WORD -64 ALLOT
|
|
PARSENUMBER IF
|
|
STATE @ IF
|
|
POSTPONE LITERAL
|
|
THEN
|
|
ELSE
|
|
FIND-OR-ABORT
|
|
\ -1 => immediate word; execute regardless of STATE
|
|
\ 1 => read STATE; compile if true, execute if false
|
|
0< IF EXECUTE EXIT THEN
|
|
STATE @ IF COMPILE, EXIT THEN
|
|
EXECUTE
|
|
THEN
|
|
THEN ;
|
|
|
|
\ Comments; ignore all characters until the next EOL or ) character, respectively
|
|
: \ ( "ccc<eol>" -- ) IMMEDIATE BEGIN KEY LF = UNTIL ;
|
|
: ( ( "ccc<closeparen>" -- ) IMMEDIATE BEGIN KEY [CHAR] ) = UNTIL ;
|
|
|
|
\ Empty the return stack and enter interpretation state
|
|
: QUIT ( -- <noreturn> ) R0 RSP! FALSE STATE ! BEGIN INTERPRET AGAIN ;
|
|
|
|
\ Redefine ABORT as a non-deferred word; update deferred references to point here
|
|
\ Empty the data stack and then perform the function of QUIT without any message
|
|
' ABORT
|
|
HIDE ABORT
|
|
: ABORT ( -- <noreturn> ) S0 SP! QUIT ;
|
|
' ABORT SWAP DEFER!
|
|
|
|
\ Remove the bootstrap word list from the search order
|
|
\ Switch to the interpreter defined in this startup file
|
|
FORTH-WORDLIST 1 SET-ORDER
|
|
DEFINITIONS
|
|
QUIT
|
|
|
|
\ *****************************************************************************
|
|
\ Bootstrapping is complete
|
|
\ From this point on we only execute threaded FORTH words defined in this file
|
|
\ *****************************************************************************
|
|
|
|
\ Return the number of words on the data stack
|
|
: DEPTH ( -- n ) SP@ S0 SWAP - CELL / ;
|
|
|
|
\ Display the content of the data stack
|
|
: .DS ( -- "<text>" )
|
|
SP@ S0
|
|
CELL - 2DUP > IF 2DROP EXIT THEN DUP @ .
|
|
BEGIN
|
|
CELL - 2DUP > IF 2DROP EXIT THEN DUP @ SPACE .
|
|
AGAIN ;
|
|
|
|
\ Display the content of the return stack
|
|
: .RS ( -- "<text>" )
|
|
\ Skip the topmost cell, which is the return address for the call to .RS
|
|
RSP@ CELL + R0
|
|
CELL - 2DUP > IF 2DROP EXIT THEN DUP @ .
|
|
BEGIN
|
|
CELL - 2DUP > IF 2DROP EXIT THEN DUP @ SPACE .
|
|
AGAIN ;
|
|
|
|
\ Attempt to locate a visible word whose execution token matches the given address
|
|
\ If found return the word name and TRUE; otherwise just return FALSE
|
|
: LOOKUP ( addr -- c-addr u TRUE | FALSE )
|
|
>R
|
|
GET-ORDER
|
|
BEGIN
|
|
?DUP
|
|
WHILE
|
|
1- SWAP R@ FALSE ROT
|
|
( S: widn ... wid1 n addr FALSE wid ) ( R: addr )
|
|
{ ( addr FALSE xt -- addr FALSE FALSE | c-addr u TRUE TRUE )
|
|
NIP OVER = IF
|
|
>NAME TRUE
|
|
ELSE
|
|
FALSE
|
|
THEN DUP } WITH-VISIBLE
|
|
?DUP IF RDROP EXIT THEN
|
|
DROP
|
|
REPEAT
|
|
RDROP FALSE ;
|
|
|
|
\ Display the top of the stack as a word name if possible, or a number otherwise
|
|
\ Words with zero-length names (e.g. from :NONAME) are displayed as numbers
|
|
: .W ( addr -- "<name>" | "<digits>" )
|
|
DUP LOOKUP IF TYPE DROP ELSE . THEN ;
|
|
|
|
\ Display the first `u` words in the body of the given execution token with .W
|
|
: UNTHREAD ( xt u -- )
|
|
SWAP >DFA @ SWAP
|
|
BEGIN
|
|
?DUP
|
|
WHILE
|
|
SWAP DUP @ .W SPACE
|
|
CELL + SWAP 1-
|
|
REPEAT
|
|
DROP
|
|
;
|
|
|
|
: BANNER "JumpForth version " TYPE VERSION . ", by Jesse McDonald" TYPE EOL ;
|
|
|
|
BANNER
|