953 lines
30 KiB
Forth
953 lines
30 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 ;
|
||
|
||
\ 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. ;
|
||
|
||
\ 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 ;
|
||
|
||
\ 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 ;
|
||
|
||
\ Short-circuit logical operators
|
||
\ Examples:
|
||
\ <cond1> AND-THEN <cond2> THEN
|
||
\ <cond1> OR-ELSE <cond2> THEN
|
||
: AND-THEN ( C: -- orig ) ( Runtime S: flag -- FALSE | <dropped> ) IMMEDIATE
|
||
POSTPONE DUP POSTPONE IF POSTPONE DROP ;
|
||
: OR-ELSE ( C: -- orig ) ( Runtime S: flag -- nonzero-flag | <dropped> ) IMMEDIATE
|
||
POSTPONE ?DUP POSTPONE 0= POSTPONE IF ;
|
||
|
||
\ 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 ;
|
||
|
||
SOURCE
|
||
CREATE INPUT-BUFFER-SIZE ,
|
||
CREATE INPUT-BUFFER ,
|
||
|
||
CREATE CURRENT-SOURCE-ID -1 ,
|
||
|
||
: SOURCE ( -- c-addr u ) INPUT-BUFFER @ INPUT-BUFFER-SIZE @ ;
|
||
: SOURCE-ID ( -- 0 | -1 | +n ) CURRENT-SOURCE-ID @ ;
|
||
|
||
: SAVE-INPUT ( -- xu ... x1 u ) >IN @ 1 ;
|
||
: RESTORE-INPUT ( xu ... x1 u -- ) OVER >IN ! NDROP ;
|
||
|
||
\ The size of this buffer will determine the maximum line length
|
||
4096 CONSTANT TERMINAL-BUFFER-SIZE
|
||
CREATE TERMINAL-BUFFER TERMINAL-BUFFER-SIZE ALLOT
|
||
|
||
CREATE TIB-LEFTOVER 0 ,
|
||
CREATE TIB-LEFTOVER-SIZE 0 ,
|
||
|
||
: 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
|
||
DROP "Error occurred while reading input\n" TYPE
|
||
FATAL-ERROR
|
||
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 INPUT-BUFFER !
|
||
DUP INPUT-BUFFER-SIZE !
|
||
DUP IF 0 >IN ! THEN
|
||
0<> ;
|
||
|
||
: DROP-PREFIX ( c-addr u1 u2 -- c-addr+u2 u1-u2 ) ROT OVER + -ROT - ;
|
||
|
||
: PARSE-AREA ( -- c-addr u ) SOURCE >IN @ DROP-PREFIX ;
|
||
|
||
: PARSE-EMPTY? ( -- flag ) SOURCE NIP >IN @ = ;
|
||
|
||
: PEEK-CHAR ( -- c )
|
||
PARSE-AREA 0= IF
|
||
DROP "Unexpected end of input\n" TYPE
|
||
FATAL-ERROR
|
||
THEN C@ ;
|
||
|
||
: SKIP-CHAR ( -- ) 1 >IN +! ;
|
||
|
||
: NEXT-CHAR ( -- c ) PEEK-CHAR SKIP-CHAR ;
|
||
|
||
: SKIPSPACE ( "<spaces?>" -- )
|
||
BEGIN
|
||
PARSE-EMPTY? 0= AND-THEN PEEK-CHAR SPACE? THEN
|
||
WHILE
|
||
SKIP-CHAR
|
||
REPEAT ;
|
||
|
||
\ Comments; ignore all characters until the next EOL or ) character, respectively
|
||
: \ ( "ccc<eol>" -- ) IMMEDIATE BEGIN NEXT-CHAR LF = UNTIL ;
|
||
: ( ( "ccc<closeparen>" -- ) IMMEDIATE BEGIN NEXT-CHAR [CHAR] ) = UNTIL ;
|
||
|
||
\ 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 )
|
||
SKIPSPACE
|
||
PARSE-AREA DROP
|
||
BEGIN
|
||
PARSE-EMPTY? OR-ELSE PEEK-CHAR SPACE? THEN 0=
|
||
WHILE
|
||
SKIP-CHAR
|
||
REPEAT
|
||
PARSE-AREA DROP OVER - ;
|
||
|
||
: CREATE ( "<spaces>ccc" -- )
|
||
ALIGN HERE
|
||
DODATA , 0 , LATEST ,
|
||
WORD DUP C, HERE SWAP DUP ALLOT CMOVE
|
||
ALIGN 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> @ ;
|
||
|
||
: (TRACE) >NAME TYPE SPACE .DS EOL ;
|
||
|
||
\ 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 ]
|
||
\ ( uncomment for tracing ) LATEST POSTPONE LITERAL POSTPONE (TRACE)
|
||
;
|
||
|
||
\ 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 ;
|
||
|
||
\ 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 0= IF "UNKNOWN WORD: " TYPE TYPE EOL ABORT 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-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
|
||
|
||
: ESCAPED-CHAR ( "<escapeseq>" | "c" -- c )
|
||
NEXT-CHAR DUP [CHAR] \ = IF
|
||
DROP NEXT-CHAR CASE
|
||
[CHAR] 0 OF 0 ENDOF
|
||
[CHAR] a OF 7 ENDOF
|
||
[CHAR] b OF 8 ENDOF
|
||
[CHAR] t OF 9 ENDOF
|
||
[CHAR] n OF 10 ENDOF
|
||
[CHAR] v OF 11 ENDOF
|
||
[CHAR] f OF 12 ENDOF
|
||
[CHAR] r OF 13 ENDOF
|
||
[CHAR] " OF [CHAR] " ENDOF
|
||
[CHAR] ' OF [CHAR] ' ENDOF
|
||
[CHAR] \ OF [CHAR] \ ENDOF
|
||
"Unknown escape sequence: \\" TYPE DUP EMIT EOL
|
||
FATAL-ERROR
|
||
ENDCASE
|
||
THEN ;
|
||
|
||
\ 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
|
||
PEEK-CHAR [CHAR] " <>
|
||
WHILE
|
||
ESCAPED-CHAR C,
|
||
REPEAT
|
||
SKIP-CHAR
|
||
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 )
|
||
BEGIN
|
||
SKIPSPACE
|
||
PARSE-EMPTY? 0=
|
||
WHILE
|
||
PEEK-CHAR [CHAR] " = IF
|
||
SKIP-CHAR
|
||
STATE @ IF
|
||
POSTPONE LITSTRING
|
||
HERE 0 C,
|
||
READSTRING NIP SWAP C! ALIGN
|
||
ELSE
|
||
READSTRING
|
||
THEN
|
||
ELSE
|
||
WORD
|
||
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< OR-ELSE STATE @ 0= THEN IF EXECUTE ELSE COMPILE, THEN
|
||
THEN
|
||
THEN
|
||
REPEAT ;
|
||
|
||
\ Empty the return stack, make stdin the input source, and enter interpretation state
|
||
: QUIT ( -- <noreturn> )
|
||
R0 RSP!
|
||
0 CURRENT-SOURCE-ID !
|
||
FALSE STATE !
|
||
BEGIN
|
||
REFILL 0= IF
|
||
EOL BYE
|
||
THEN
|
||
INTERPRET
|
||
STATE @ 0= IF
|
||
"OK> " TYPE
|
||
THEN
|
||
AGAIN ;
|
||
|
||
: EVALUATE ( i*x c-addr u -- j*x )
|
||
SAVE-INPUT N>R
|
||
SOURCE 2>R
|
||
SOURCE-ID >R
|
||
INPUT-BUFFER-SIZE !
|
||
INPUT-BUFFER !
|
||
0 >IN !
|
||
-1 CURRENT-SOURCE-ID !
|
||
INTERPRET
|
||
R> CURRENT-SOURCE-ID !
|
||
2R> INPUT-BUFFER-SIZE ! INPUT-BUFFER !
|
||
NR> RESTORE-INPUT ;
|
||
|
||
HIDE CURRENT-SOURCE-ID
|
||
HIDE INPUT-BUFFER
|
||
HIDE INPUT-BUFFER-SIZE
|
||
HIDE TERMINAL-BUFFER
|
||
HIDE TIB-LEFTOVER
|
||
HIDE TIB-LEFTOVER-SIZE
|
||
|
||
\ 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
|
||
{ R0 RSP! BEGIN INTERPRET AGAIN } EXECUTE
|
||
|
||
\ *****************************************************************************
|
||
\ 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 / ;
|
||
|
||
\ Return TRUE if the given address is the execution token of a word in
|
||
\ the current search order or compilation word list, or FALSE otherwise
|
||
\ The word's name may be hidden or shadowed by another definition
|
||
: WORD? ( addr -- flag )
|
||
>R
|
||
GET-ORDER
|
||
1+ GET-CURRENT SWAP
|
||
BEGIN
|
||
?DUP
|
||
WHILE
|
||
1- SWAP R@ FALSE ROT
|
||
( S: widn ... wid1 n addr FALSE wid ) ( R: addr )
|
||
\ Inner function: ( addr FALSE xt -- addr FALSE FALSE | addr TRUE TRUE )
|
||
{ NIP OVER = DUP } WITH-WORDLIST
|
||
NIP IF RDROP NDROP TRUE EXIT THEN
|
||
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 WORD? IF
|
||
\ Some kind of word; is the name zero-length (:NONAME)?
|
||
DUP >NAME DUP IF
|
||
\ Is the name hidden?
|
||
2 PICK HIDDEN? IF
|
||
"×" TYPE
|
||
ELSE
|
||
\ Does FIND with the same name fail to return the same word?
|
||
2DUP FIND AND-THEN 3 PICK = ELSE NIP NIP THEN 0= IF
|
||
"¤" TYPE
|
||
THEN
|
||
THEN
|
||
TYPE
|
||
DROP
|
||
ELSE
|
||
2DROP "∷" TYPE U.
|
||
THEN
|
||
ELSE
|
||
\ Not a word in the current search order or compilation word list
|
||
.
|
||
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\nOK> " TYPE ;
|
||
|
||
BANNER
|
||
QUIT
|