1369 lines
45 KiB
Forth
1369 lines
45 KiB
Forth
\ 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 or clear the HIDDEN flag for word with the given execution token
|
|
: (HIDE) ( xt -- ) >FLAGS DUP C@ F_HIDDEN OR SWAP C! ;
|
|
: (UNHIDE) ( xt -- ) >FLAGS DUP C@ F_HIDDEN INVERT AND SWAP C! ;
|
|
|
|
\ QUIT needs to be deferred so that it can refer to INTERPRET
|
|
DEFER QUIT ( -- <noreturn> )
|
|
' BAILOUT ' QUIT DEFER!
|
|
|
|
\ Standard (ANS FORTH) THROW code assignments (-255 ... -1)
|
|
-1 CONSTANT EXCP-ABORT
|
|
-2 CONSTANT EXCP-FAIL
|
|
-3 CONSTANT EXCP-STACK-OVERFLOW
|
|
-4 CONSTANT EXCP-STACk-UNDERFLOW
|
|
-5 CONSTANT EXCP-RETURN-OVERFLOW
|
|
-6 CONSTANT EXCP-RETURN-UNDERFLOW
|
|
-8 CONSTANT EXCP-DICTIONARY-OVERFLOW
|
|
-13 CONSTANT EXCP-UNDEFINED-WORD
|
|
-24 CONSTANT EXCP-BAD-NUMERIC-ARGUMENT
|
|
-37 CONSTANT EXCP-FILE-IO
|
|
|
|
\ Non-standard system error codes (-4095 ... -256)
|
|
-256 CONSTANT EXCP-HEAP-OVERFLOW
|
|
|
|
\ THROWN-STRING holds the address and size of the string passed to FAIL
|
|
\ It may also be used to hold context strings for other system exception codes
|
|
CREATE THROWN-STRING 0 , 0 ,
|
|
|
|
\ This is called by THROW when n is nonzero
|
|
\ The initial value (DEFAULT-UNWIND) performs the function of ABORT
|
|
\ CATCH saves and restores the current target and substitutes its own version
|
|
DEFER THROW-UNWIND ( k*x n -- i*x <noreturn> )
|
|
|
|
\ If n is nonzero, return control to the nearest CATCH on the return stack
|
|
\ If there is no CATCH, perform the function of ABORT (clear data stack and QUIT)
|
|
\ Absent CATCH, whether a message is displayed depends on the value of n:
|
|
\ -1 (ABORT) no message
|
|
\ -2 (FAIL) the string passed to THROW-STRING
|
|
\ otherwise message is implementation-dependent
|
|
: THROW-STRING ( k*x n c-addr u -- k*x | i*x n <noreturn> )
|
|
THROWN-STRING 2!
|
|
?DUP IF THROW-UNWIND THEN ;
|
|
|
|
\ Same but without the string (default to zero-length)
|
|
: THROW ( k*x n c-addr u -- k*x | i*x n <noreturn> )
|
|
0 0 THROW-STRING ;
|
|
|
|
\ By default, clear the data stack and QUIT without any message
|
|
\ This behavior can be overridden with CATCH
|
|
: ABORT ( i*x -- ) ( R: j*x -- ) EXCP-ABORT THROW ;
|
|
|
|
\ Display a message and ABORT
|
|
\ This behavior can be overridden with CATCH
|
|
: FAIL ( c-addr u -- <none> | <noreturn> )
|
|
EXCP-FAIL -ROT THROW-STRING ;
|
|
|
|
\ If flag is non-zero, display a message and ABORT
|
|
\ This behavior can be overridden with CATCH
|
|
: ?FAIL ( flag c-addr u -- <none> | <noreturn> )
|
|
ROT IF FAIL ELSE 2DROP 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 ;
|
|
|
|
\ Decrement the array size and increment the address by the same amount
|
|
: DROP-PREFIX ( c-addr u1 u2 -- c-addr+u2 u1-u2 ) TUCK - -ROT + SWAP ;
|
|
|
|
\ Write a character array to the given file descriptor
|
|
\ Repeat write syscall until entire string is written
|
|
\ Abandon output on any error other than EINTR
|
|
: TYPE-FD ( c-addr u fd -- "ccc" )
|
|
>R
|
|
BEGIN
|
|
?DUP
|
|
WHILE
|
|
2DUP R@ -ROT SYS_WRITE SYSCALL3
|
|
DUP 0<= IF
|
|
ERRNO_EINTR NEGATE <> IF
|
|
2DROP RDROP EXIT
|
|
THEN
|
|
ELSE
|
|
DROP-PREFIX
|
|
THEN
|
|
REPEAT
|
|
DROP RDROP ;
|
|
|
|
\ Specializations for output to stdout and stderr
|
|
: TYPE ( c-addr u -- "ccc" ) STDOUT TYPE-FD ;
|
|
: TYPE-ERR ( c-addr u -- "ccc" ) STDERR TYPE-FD ;
|
|
|
|
\ Get and set the current compilation word list
|
|
: GET-CURRENT ( -- wid ) CURRENT @ ;
|
|
: SET-CURRENT ( wid -- ) CURRENT ! ;
|
|
' CURRENT (HIDE)
|
|
|
|
\ 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 @ ;
|
|
|
|
\ 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 ! ;
|
|
|
|
\ Convert from a double-cell signed number to a single-cell signed number
|
|
: D>S ( d -- n ) DROP ;
|
|
|
|
\ Separate the division and modulus operators
|
|
: /MOD ( n1 n2 -- n1%n2 n1/n2 ) >R S>D R> FM/MOD D>S ;
|
|
: / ( n1 n2 -- n1/n2 ) >R S>D R> FM/MOD D>S NIP ;
|
|
: MOD ( n1 n2 -- n1%n2 ) >R S>D R> FM/MOD 2DROP ;
|
|
|
|
\ Single-cell unsigned division and modulus
|
|
: U/MOD ( u1 u2 -- u1%u2 u1/u2 ) 0 SWAP UM/MOD DROP ;
|
|
: U/ ( u1 u2 -- u1/u2 ) 0 SWAP UM/MOD DROP NIP ;
|
|
: UMOD ( u1 u2 -- u1%u2 ) 0 SWAP UM/MOD 2DROP ;
|
|
|
|
\ Symmetric division and remainder
|
|
: SM/REM ( d1 n1 -- d1%n1 d1/n1 )
|
|
DUP >R FM/MOD DUP IF OVER 0< IF 1+ SWAP R> - SWAP ELSE RDROP THEN THEN ;
|
|
|
|
\ Signed minimum and maximum
|
|
: MIN 2DUP > IF NIP ELSE DROP THEN ;
|
|
: MAX 2DUP < IF NIP ELSE DROP THEN ;
|
|
|
|
\ Unsigned minimum and maximum
|
|
: UMIN 2DUP U> IF NIP ELSE DROP THEN ;
|
|
: UMAX 2DUP U< IF NIP ELSE DROP THEN ;
|
|
|
|
\ Return -1, 0, or 1 if n is respectively negative, zero, or positive
|
|
: SIGNUM ( n -- -1 | 0 | 1 ) DUP IF 0< 2 * 1+ THEN ;
|
|
|
|
\ Double-cell versions of standard numeric words
|
|
: DABS ( d -- +d ) 2DUP D0< IF DNEGATE THEN ;
|
|
: DMIN ( d1 d2 -- d1|d2 ) 2OVER 2OVER D> IF 2SWAP THEN 2DROP ;
|
|
: DMAX ( d1 d2 -- d1|d2 ) 2OVER 2OVER D< IF 2SWAP THEN 2DROP ;
|
|
: DUMIN ( ud1 ud2 -- ud1|ud2 ) 2OVER 2OVER DU> IF 2SWAP THEN 2DROP ;
|
|
: DUMAX ( ud1 ud2 -- ud1|ud2 ) 2OVER 2OVER DU< IF 2SWAP THEN 2DROP ;
|
|
: DSIGNUM ( d -- -1 | 0 | 1 ) 2DUP D0= IF DROP ELSE D0< 2 * 1+ THEN ;
|
|
|
|
\ 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 ;
|
|
|
|
80 CONSTANT PNO-BUFFER-BYTES
|
|
CREATE PNO-BUFFER PNO-BUFFER-BYTES ALLOT
|
|
PNO-BUFFER PNO-BUFFER-BYTES + CONSTANT PNO-BUFFER-END
|
|
CREATE PNO-POINTER PNO-BUFFER-END ,
|
|
|
|
: <# ( -- ) PNO-BUFFER-END PNO-POINTER ! ;
|
|
: HOLD ( char -- ) PNO-POINTER 1 OVER -! @ C! ;
|
|
: #> ( xd -- c-addr u ) 2DROP PNO-BUFFER-END PNO-POINTER @ TUCK - ;
|
|
|
|
' PNO-BUFFER (HIDE)
|
|
' PNO-BUFFER-END (HIDE)
|
|
' PNO-POINTER (HIDE)
|
|
|
|
: SIGN ( n -- ) 0< IF [CHAR] - HOLD THEN ;
|
|
|
|
: #B ( ud1 u -- ud2 )
|
|
UM/MOD ROT DUP 10 >= IF
|
|
10 - [CHAR] A +
|
|
ELSE
|
|
[CHAR] 0 +
|
|
THEN HOLD ;
|
|
|
|
: # ( ud1 -- ud2 ) 10 #B ;
|
|
|
|
: #SB ( ud u -- )
|
|
>R BEGIN R@ #B 2DUP D0= UNTIL RDROP ;
|
|
|
|
: #S ( ud -- ) 10 #SB ;
|
|
|
|
\ Display the unsigned number at the top of the stack
|
|
: DU. ( ud -- "<digits>" ) <# #S #> TYPE ;
|
|
: U. ( u -- "<digits>" ) 0 DU. ;
|
|
|
|
\ Display the signed number at the top of the stack
|
|
: D. ( d -- "<minus?><digits>" ) DUP -ROT DABS <# #S ROT SIGN #> TYPE ;
|
|
: . ( n -- "<minus?><digits>" ) S>D D. ;
|
|
|
|
\ 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 @ ;
|
|
|
|
\ When growing the data area, round the end address up to a multiple of this size
|
|
65536 CONSTANT DATA-SEGMENT-ALIGNMENT
|
|
|
|
\ Allocate n consecutive bytes from the end of the data area
|
|
\ If necessary use the brk system call to grow the data area
|
|
\ The value n can be negative to release the most recently allocated space
|
|
: ALLOT ( n -- )
|
|
DUP 0< IF
|
|
DUP C0 HERE - < IF EXCP-BAD-NUMERIC-ARGUMENT THROW THEN
|
|
ELSE
|
|
DUP HERE INVERT U> IF EXCP-DICTIONARY-OVERFLOW THROW THEN
|
|
THEN
|
|
HERE + DUP BRK @ U> IF
|
|
[ DATA-SEGMENT-ALIGNMENT 1- ] LITERAL 2DUP + SWAP INVERT AND
|
|
DUP
|
|
SYS_BRK SYSCALL1
|
|
OVER <> IF EXCP-DICTIONARY-OVERFLOW THROW THEN
|
|
BRK !
|
|
THEN
|
|
CP !
|
|
;
|
|
|
|
\ Allocate one character from the data area and fill it with the value on the stack
|
|
: C, HERE 1 ALLOT C! ;
|
|
|
|
\ Allocate one cell from the data area and fill it with the value on the stack
|
|
: , HERE CELL ALLOT ! ;
|
|
|
|
\ Allocate two cells from the data area and fill them with the values on the stack
|
|
: 2, HERE [ 2 CELLS ] LITERAL ALLOT 2! ;
|
|
|
|
\ Allocate bytes from the data area (less than one cell) to cell-align the address
|
|
: 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 LITSTRING xt and a copy of the string passed on the stack.
|
|
: SLITERAL ( Compilation: c-addr1 u -- ) ( Runtime: -- c-addr2 u ) IMMEDIATE
|
|
POSTPONE LITSTRING DUP C, HERE SWAP DUP ALLOT CMOVE ALIGN ;
|
|
|
|
: 2LITERAL ( Compilation: x1 x2 -- ) ( Runtime: -- x1 x2 ) IMMEDIATE
|
|
POSTPONE 2LIT 2, ;
|
|
|
|
\ 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 (UNHIDE) ;
|
|
|
|
\ 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 ;
|
|
|
|
\ 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 BEGIN ?DUP WHILE 1- SWAP POSTPONE THEN REPEAT ;
|
|
|
|
\ 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 IMMEDIATE
|
|
POSTPONE 2R> POSTPONE (+LOOP) POSTPONE 2>R
|
|
POSTPONE UNTIL POSTPONE 2RDROP ;
|
|
' (+LOOP) (HIDE)
|
|
: LOOP IMMEDIATE 1 POSTPONE LITERAL POSTPONE +LOOP ;
|
|
|
|
\ 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 ;
|
|
|
|
\ This function defines what happens when THROW is used outside of any CATCH
|
|
: DEFAULT-UNWIND ( k*x n -- i*x <noreturn> )
|
|
CASE
|
|
EXCP-ABORT OF ENDOF
|
|
EXCP-FAIL OF
|
|
THROWN-STRING 2@ TYPE-ERR "\n" TYPE-ERR
|
|
ENDOF
|
|
EXCP-DICTIONARY-OVERFLOW OF
|
|
"Dictionary overflow\n" TYPE-ERR
|
|
ENDOF
|
|
EXCP-UNDEFINED-WORD OF
|
|
"Undefined word: " TYPE-ERR THROWN-STRING 2@ TYPE-ERR "\n" TYPE-ERR
|
|
ENDOF
|
|
EXCP-FILE-IO OF
|
|
"I/O error\n" TYPE-ERR
|
|
ENDOF
|
|
"Uncaught exception: " TYPE-ERR
|
|
DUP DUP S>D DABS <# #S ROT SIGN #> TYPE-ERR EOL
|
|
ENDCASE
|
|
S0 SP! QUIT ;
|
|
|
|
' DEFAULT-UNWIND ' THROW-UNWIND DEFER!
|
|
' DEFAULT-UNWIND (HIDE)
|
|
|
|
\ Copy the bootstrap SOURCE values into variables to allow changing the input buffer
|
|
SOURCE
|
|
CREATE INPUT-BUFFER-SIZE ,
|
|
CREATE INPUT-BUFFER ,
|
|
|
|
\ 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 @ INPUT-BUFFER-SIZE @ ;
|
|
: 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 ;
|
|
|
|
: PARSE-AREA ( -- c-addr u ) SOURCE >IN @ DROP-PREFIX ;
|
|
|
|
: PARSE-EMPTY? ( -- flag ) SOURCE NIP >IN @ = ;
|
|
|
|
: PEEK-CHAR ( -- c )
|
|
PARSE-AREA 0= "Unexpected end of input" ?FAIL 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 ! ;
|
|
|
|
' (DOES) (HIDE)
|
|
|
|
: (MARK) TYPE ": " TYPE .DS EOL ;
|
|
: MARK IMMEDIATE WORD POSTPONE SLITERAL POSTPONE (MARK) ;
|
|
' (MARK) (HIDE)
|
|
|
|
\ 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 (HIDE) DOCOL SWAP >CFA ! POSTPONE ] ;
|
|
|
|
\ End a definition by appending EXIT and leaving compilation mode
|
|
\ Unhide the name if it isn't empty (e.g. from :NONAME)
|
|
: ; ( -- ) IMMEDIATE
|
|
POSTPONE EXIT POSTPONE [ LATEST DUP >NAME NIP IF (UNHIDE) ELSE DROP THEN ;
|
|
|
|
\ 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 ! ;
|
|
|
|
\ Same for double-cell constants; no DFA trick this time
|
|
: 2CONSTANT : POSTPONE 2LITERAL POSTPONE ; ;
|
|
|
|
\ 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 , ;
|
|
|
|
\ Same for double-cell variables (two-variables)
|
|
: 2VARIABLE CREATE [ 0 0 ] 2LITERAL 2, ;
|
|
|
|
\ 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 , DOLOAD LATEST >CFA ! ;
|
|
|
|
\ Define an array of n single-cell elements
|
|
\ name Runtime: ( n -- a-addr ) Return the address of the cell at index n
|
|
: ARRAY ( n "<spaces>name" -- )
|
|
CREATE CELLS ALLOT DOES> SWAP [ CELL ] LITERAL * + ;
|
|
|
|
\ Define an array of n double-cell elements
|
|
\ name Runtime: ( n -- a-addr ) Return the address of the double-cell at index n
|
|
: 2ARRAY ( n "<spaces>name" -- )
|
|
CREATE CELLS 2* ALLOT DOES> SWAP [ 2 CELLS ] LITERAL * + ;
|
|
|
|
\ Define a threaded word which also displays its name and the data stack when called
|
|
: (TRACE) >NAME TYPE SPACE .DS EOL ;
|
|
: :TRACE : LATEST POSTPONE LITERAL POSTPONE (TRACE) ;
|
|
' (TRACE) (HIDE)
|
|
|
|
\ 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+ , LATEST , F_HIDDEN C,
|
|
DUP GET-CURRENT ! ALIGN POSTPONE ] ;
|
|
|
|
\ Fetch and store the target of the deferred word denoted by deferred-xt
|
|
\ Note that this DEFER! can turn any word into a deferred word
|
|
: DEFER@ ( deferred-xt -- xt ) >DFA @ ;
|
|
: DEFER! ( xt deferred-xt -- ) DODEFER OVER >CFA ! >DFA ! ;
|
|
|
|
\ Create a deferred word; the target is stored in the DFA field
|
|
\ The default target throws an exception — replace it using DEFER! or IS
|
|
: (DEFERRED-UNINIT) "Uninitialized deferred word" FAIL ;
|
|
: DEFER ( "<spaces>ccc" -- )
|
|
CREATE ['] (DEFERRED-UNINIT) LATEST DEFER! ;
|
|
' (DEFERRED-UNINIT) (HIDE)
|
|
|
|
\ 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. If RECURSE is used in <code>
|
|
\ it will create a recursive call to the anonymous inner function. In the word
|
|
\ list, after the }, the inner definition is ordered before the outer definition.
|
|
\ LATEST always refers to the innermost enclosing definition.
|
|
\
|
|
\ Example:
|
|
\ > : TIMES 0 DO DUP EXECUTE LOOP DROP ;
|
|
\ > : GREETINGS { "Hello" TYPE EOL } 3 TIMES ;
|
|
\ > GREETINGS
|
|
\ Hello
|
|
\ Hello
|
|
\ Hello
|
|
\
|
|
\ Compilation effect: ( C: -- outer-xt orig inner-xt state )
|
|
\ Interpreter effect: ( S: -- inner-xt state )
|
|
\ Enters compilation mode if not already compiling
|
|
: { ( -- {outer-xt orig} inner-xt state ) IMMEDIATE
|
|
STATE @
|
|
DUP IF
|
|
LATEST
|
|
DUP >LINK @ GET-CURRENT !
|
|
0 OVER >LINK !
|
|
POSTPONE AHEAD
|
|
ROT
|
|
POSTPONE [
|
|
THEN
|
|
:NONAME SWAP ;
|
|
|
|
\ Leave compilation mode if STATE was 0 before { was executed
|
|
\ Otherwise:
|
|
\ Resolve the forward branch over the inner function
|
|
\ Add outer-xt back to the word list after inner-xt
|
|
\ Generate a literal for inner-xt
|
|
: } ( {outer-xt orig} inner-xt state -- {inner-xt} ) IMMEDIATE
|
|
POSTPONE ;
|
|
IF
|
|
( S: outer-xt orig inner-xt )
|
|
\ Resolve the forward branch over the inner definition
|
|
-ROT POSTPONE THEN
|
|
\ Re-append the outer definition to the word list
|
|
LATEST OVER >LINK ! GET-CURRENT !
|
|
\ Return to compilation mode (was ended by ; )
|
|
POSTPONE ]
|
|
\ Compile inner-xt as a literal in the outer definition
|
|
POSTPONE LITERAL
|
|
\ ELSE ( nothing to do )
|
|
( S: inner-xt )
|
|
THEN ;
|
|
|
|
4096 CONSTANT PAGESIZE
|
|
|
|
0 CONSTANT PROT_NONE
|
|
1 CONSTANT PROT_READ
|
|
2 CONSTANT PROT_WRITE
|
|
4 CONSTANT PROT_EXEC
|
|
|
|
2 CONSTANT MAP_PRIVATE
|
|
32 CONSTANT MAP_ANONYMOUS
|
|
|
|
32 CONSTANT BUDDY-MIN-BYTES
|
|
18 CONSTANT BUDDY-ORDERS
|
|
: BUDDY-ORDER-BYTES ( order -- n-bytes ) BUDDY-MIN-BYTES SWAP LSHIFT ;
|
|
BUDDY-ORDERS 1- BUDDY-ORDER-BYTES CONSTANT BUDDY-MAX-BYTES
|
|
|
|
BUDDY-ORDERS ARRAY BUDDY-HEADS
|
|
|
|
: INIT-BUDDY-HEADS ( -- )
|
|
BUDDY-ORDERS 0 DO 0 I BUDDY-HEADS ! LOOP ;
|
|
|
|
INIT-BUDDY-HEADS
|
|
|
|
: BUDDY-FREE ( order a-addr -- )
|
|
OVER BUDDY-ORDERS U>= "order out of bounds" ?FAIL
|
|
2DUP SWAP BUDDY-ORDER-BYTES 1- AND "address is not naturally aligned" ?FAIL
|
|
>R DUP BUDDY-HEADS
|
|
BEGIN
|
|
( S: order head-addr ) ( R: a-addr )
|
|
DUP @
|
|
DUP 0= IF
|
|
\ Append to end of list
|
|
DROP 0 R@ ! R> SWAP !
|
|
DROP EXIT
|
|
THEN
|
|
( S: order head-addr block-addr ) ( R: freed-addr )
|
|
2 PICK 1+ BUDDY-ORDERS < AND-THEN
|
|
DUP 3 PICK BUDDY-ORDER-BYTES XOR R@ = AND-THEN
|
|
\ Found the buddy on the free list; coalesce
|
|
@ SWAP !
|
|
\ Pick the lower (naturally aligned) block address
|
|
DUP BUDDY-ORDER-BYTES INVERT R> AND >R
|
|
\ Repeat process with the next-higher order
|
|
1+ DUP BUDDY-HEADS TRUE
|
|
THEN
|
|
THEN 0= IF
|
|
\ Insert before first item with address >= this addr
|
|
DUP R@ U>= IF R@ ! R> SWAP ! DROP EXIT THEN
|
|
\ Otherwise advance to next block
|
|
NIP
|
|
THEN
|
|
AGAIN ;
|
|
|
|
: BUDDY-ALLOCATE ( order -- a-addr ) RECURSIVE
|
|
DUP BUDDY-ORDERS U>= "order out of bounds" ?FAIL
|
|
DUP BUDDY-HEADS @ ?DUP IF DUP @ ROT BUDDY-HEADS ! EXIT THEN
|
|
DUP 1+ BUDDY-ORDERS >= IF EXCP-HEAP-OVERFLOW THROW THEN
|
|
DUP 1+ BUDDY-ALLOCATE SWAP 2DUP BUDDY-ORDER-BYTES + BUDDY-FREE ;
|
|
|
|
: BUDDY-ORDER-FROM-BYTES ( u-bytes -- order )
|
|
DUP 0= OR-ELSE DUP DUP 1- AND 0<> THEN
|
|
"buddy allocator block size is not a power of two" ?FAIL
|
|
DUP BUDDY-MIN-BYTES - [ BUDDY-MAX-BYTES BUDDY-MIN-BYTES - ] LITERAL U>
|
|
"buddy allocator block size out of bounds" ?FAIL
|
|
BUDDY-MIN-BYTES / 0 SWAP BEGIN 2/ ?DUP 0<> WHILE SWAP 1+ SWAP REPEAT ;
|
|
|
|
: BUDDY-COUNT BUDDY-HEADS @ 0 SWAP BEGIN ?DUP WHILE @ SWAP 1+ SWAP REPEAT ;
|
|
|
|
VARIABLE TOTAL
|
|
: BUDDY-STATS ( -- )
|
|
0 TOTAL !
|
|
BUDDY-ORDERS 0 DO
|
|
I BUDDY-COUNT ?DUP IF
|
|
DUP I BUDDY-ORDER-BYTES * TOTAL +!
|
|
. "x" TYPE I BUDDY-ORDER-BYTES . SPACE
|
|
THEN
|
|
LOOP "total " TYPE TOTAL @ . EOL ;
|
|
' TOTAL (HIDE)
|
|
|
|
: NATURALLY-ALIGNED ( u1 -- u2 )
|
|
1- DUP U2/ OR DUP 2 RSHIFT OR DUP 4 RSHIFT OR DUP 8 RSHIFT OR DUP 16 RSHIFT OR 1+ ;
|
|
|
|
: ALIGNED-TO ( addr1 u -- addr2 )
|
|
NATURALLY-ALIGNED TUCK 1- + SWAP NEGATE AND ;
|
|
|
|
: ALIGN-TO ( u -- )
|
|
HERE SWAP ALIGNED-TO HERE - ALLOT ;
|
|
|
|
0 CONSTANT NULL
|
|
: KB 10 LSHIFT ;
|
|
: MB 20 LSHIFT ;
|
|
|
|
: ALLOCATE ( size -- a-addr )
|
|
CELL+ DUP BUDDY-MAX-BYTES U> IF
|
|
MARK A
|
|
BEGIN
|
|
NULL OVER PROT_READ PROT_WRITE OR
|
|
MAP_PRIVATE MAP_ANONYMOUS OR -1 0 SYS_MMAP2 SYSCALL6
|
|
DUP -4095 U>=
|
|
WHILE
|
|
NEGATE ERRNO_EINTR <> IF EXCP-HEAP-OVERFLOW THROW THEN
|
|
REPEAT
|
|
TUCK ! CELL+ EXIT
|
|
THEN
|
|
MARK B
|
|
NATURALLY-ALIGNED DUP BUDDY-MIN-BYTES U< IF DROP BUDDY-MIN-BYTES THEN
|
|
BUDDY-ORDER-FROM-BYTES DUP BUDDY-ALLOCATE SWAP OVER ! CELL+ ;
|
|
|
|
: FREE ( a-addr -- )
|
|
CELL- DUP @
|
|
DUP BUDDY-ORDERS U< IF SWAP BUDDY-FREE EXIT THEN
|
|
BEGIN
|
|
2DUP SYS_MUNMAP SYSCALL2 ?DUP 0= IF 2DROP EXIT THEN
|
|
NEGATE ERRNO_EINTR <> "munmap failed" ?FAIL
|
|
AGAIN ;
|
|
|
|
\ 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 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 !
|
|
;
|
|
|
|
\ 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) ;
|
|
|
|
\ Begin a new colon definition; hide & redirect the previous word
|
|
\ with the same name to the new definition
|
|
: :REPLACE ( "<spaces>ccc" -- )
|
|
: LATEST DUP >NAME FIND-OR-THROW DROP DUP (HIDE) DEFER! ;
|
|
|
|
\ The size of this buffer will determine the maximum line length
|
|
4096 CONSTANT TERMINAL-BUFFER-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 ,
|
|
|
|
: 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 INPUT-BUFFER !
|
|
DUP INPUT-BUFFER-SIZE !
|
|
DUP IF 0 >IN ! THEN
|
|
0<> ;
|
|
|
|
HIDE TIB-LEFTOVER
|
|
HIDE TIB-LEFTOVER-SIZE
|
|
HIDE TERMINAL-BUFFER
|
|
|
|
: 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" FAIL
|
|
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-THROW
|
|
\ -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 ;
|
|
|
|
DEFER SHOW-PROMPT
|
|
{ "> " TYPE } IS SHOW-PROMPT
|
|
|
|
\ Redefine QUIT as a non-deferred word; update deferred references to point here
|
|
\ Empty the return stack, make stdin the input source, and enter interpretation state
|
|
:REPLACE QUIT ( -- <noreturn> )
|
|
R0 RSP!
|
|
0 CURRENT-SOURCE-ID !
|
|
FALSE STATE !
|
|
BEGIN
|
|
SHOW-PROMPT
|
|
REFILL 0= IF
|
|
EOL BYE
|
|
THEN
|
|
INTERPRET
|
|
STATE @ 0= IF
|
|
"OK\n" 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 DROP ;
|
|
|
|
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> ['] THROW-UNWIND DEFER!
|
|
R> CURRENT-SOURCE-ID !
|
|
2R> INPUT-BUFFER-SIZE ! INPUT-BUFFER !
|
|
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
|
|
|
|
HIDE CURRENT-SOURCE-ID
|
|
HIDE INPUT-BUFFER
|
|
HIDE INPUT-BUFFER-SIZE
|
|
|
|
HIDE (HIDE)
|
|
HIDE (UNHIDE)
|
|
|
|
HIDE ESCAPED-CHAR
|
|
HIDE READSTRING
|
|
HIDE PARSENUMBER
|
|
|
|
\ Switch to the interpreter defined in this startup file
|
|
{ R0 RSP! BEGIN INTERPRET AGAIN } EXECUTE
|
|
HIDE INTERPRET
|
|
|
|
\ Remove the bootstrap word list from the search order
|
|
HIDE BOOTSTRAP-WORDLIST
|
|
FORTH-WORDLIST 1 SET-ORDER
|
|
DEFINITIONS
|
|
|
|
\ *****************************************************************************
|
|
\ 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 ;
|
|
|
|
\ Read one cell and increment
|
|
: @(+) ( a-addr1 -- a-addr2 x ) DUP CELL+ SWAP @ ;
|
|
|
|
\ Display a string in escaped (double-quoted) format, without the delimiters
|
|
: TYPE-ESCAPED ( c-addr u -- "<escapeseq*>" )
|
|
0 DO DUP 1+ SWAP C@ CASE
|
|
0 OF "\\0" TYPE ENDOF
|
|
7 OF "\\a" TYPE ENDOF
|
|
8 OF "\\b" TYPE ENDOF
|
|
9 OF "\\t" TYPE ENDOF
|
|
10 OF "\\n" TYPE ENDOF
|
|
11 OF "\\v" TYPE ENDOF
|
|
12 OF "\\f" TYPE ENDOF
|
|
13 OF "\\r" TYPE ENDOF
|
|
[CHAR] " OF "\\\"" TYPE ENDOF
|
|
\ escape sequence not needed in strings
|
|
\ [CHAR] ' OF "\\\'" TYPE ENDOF
|
|
[CHAR] \ OF "\\\\" TYPE ENDOF
|
|
DUP 32 < OR-ELSE DUP 127 = THEN IF
|
|
"⌷" TYPE
|
|
ELSE
|
|
DUP EMIT
|
|
THEN
|
|
ENDCASE LOOP DROP ;
|
|
|
|
\ Recognize the pattern BRANCH a:{c-a} b:{word} {code…} c:LIT d:{b}
|
|
\ This pattern is generated by the { … } inline :NONAME syntax
|
|
: NONAME-LITERAL? ( a-addr -- flag )
|
|
@(+) ['] BRANCH = AND-THEN
|
|
@(+) DUP 0> AND-THEN
|
|
( S: addr-b offset-c-a )
|
|
OVER CELL- + @(+) ['] LIT = AND-THEN
|
|
( S: addr-b addr-d )
|
|
@ OVER = AND-THEN
|
|
DUP WORD?
|
|
THEN
|
|
ELSE NIP THEN
|
|
ELSE NIP THEN
|
|
THEN NIP ;
|
|
|
|
\ Display the threaded code which starts at a-addr
|
|
\ Continues until it encounters a reference to EXIT beyond any forward branches
|
|
\ Numeric, string, and { … } literals are decoded, plus offsets for branches
|
|
: UNTHREAD ( a-addr -- ) RECURSIVE
|
|
DUP >R
|
|
BEGIN
|
|
@(+)
|
|
DUP ['] EXIT = AND-THEN OVER R@ U> THEN IF
|
|
2DROP RDROP EXIT
|
|
THEN
|
|
CASE
|
|
['] LIT OF
|
|
@(+) DUP WORD? IF "['] " TYPE .W ELSE . THEN SPACE
|
|
ENDOF
|
|
['] 2LIT OF
|
|
"[ " TYPE @(+) U. SPACE @(+) . " ] 2LITERAL " TYPE
|
|
ENDOF
|
|
['] LITSTRING OF
|
|
DUP 1+ SWAP C@ 2DUP "\"" TYPE TYPE-ESCAPED "\" " TYPE + ALIGNED
|
|
ENDOF
|
|
OVER CELL- NONAME-LITERAL? IF
|
|
DROP DUP @ OVER + 2 CELLS+ DUP R> UMAX >R SWAP
|
|
"{ " TYPE CELL+ >DFA @ UNTHREAD "} " TYPE
|
|
ELSE
|
|
DUP ['] BRANCH = OR-ELSE DUP ['] 0BRANCH = THEN IF
|
|
>NAME TYPE SPACE
|
|
@(+) DUP "{" TYPE DUP 0> IF "+" TYPE THEN . "} " TYPE
|
|
OVER CELL- + R> UMAX >R
|
|
ELSE
|
|
DUP WORD? AND-THEN DUP IMMEDIATE? THEN IF
|
|
"POSTPONE " TYPE
|
|
THEN
|
|
.W SPACE
|
|
THEN
|
|
THEN
|
|
DUP \ placeholder to be dropped by ENDCASE since we consumed the xt
|
|
ENDCASE
|
|
AGAIN ;
|
|
|
|
HIDE NONAME-LITERAL?
|
|
|
|
: SEE ( "<spaces>name" -- )
|
|
' DUP >CFA @ CASE
|
|
DOCOL OF
|
|
": " TYPE DUP >NAME TYPE " " TYPE
|
|
DUP IMMEDIATE? IF "IMMEDIATE " TYPE THEN
|
|
>DFA @ UNTHREAD ";\n" TYPE
|
|
ENDOF
|
|
DODEFER OF
|
|
"DEFER " TYPE DUP >NAME TYPE EOL
|
|
DUP >DFA @ DUP WORD? IF "' " TYPE .W ELSE U. THEN " IS " TYPE >NAME TYPE EOL
|
|
ENDOF
|
|
DODATA OF
|
|
DUP EXECUTE . " CONSTANT " TYPE >NAME TYPE EOL
|
|
ENDOF
|
|
DOLOAD OF
|
|
DUP EXECUTE . " VALUE " TYPE >NAME TYPE EOL
|
|
ENDOF
|
|
DODOES OF
|
|
"CREATE " TYPE DUP >NAME TYPE " … DOES> " TYPE
|
|
>DFA @ UNTHREAD ";\n" TYPE
|
|
ENDOF
|
|
\ Anything else can be assumed to be implemented in assembly
|
|
SWAP "CREATE " TYPE >NAME TYPE " … ;CODE … END-CODE\n" TYPE
|
|
ENDCASE ;
|
|
|
|
HIDE UNTHREAD
|
|
|
|
: BANNER "JumpForth version " TYPE VERSION . ", by Jesse McDonald\n" TYPE ;
|
|
|
|
BANNER
|
|
QUIT
|