diff --git a/startup.4th b/startup.4th index 8e5b13b..ba8b174 100644 --- a/startup.4th +++ b/startup.4th @@ -5,7 +5,7 @@ CP @ 0 , CONSTANT LINUX-WORDLIST BOOTSTRAP-WORDLIST CONSTANT BOOTSTRAP-WORDLIST \ Use this list until we get around to defining the real GET-ORDER -: STARTUP-ORDER ( -- widn ... wid1 n ) +: STARTUP-ORDER ( -- widn ... wid1 n ) BOOTSTRAP-WORDLIST LINUX-WORDLIST UTILITY-WORDLIST @@ -17,16 +17,16 @@ BOOTSTRAP-WORDLIST CONSTANT BOOTSTRAP-WORDLIST FORTH-WORDLIST CURRENT ! \ Get and set the current compilation word list -: GET-CURRENT ( -- wid ) CURRENT @ ; -: SET-CURRENT ( wid -- ) CURRENT ! ; +: GET-CURRENT ( -- wid ) CURRENT @ ; +: SET-CURRENT ( wid -- ) CURRENT ! ; SYSTEM-WORDLIST SET-CURRENT -\ Shorthand for selecting the current compilation word list -: >>SYSTEM SYSTEM-WORDLIST SET-CURRENT ; -: >>UTILITY UTILITY-WORDLIST SET-CURRENT ; -: >>FORTH FORTH-WORDLIST SET-CURRENT ; -: >>LINUX LINUX-WORDLIST SET-CURRENT ; +\ Shorthand for selecting the current compilation word list until >> is defined +: >>SYSTEM SYSTEM-WORDLIST SET-CURRENT ; +: >>UTILITY UTILITY-WORDLIST SET-CURRENT ; +: >>FORTH FORTH-WORDLIST SET-CURRENT ; +: >>LINUX LINUX-WORDLIST SET-CURRENT ; >>FORTH @@ -35,42 +35,42 @@ SYSTEM-WORDLIST SET-CURRENT 0 CONSTANT NULL \ Unit suffixes, e.g. 4 KB ≡ 4096 (bytes) -: KB 10 LSHIFT ; -: MB 20 LSHIFT ; +: KB ( u1 -- u2 ) 10 LSHIFT ; +: MB ( u1 -- u2 ) 20 LSHIFT ; \ 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 * - ; +: CELL+ ( addr1 -- addr2 ) CELL + ; +: CELL- ( addr1 -- addr2 ) CELL - ; +: CELLS+ ( addr1 n -- addr2 ) CELL * + ; +: CELLS- ( addr1 n -- addr2 ) CELL * - ; +: CELLS ( n1 -- n2 ) CELL * ; \ Returns the least multiple of u >= the aligned u \ The alignment u must be a power of two -: ALIGNED-TO ( addr1 u -- addr2 ) +: ALIGNED-TO ( addr1 u -- addr2 ) TUCK 1- + SWAP NEGATE AND ; \ Round up to the next cell-aligned address -: ALIGNED ( addr -- a-addr ) CELL ALIGNED-TO ; +: ALIGNED ( addr -- a-addr ) CELL ALIGNED-TO ; \ Return the next address in the compilation/data area -: HERE ( -- addr ) CP @ ; +: HERE ( -- addr ) CP @ ; >>UTILITY \ Field accessors for execution tokens -: >BODY ( xt -- a-addr ) [ 2 CELLS ] LITERAL + ; -: >DFA ( xt -- a-addr ) CELL+ ; -: >CFA ( xt -- a-addr ) ; -: >LINK ( xt -- a-addr ) CELL- ; -: >FLAGS ( xt -- c-addr ) [ CELL 1+ ] LITERAL - ; -: >NAME ( xt -- c-addr u ) >FLAGS DUP C@ F_LENMASK AND TUCK - SWAP ; +: >BODY ( xt -- a-addr ) [ 2 CELLS ] LITERAL + ; +: >DFA ( xt -- a-addr ) CELL+ ; +: >CFA ( xt -- a-addr ) ; +: >LINK ( xt -- a-addr ) CELL- ; +: >FLAGS ( xt -- c-addr ) [ CELL 1+ ] LITERAL - ; +: >NAME ( xt -- c-addr u ) >FLAGS DUP C@ F_LENMASK AND TUCK - SWAP ; >>SYSTEM \ 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! ; +: (HIDE) ( xt -- ) >FLAGS DUP C@ F_HIDDEN OR SWAP C! ; +: (UNHIDE) ( xt -- ) >FLAGS DUP C@ F_HIDDEN INVERT AND SWAP C! ; \ Use GET-CURRENT and SET-CURRENT to manipulate the compilation word list ' CURRENT (HIDE) @@ -80,13 +80,13 @@ SYSTEM-WORDLIST SET-CURRENT >>FORTH -: IMMEDIATE? ( xt -- flag ) >FLAGS C@ F_IMMED AND 0<> ; -: HIDDEN? ( xt -- flag ) >FLAGS C@ F_HIDDEN AND 0<> ; +: IMMEDIATE? ( xt -- flag ) >FLAGS C@ F_IMMED AND 0<> ; +: HIDDEN? ( xt -- flag ) >FLAGS C@ F_HIDDEN AND 0<> ; \ Decrement the array size and increment the address by the same amount -: /STRING ( c-addr u1 u2 -- c-addr+u2 u1-u2 ) TUCK - -ROT + SWAP ; +: /STRING ( c-addr u1 u2 -- c-addr+u2 u1-u2 ) TUCK - -ROT + SWAP ; \ Semantically equivalent to "1 /STRING" -: 1/STRING ( c-addr u -- c-addr+1 u-1 ) 1- SWAP 1+ SWAP ; +: 1/STRING ( c-addr u -- c-addr+1 u-1 ) 1- SWAP 1+ SWAP ; \ Standard (ANS FORTH) THROW code assignments (-255 ... -1) -1 CONSTANT EXCP-ABORT @@ -102,6 +102,7 @@ SYSTEM-WORDLIST SET-CURRENT -17 CONSTANT EXCP-PNO-OVERFLOW -24 CONSTANT EXCP-BAD-NUMERIC-ARGUMENT -37 CONSTANT EXCP-FILE-IO +-39 CONSTANT EXCP-UNEXPECTED-EOF -56 CONSTANT EXCP-QUIT \ Non-standard system error codes (-4095 ... -256) @@ -118,7 +119,7 @@ NULL 0 THROWN-STRING 2! \ This is called by THROW when n is nonzero \ CATCH saves and restores the current target and substitutes its own version \ BAILOUT will be replaced by DEFAULT-UNWIND later in the startup -DEFER THROW-UNWIND ( k*x n -- i*x ) +DEFER THROW-UNWIND ( k*x n -- i*x ) ' BAILOUT ' THROW-UNWIND DEFER! >>FORTH @@ -136,55 +137,55 @@ DEFER QUIT \ \ For use after CATCH; like THROW but doesn't change the string \ Also, if n is EXCP-QUIT then invokes QUIT for special handling (keeps data stack) -: RETHROW ( k*x n -- k*x | i*x n ) +: RETHROW ( k*x n -- k*x | i*x n ) ?DUP IF DUP EXCP-QUIT = IF QUIT THEN THROW-UNWIND THEN ; \ THROW while storing a string for context -: THROW-STRING ( k*x n c-addr u -- k*x | i*x n ) +: THROW-STRING ( k*x n c-addr u -- k*x | i*x n ) 2>R ?DUP IF 2R> THROWN-STRING 2! THROW-UNWIND ELSE 2RDROP THEN ; \ Basic THROW without any string (store an empty string) -: THROW ( k*x n -- k*x | i*x n ) +: THROW ( k*x n -- k*x | i*x n ) "" 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 ; +: 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 -- | ) +: FAIL ( c-addr u -- | ) 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 -- | ) +: ?FAIL ( flag c-addr u -- | ) ROT IF FAIL ELSE 2DROP THEN ; \ 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 | NULL ) GET-CURRENT @ ; +: LATEST ( -- xt | NULL ) GET-CURRENT @ ; >>UTILITY \ Set the given xt as the most recent word in the compilation word list \ Since this replaces the head of a linked list it may affect the entire list, \ not just the most recent word -: LATEST! ( xt -- ) GET-CURRENT ! ; +: LATEST! ( xt -- ) GET-CURRENT ! ; >>FORTH \ 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 +: 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 ! ; +: [ IMMEDIATE FALSE STATE ! ; +: ] IMMEDIATE TRUE STATE ! ; \ Just a visual separator, no compilation or runtime effect -: ▪ ( -- ) IMMEDIATE ; +: ▪ IMMEDIATE ; \ Returns the least power of two greater than or equal to u1 -: NATURALLY-ALIGNED ( u1 -- u2 ) +: 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+ ; @@ -195,14 +196,14 @@ DEFER QUIT >>FORTH \ Fetch and store the target of the deferred word denoted by deferred-xt -: DEFER@ ( deferred-xt -- xt ) DUP DEFERRED? ▪ >DFA @ ; -: DEFER! ( xt deferred-xt -- ) DUP DEFERRED? ▪ >DFA ! ; +: DEFER@ ( deferred-xt -- xt ) DUP DEFERRED? ▪ >DFA @ ; +: DEFER! ( xt deferred-xt -- ) DUP DEFERRED? ▪ >DFA ! ; >>LINUX \ Next we'll be defining a lot of constants for system calls and other ABI data \ CONSTANT is still a bootstrap word here, but ⇒ is just temporary -: ⇒ [ ' CONSTANT , ] ; +: ⇒ [ ' CONSTANT , ] ; \ x86 system call numbers 1 ⇒ SYS_EXIT @@ -618,75 +619,75 @@ DEFER QUIT ' ⇒ (HIDE) \ Generic wrapper that will retry any system call on EINTR -: SYSCALL-RETRY ( xu ... x1 sc xt n -- x ) +: SYSCALL-RETRY ( xu ... x1 sc xt n -- x ) 1+ 1+ N>R NULL BEGIN DROP NR@ DROP EXECUTE DUP ERRNO_EINTR + UNTIL NR> NDROP ; \ Specializations for specific numbers of parameters -: SYSCALL0-RETRY [ ' SYSCALL0 ] LITERAL 0 SYSCALL-RETRY ; -: SYSCALL1-RETRY [ ' SYSCALL1 ] LITERAL 1 SYSCALL-RETRY ; -: SYSCALL2-RETRY [ ' SYSCALL2 ] LITERAL 2 SYSCALL-RETRY ; -: SYSCALL3-RETRY [ ' SYSCALL3 ] LITERAL 3 SYSCALL-RETRY ; -: SYSCALL4-RETRY [ ' SYSCALL4 ] LITERAL 4 SYSCALL-RETRY ; -: SYSCALL5-RETRY [ ' SYSCALL5 ] LITERAL 5 SYSCALL-RETRY ; -: SYSCALL6-RETRY [ ' SYSCALL6 ] LITERAL 6 SYSCALL-RETRY ; +: SYSCALL0-RETRY [ ' SYSCALL0 ] LITERAL 0 SYSCALL-RETRY ; +: SYSCALL1-RETRY [ ' SYSCALL1 ] LITERAL 1 SYSCALL-RETRY ; +: SYSCALL2-RETRY [ ' SYSCALL2 ] LITERAL 2 SYSCALL-RETRY ; +: SYSCALL3-RETRY [ ' SYSCALL3 ] LITERAL 3 SYSCALL-RETRY ; +: SYSCALL4-RETRY [ ' SYSCALL4 ] LITERAL 4 SYSCALL-RETRY ; +: SYSCALL5-RETRY [ ' SYSCALL5 ] LITERAL 5 SYSCALL-RETRY ; +: SYSCALL6-RETRY [ ' SYSCALL6 ] LITERAL 6 SYSCALL-RETRY ; >>FORTH \ 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" ) +: TYPE-FD ( c-addr u fd -- fd: "ccc" ) >R ▪ BEGIN ?DUP WHILE 2DUP R@ -ROT SYS_WRITE SYSCALL3-RETRY DUP 0<= IF 2DROP RDROP EXIT THEN /STRING 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 ; +: TYPE ( c-addr u -- "ccc" ) STDOUT TYPE-FD ; +: TYPE-ERR ( c-addr u -- stderr: "ccc" ) STDERR TYPE-FD ; \ Write one character to FD 1 (stdout) -: EMIT ( c -- "c" ) SP@ 2DUP C! 1 TYPE DROP ; +: EMIT ( c -- "c" ) SP@ 2DUP C! 1 TYPE DROP ; \ Convert from a double-cell signed number to a single-cell signed number \ For 2's complement this is just DROP but e.g. sign-magnitude would require more \ For unsigned numbers just use DROP -: D>S ( d -- n ) DROP ; +: 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 ; +: /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 ; +: 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 ) +: 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 ; +: MIN ( n1 n2 -- n1|n2 ) 2DUP > IF NIP ELSE DROP THEN ; +: MAX ( n1 n2 -- n1|n2 ) 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 ; +: UMIN ( u1 u2 -- u1|n2 ) 2DUP U> IF NIP ELSE DROP THEN ; +: UMAX ( u1 u2 -- u1|n2 ) 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 0<= SWAP 0>= - ; +: SIGNUM ( n -- -1 | 0 | 1 ) DUP 0<= SWAP 0>= - ; \ True if n1 >= n2 && n1 <= n3, false otherwise : WITHIN ( n1|u1 n2|u2 n3|u3 -- flag ) OVER - -ROT - U> ; \ 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 ; +: 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 @@ -698,15 +699,15 @@ DEFER QUIT \ 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 ) +: SPACE? ( c -- flag ) DUP BL = IF DROP TRUE EXIT THEN 9 - [ 13 9 - ] LITERAL U<= ; \ Emit a blank (space) character -: SPACE ( -- "" ) BL EMIT ; +: SPACE ( -- "" ) BL EMIT ; \ Emit a horizontal tab character -: TAB ( -- "" ) HT EMIT ; +: TAB ( -- "" ) HT EMIT ; >>UTILITY @@ -717,14 +718,14 @@ DEFER QUIT >>FORTH \ Emit the implementation-dependent End-of-Line string -: EOL ( -- "" ) (EOL) TYPE ; +: EOL ( -- "" ) (EOL) TYPE ; \ Emit n blank (space) characters -: SPACES ( n -- "" ) BEGIN ?DUP WHILE 1- SPACE REPEAT ; +: SPACES ( n -- "" ) BEGIN ?DUP WHILE 1- SPACE REPEAT ; \ Terminate the program, successfully \ This will never return, even if the system call does -: BYE ( -- ) +: BYE ( -- ) BEGIN 0 SYS_EXIT SYSCALL1 DROP AGAIN ; >>SYSTEM @@ -737,7 +738,7 @@ DEFER QUIT \ 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 -- ) +: ALLOT ( n -- ) DUP 0< IF DUP C0 HERE - < IF EXCP-BAD-NUMERIC-ARGUMENT THROW THEN ELSE @@ -754,59 +755,59 @@ DEFER QUIT ' ALLOT ' BOOTSTRAP-ALLOT DEFER! \ Allocate one character from the data area and fill it with the value on the stack -: C, HERE 1 ALLOT C! ; +: C, ( c -- ) HERE 1 ALLOT C! ; \ Allocate one cell from the data area and fill it with the value on the stack -: , HERE CELL ALLOT ! ; +: , ( x -- ) 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! ; +: 2, ( x1 x2 -- ) HERE [ 2 CELLS ] LITERAL ALLOT 2! ; \ Allocate >= 0 and < u bytes such that the next address is a multiple of u \ The alignment u must be a power of two -: ALIGN-TO ( u -- ) HERE SWAP ALIGNED-TO HERE - ALLOT ; +: ALIGN-TO ( u -- ) HERE SWAP ALIGNED-TO HERE - ALLOT ; \ Allocate bytes from the data area (less than one cell) to cell-align the address -: ALIGN ( -- ) CELL ALIGN-TO ; +: ALIGN CELL ALIGN-TO ; \ Compile the name field of a word header, which is a counted string _right_ aligned \ to a cell boundary, with the length at the _end_ of the string. Example: \ [ x x x N ][ A M E 4 ] -: NAME, ( c-addr u -- ) +: NAME, ( c-addr u -- ) TUCK ▪ ALIGN HERE OVER + 1+ ▪ NEGATE CELL 1- AND ALLOT HERE ▪ OVER ALLOT ▪ SWAP CMOVE ▪ C, ; \ 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 -- ) , ; +: COMPILE, ( xt -- ) , ; \ Append the LIT xt and the topmost word on the stack to the current definition. -: LITERAL ( Compilation: x -- ) ( Runtime: -- x ) IMMEDIATE +: LITERAL ( x -- ; -- 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 +: SLITERAL ( c-addr1 u -- ; -- c-addr2 u ) IMMEDIATE POSTPONE LITSTRING DUP C, HERE SWAP DUP ALLOT CMOVE ALIGN ; -: 2LITERAL ( Compilation: x1 x2 -- ) ( Runtime: -- x1 x2 ) IMMEDIATE +: 2LITERAL ( x1 x2 -- ; -- x1 x2 ) IMMEDIATE POSTPONE 2LIT 2, ; \ Append the execution semantics of the current definition to the current definition -: RECURSE ( -- ) IMMEDIATE +: RECURSE IMMEDIATE LATEST COMPILE, ; \ Unhide the current definition so it can refer to itself by name -: RECURSIVE ( -- ) IMMEDIATE +: RECURSIVE IMMEDIATE LATEST (UNHIDE) ; \ Define [[ ]] as shorthand for [ ] LITERAL -: [[ ( -- ) IMMEDIATE POSTPONE [ ; -: ]] ( x -- ) POSTPONE ] POSTPONE LITERAL ; +: [[ IMMEDIATE POSTPONE [ ; +: ]] ( x -- ) POSTPONE ] POSTPONE LITERAL ; \ Aliases to improve readability -: NULL= ( addr -- flag ) IMMEDIATE STATE @ IF POSTPONE 0= ELSE 0= THEN ; -: NULL<> ( addr -- flag ) IMMEDIATE STATE @ IF POSTPONE 0<> ELSE 0<> THEN ; +: NULL= ( addr -- flag ) IMMEDIATE STATE @ IF POSTPONE 0= ELSE 0= THEN ; +: NULL<> ( addr -- flag ) IMMEDIATE STATE @ IF POSTPONE 0<> ELSE 0<> THEN ; \ Our first control-flow primitive: IF {ELSE } THEN \ @@ -835,28 +836,46 @@ DEFER QUIT \ by THEN and marks the end of the list if consumed by ONWARD-IF or ONWARD-AHEAD. \ This can be used as a base for control structures with zero or more branches. -: ALWAYS ( C: -- null-orig ) IMMEDIATE +>>UTILITY + +: (ALWAYS) ( C: -- null-orig ) IMMEDIATE NULL ; -: ONWARD-IF ( C: orig1 -- orig2 ) ( Runtime: flag -- ) IMMEDIATE +: (ONWARD-IF) ( C: orig1 -- orig2 ; flag -- ) IMMEDIATE POSTPONE 0BRANCH HERE SWAP , ; -: ONWARD-AHEAD ( C: orig1 -- orig2 ) IMMEDIATE +: (ONWARD-AHEAD) ( C: orig1 -- orig2 ) IMMEDIATE POSTPONE BRANCH HERE SWAP , ; -: THEN ( C: orig -- ) IMMEDIATE +: (THEN) ( C: orig -- ) IMMEDIATE BEGIN ?DUP WHILE HERE OVER - SWAP XCHG REPEAT ; -: IF ( C: -- orig ) ( Runtime: flag -- ) IMMEDIATE - POSTPONE ALWAYS POSTPONE ONWARD-IF ; -: AHEAD ( C: -- orig ) IMMEDIATE - POSTPONE ALWAYS POSTPONE ONWARD-AHEAD ; -: ELSE ( C: orig1 -- orig2 ) IMMEDIATE - POSTPONE AHEAD SWAP POSTPONE THEN ; + +: (IF) ( C: -- orig ; flag -- ) IMMEDIATE + POSTPONE (ALWAYS) POSTPONE (ONWARD-IF) ; +: (AHEAD) ( C: -- orig ; flag -- ) IMMEDIATE + POSTPONE (ALWAYS) POSTPONE (ONWARD-AHEAD) ; + +>>FORTH + +\ IF +\ {ELSE-IF THEN-IF }… +\ {ELSE } +\ THEN +: IF ( C: -- orig-final orig-next ; flag -- ) IMMEDIATE + POSTPONE (ALWAYS) POSTPONE (ALWAYS) POSTPONE (ONWARD-IF) ; +: ELSE-IF ( C: orig-final1 orig-next -- orig-final2 ) IMMEDIATE + SWAP POSTPONE (ONWARD-AHEAD) SWAP POSTPONE (THEN) ; +: THEN-IF ( C: orig-final -- orig-final orig-next ; flag -- ) IMMEDIATE + POSTPONE (ALWAYS) POSTPONE (ONWARD-IF) ; +: ELSE ( C: orig-final1 orig-next -- orig-final2 orig-always ) IMMEDIATE + SWAP POSTPONE (ONWARD-AHEAD) SWAP POSTPONE (THEN) POSTPONE (ALWAYS) ; +: THEN ( C: orig-final orig-next -- ) IMMEDIATE + POSTPONE (THEN) POSTPONE (THEN) ; \ Short-circuit logical operators \ Examples: \ AND-THEN THEN \ OR-ELSE THEN -: AND-THEN ( C: -- orig ) ( Runtime: flag -- FALSE | ) IMMEDIATE +: AND-THEN ( C: -- orig ) ( Runtime: flag -- FALSE | ) IMMEDIATE POSTPONE ?0DUP POSTPONE IF ; -: OR-ELSE ( C: -- orig ) ( Runtime: flag -- nonzero-flag | ) IMMEDIATE +: OR-ELSE ( C: -- orig ) ( Runtime: flag -- nonzero-flag | ) IMMEDIATE POSTPONE ?DUP POSTPONE 0= POSTPONE IF ; \ Unbounded loop: BEGIN AGAIN @@ -865,13 +884,13 @@ DEFER QUIT \ Mixed WHILE/UNTIL loop: BEGIN WHILE UNTIL : BEGIN ( C: -- null-orig dest ) IMMEDIATE - POSTPONE ALWAYS ▪ HERE ; + POSTPONE (ALWAYS) ▪ HERE ; : AGAIN ( C: orig dest -- ) IMMEDIATE - POSTPONE BRANCH ▪ HERE - , ▪ POSTPONE THEN ; + POSTPONE BRANCH ▪ HERE - , ▪ POSTPONE (THEN) ; : UNTIL ( C: orig dest -- ) ( Runtime: flag -- ) IMMEDIATE - POSTPONE 0BRANCH HERE - , POSTPONE THEN ; + POSTPONE 0BRANCH HERE - , POSTPONE (THEN) ; : WHILE ( C: orig1 dest -- orig2 dest ) ( Runtime: flag -- ) IMMEDIATE - SWAP POSTPONE ONWARD-IF SWAP ; + SWAP POSTPONE (ONWARD-IF) SWAP ; : REPEAT ( C: orig dest -- ) IMMEDIATE POSTPONE AGAIN ; @@ -888,48 +907,48 @@ DEFER QUIT \ a forward reference to the ENDOF (as with IF ... THEN) above the ENDCASE counter. \ \ Begin by creating a placeholder for the unresolved ENDOF forward references -: CASE ( C: -- NULL ) IMMEDIATE - POSTPONE ALWAYS ; +: CASE ( C: -- NULL ) IMMEDIATE + POSTPONE (ALWAYS) ; \ 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 ; +: OF ( C: orign ... orig1 n -- orign ... orig1 n orig-of ) IMMEDIATE + POSTPONE OVER POSTPONE = POSTPONE (ALWAYS) POSTPONE (ONWARD-IF) POSTPONE DROP ; \ Create a forward branch to ENDCASE and resolve the one from OF -: ENDOF ( C: orig-case1 orig-of -- orig-case2 ) IMMEDIATE - SWAP POSTPONE ONWARD-AHEAD SWAP POSTPONE THEN ; +: ENDOF ( C: orig-case1 orig-of -- orig-case2 ) IMMEDIATE + SWAP POSTPONE (ONWARD-AHEAD) SWAP POSTPONE (THEN) ; \ Drop the value in case none of the OF...ENDOF clauses matched \ Resolve all the forward branches from ENDOF to the location after ENDCASE -: ENDCASE ( C: orig-case -- ) IMMEDIATE - POSTPONE DROP POSTPONE THEN ; +: ENDCASE ( C: orig-case -- ) IMMEDIATE + POSTPONE DROP POSTPONE (THEN) ; \ Range loop: DO LOOP \ DO +LOOP \ ?DO LOOP \ ?DO +LOOP CREATE LEAVE-ORIG NULL , -: DO ( C: -- outer-stack dest S: limit index R: -- limit index ) IMMEDIATE +: DO ( C: -- outer-stack dest ; limit index -- R: -- limit index ) IMMEDIATE POSTPONE 2>R LEAVE-ORIG @ - POSTPONE ALWAYS LEAVE-ORIG ! + POSTPONE (ALWAYS) LEAVE-ORIG ! POSTPONE BEGIN ; -: ?DO ( C: -- outer-stack dest S: limit index R: -- limit index ) IMMEDIATE +: ?DO ( C: -- outer-stack dest ; limit index -- R: -- limit index ) IMMEDIATE POSTPONE 2>R LEAVE-ORIG @ - POSTPONE 2R@ POSTPONE <> POSTPONE IF LEAVE-ORIG ! + POSTPONE 2R@ POSTPONE <> POSTPONE (IF) LEAVE-ORIG ! POSTPONE BEGIN ; -: LEAVE ( C: -- S: -- R: limit index -- ) IMMEDIATE - LEAVE-ORIG @ POSTPONE ONWARD-AHEAD LEAVE-ORIG ! ; -: UNLOOP ( R: limit index -- ) IMMEDIATE +: LEAVE ( C: -- ; -- R: limit index -- ) IMMEDIATE + LEAVE-ORIG @ POSTPONE (ONWARD-AHEAD) LEAVE-ORIG ! ; +: UNLOOP ( R: limit index -- ) IMMEDIATE POSTPONE 2RDROP ; -: +LOOP ( C: outer-stack dest -- S: n -- R: {limit index} -- ) IMMEDIATE +: +LOOP ( C: outer-stack dest -- ; n -- R: {limit index} -- ) IMMEDIATE POSTPONE RSP@ POSTPONE +! POSTPONE 2R@ POSTPONE = POSTPONE UNTIL - LEAVE-ORIG @ POSTPONE THEN POSTPONE UNLOOP LEAVE-ORIG ! ; -: LOOP ( C: outer-stack dest -- S: -- R: {limit index} -- ) IMMEDIATE + LEAVE-ORIG @ POSTPONE (THEN) POSTPONE UNLOOP LEAVE-ORIG ! ; +: LOOP ( C: outer-stack dest -- ; -- R: {limit index} -- ) IMMEDIATE 1 POSTPONE LITERAL POSTPONE +LOOP ; ' LEAVE-ORIG (HIDE) \ 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 ; +: I 1 RPICK ; +: J 3 RPICK ; >>SYSTEM @@ -944,47 +963,47 @@ PNO-BUFFER PNO-BUFFER-BYTES + CONSTANT PNO-BUFFER-END CREATE PNO-POINTER PNO-BUFFER-END , \ THROW if there are less than u bytes remaining in the PNO buffer -: PNO-CHECK ( u -- ) +: PNO-CHECK ( u -- ) PNO-POINTER @ PNO-BUFFER - U> IF EXCP-PNO-OVERFLOW THROW THEN ; >>FORTH -: <# ( -- ) PNO-BUFFER-END PNO-POINTER ! ; -: HOLD ( char -- ) PNO-POINTER 1 DUP PNO-CHECK OVER -! @ C! ; -: HOLDS ( c-addr u -- ) PNO-POINTER OVER DUP PNO-CHECK OVER -! @ SWAP CMOVE ; -: #> ( xd -- c-addr u ) 2DROP PNO-BUFFER-END PNO-POINTER @ TUCK - ; +: <# PNO-BUFFER-END PNO-POINTER ! ; +: HOLD ( char -- ) PNO-POINTER 1 DUP PNO-CHECK OVER -! @ C! ; +: HOLDS ( c-addr u -- ) PNO-POINTER OVER DUP PNO-CHECK OVER -! @ SWAP CMOVE ; +: #> ( xd -- c-addr u ) 2DROP PNO-BUFFER-END PNO-POINTER @ TUCK - ; -: SIGN ( n -- ) 0< IF [[ CHAR - ]] HOLD THEN ; +: SIGN ( n -- ) 0< IF [[ CHAR - ]] HOLD THEN ; -: #B ( ud1 u -- ud2 ) +: #B ( ud1 u -- ud2 ) UM/MOD ROT DUP 10 >= IF 10 - [[ CHAR A ]] + ELSE [[ CHAR 0 ]] + THEN HOLD ; -: # ( ud1 -- ud2 ) 10 #B ; +: # ( ud1 -- ud2 ) 10 #B ; -: #SB ( ud u -- ) +: #SB ( ud u -- ) >R BEGIN R@ #B 2DUP D0= UNTIL RDROP ; -: #S ( ud -- ) 10 #SB ; +: #S ( ud -- ) 10 #SB ; \ Decimal Fixed Precision with u digits after the decimal point \ Example: 12345 0 <# 3 #DFP #> ≡ "12.345" -: #DFP ( ud1 u -- ud2 ) BEGIN ?DUP WHILE 1- >R # R> REPEAT [[ CHAR . ]] HOLD #S ; +: #DFP ( ud1 u -- ud2 ) BEGIN ?DUP WHILE 1- >R # R> REPEAT [[ CHAR . ]] HOLD #S ; \ Display the unsigned number at the top of the stack -: DU. ( ud -- "" ) <# #S #> TYPE ; -: U. ( u -- "" ) 0 DU. ; +: DU. ( ud -- "" ) <# #S #> TYPE ; +: U. ( u -- "" ) 0 DU. ; \ Display the signed number at the top of the stack -: D. ( d -- "" ) DUP -ROT DABS <# #S ROT SIGN #> TYPE ; -: . ( n -- "" ) S>D D. ; +: D. ( d -- "" ) DUP -ROT DABS <# #S ROT SIGN #> TYPE ; +: . ( n -- "" ) S>D D. ; \ Return the number of words on the data and return stacks, respectively -: DEPTH ( -- n ) SP@ S0 SWAP - CELL / ; -: RDEPTH ( -- n ) RSP@ CELL+ R0 SWAP - CELL / ; +: DEPTH ( -- n ) SP@ S0 SWAP - CELL / ; +: RDEPTH ( -- n ) RSP@ CELL+ R0 SWAP - CELL / ; >>SYSTEM -: STARTUP-UNWIND ( k*x n -- i*x ) +: STARTUP-UNWIND ( k*x n -- i*x ) "Exception " TYPE-ERR DUP ABS 0 <# (EOL) HOLDS #S ROT SIGN #> TYPE-ERR THROWN-STRING 2@ DUP IF TYPE-ERR "\n" TYPE-ERR THEN [ ' BAILOUT COMPILE, ] ; @@ -998,14 +1017,14 @@ CREATE DISPLAY-ITEM-LIMIT 6 , >>FORTH \ Display the content of the data stack -: .S ( -- "" ) +: .S ( -- "" ) "S(" TYPE DEPTH . "):" TYPE SP@ DUP DISPLAY-ITEM-LIMIT @ CELLS+ S0 UMIN DUP S0 <> IF " …" TYPE THEN BEGIN 2DUP < WHILE CELL- DUP @ SPACE . REPEAT 2DROP EOL ; \ Display the content of the return stack -: .RS ( -- "" ) +: .RS ( -- "" ) \ Skip the topmost cell, which is the return address for the call to .RS "R(" TYPE RDEPTH 1- . "):" TYPE RSP@ CELL+ DUP DISPLAY-ITEM-LIMIT @ CELLS+ R0 UMIN @@ -1013,12 +1032,12 @@ CREATE DISPLAY-ITEM-LIMIT 6 , BEGIN 2DUP < WHILE CELL- DUP @ SPACE . REPEAT 2DROP EOL ; \ Remove trailing whitespace from a string (only affects length) -: -TRAILING ( c-addr u1 -- c-addr u2 ) +: -TRAILING ( c-addr u1 -- c-addr u2 ) BEGIN DUP AND-THEN 2DUP 1- + C@ SPACE? THEN WHILE 1- REPEAT ; \ 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 ) +: COMPARE ( c-addr1 u1 c-addr2 u2 -- -1 | 0 | 1 ) ROT SWAP ▪ 2DUP - -ROT 2>R -ROT 2R> ▪ UMIN 0 ?DO ( S: u1-u2 c-addr1 c-addr2 R: loop-sys ) OVER I + C@ OVER I + C@ @@ -1027,32 +1046,34 @@ CREATE DISPLAY-ITEM-LIMIT 6 , LOOP ▪ 2DROP SIGNUM ; \ Convert a character to lowercase or uppercase, respectively -: TO-LOWER ( ch1 -- ch2 ) +: TO-LOWER ( ch1 -- ch2 ) DUP [[ CHAR A ]] [[ CHAR Z 1+ ]] WITHIN IF [[ CHAR a CHAR A - ]] + THEN ; -: TO-UPPER ( ch1 -- ch2 ) +: TO-UPPER ( ch1 -- ch2 ) DUP [[ CHAR a ]] [[ CHAR z 1+ ]] WITHIN IF [[ CHAR a CHAR A - ]] - THEN ; -\ If ch is a digit (any base) return the value in range [0, 36) and TRUE +\ If ch is an alphanumeric character return the value in range [0, 36) and TRUE \ Otherwise just return FALSE -: >DIGIT ( ch -- u TRUE | FALSE ) +: >DIGIT ( ch -- u TRUE | FALSE ) DUP [[ CHAR 0 ]] [[ CHAR 9 1+ ]] WITHIN IF [[ CHAR 0 ]] - TRUE EXIT THEN DUP [[ CHAR A ]] [[ CHAR Z 1+ ]] WITHIN IF [[ CHAR A 10 - ]] - TRUE EXIT THEN DUP [[ CHAR a ]] [[ CHAR z 1+ ]] WITHIN IF [[ CHAR a 10 - ]] - TRUE EXIT THEN DROP FALSE ; +\ Like >DIGIT but only returns TRUE if ch is a valid digit for the given base +: >DIGIT-BASE ( ch base -- u TRUE | FALSE ) + SWAP >DIGIT AND-THEN SWAP 2DUP U< DUP 0= IF NIP THEN THEN NIP ; + \ Convert a string in the given base to an unsigned double-cell number \ Stop at the end of the string or when the next character is not valid for the base \ Return the double-cell number and the remainder of the string -: >NUMBER-BASE ( c-addr1 u1 base -- ud c-addr2 u2 ) - >R 0 0 2SWAP - BEGIN - DUP 0= IF RDROP EXIT THEN - OVER C@ >DIGIT 0= IF RDROP EXIT THEN - DUP R@ U>= IF RDROP DROP EXIT THEN - >R 1/STRING 2SWAP 2R@ DROP 0 D* R> 0 D+ 2SWAP - AGAIN ; +: >NUMBER-BASE ( c-addr1 u1 base -- ud c-addr2 u2 ) + >R 0 0 2SWAP BEGIN + DUP WHILE ▪ OVER C@ >DIGIT WHILE + DUP R@ U>= ▪ DUP IF DROP THEN ▪ 0= WHILE + >R 1/STRING ▪ 2SWAP ▪ 2R@ DROP 0 D* ▪ R> 0 D+ ▪ 2SWAP + AGAIN ▪ RDROP ; -: >NUMBER ( c-addr1 u1 -- ud c-addr2 u2 ) +: >NUMBER ( c-addr1 u1 -- ud c-addr2 u2 ) DUP 0= IF 0 0 2SWAP EXIT THEN OVER C@ [[ CHAR 0 ]] = IF 1/STRING @@ -1070,7 +1091,7 @@ CREATE DISPLAY-ITEM-LIMIT 6 , >>UTILITY \ Parse a signed number; to succeed the entire input string must be consumed -: PARSENUMBER ( c-addr u -- n TRUE | FALSE ) +: PARSENUMBER ( c-addr u -- n TRUE | FALSE ) DUP 0= IF NIP EXIT THEN ▪ OVER C@ [[ CHAR - ]] = DUP >R IF 1/STRING DUP 0= IF RDROP NIP EXIT THEN THEN >NUMBER R> 2NIP SWAP 0= DUP >R IF IF NEGATE THEN ELSE 2DROP THEN R> ; @@ -1089,13 +1110,13 @@ CREATE CURRENT-SOURCE-ID -1 , >>FORTH \ Report the current input buffer region and SOURCE-ID -: SOURCE ( -- c-addr u ) INPUT-BUFFER 2@ ; -: SOURCE-ID ( -- 0 | -1 | +n ) CURRENT-SOURCE-ID @ ; +: SOURCE ( -- c-addr u ) INPUT-BUFFER 2@ ; +: SOURCE-ID ( -- 0 | -1 | +n ) CURRENT-SOURCE-ID @ ; \ Save and restore the input source parameters (e.g. file position) \ This does not include the input buffer (SOURCE) or the SOURCE-ID -: SAVE-INPUT ( -- xu ... x1 u ) >IN @ 1 ; -: RESTORE-INPUT ( xu ... x1 u -- flag ) OVER >IN ! NDROP TRUE ; +: SAVE-INPUT ( -- xu ... x1 u ) >IN @ 1 ; +: RESTORE-INPUT ( xu ... x1 u -- flag ) OVER >IN ! NDROP TRUE ; >>SYSTEM @@ -1105,13 +1126,10 @@ CREATE EXCEPTION-STACK NULL , \ 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 ) +: CATCH-UNWIND ( k*x n -- i*x ) EXCEPTION-STACK @ RSP! - R> EXCEPTION-STACK ! - R> [[ ' THROW-UNWIND ]] DEFER! - R> CURRENT-SOURCE-ID ! - 2R> INPUT-BUFFER 2! - NR> RESTORE-INPUT DROP + 2R> ▪ [[ ' THROW-UNWIND ]] DEFER! ▪ EXCEPTION-STACK ! + R> CURRENT-SOURCE-ID ! ▪ 2R> INPUT-BUFFER 2! ▪ NR> RESTORE-INPUT DROP R> SWAP >R SP! R> ; >>UTILITY @@ -1124,55 +1142,46 @@ CREATE EXCEPTION-STACK NULL , \ 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 +: CATCH ( i*x xt -- j*x 0 | i*x n ) + \ Save the original RSP to quickly remove the exception frame data on success RSP@ - \ Don't include the xt or RSP when saving the stack pointer - 2>R SP@ 2R> ROT >R + \ Save the stack poiner but don't include the xt and RSP on the top + SP@ 2 CELLS+ >R \ Save the input source specification - SAVE-INPUT N>R - SOURCE 2>R - SOURCE-ID >R + 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 + EXCEPTION-STACK @ ▪ [[ ' THROW-UNWIND ]] DEFER@ ▪ 2>R \ Push the new exception stack frame RSP@ EXCEPTION-STACK ! \ Arrange for THROW to call CATCH-UNWIND instead of DEFAULT-UNWIND - [[ ' CATCH-UNWIND ]] [[ ' THROW-UNWIND ]] DEFER! + [ ' CATCH-UNWIND ' THROW-UNWIND ] 2LITERAL DEFER! \ Save the original return stack so we can quickly free the exception frame - ( RSP@ from start of CATCH ) >R \ Run the function; if THROW is called then EXECUTE won't return - \ If it does return then push 0 to indicate success - EXECUTE 0 - R> R> R> - \ Revert THROW-UNWIND and EXCEPTION-STACK using data from exception frame - [[ ' THROW-UNWIND ]] DEFER! - EXCEPTION-STACK ! - \ We don't need the rest so just reset the RSP to where it was on entering CATCH - RSP! ; + >R EXECUTE + \ Revert THROW-UNWIND, EXCEPTION-STACK, and RSP; return 0 to indicates success + R> 2R> ▪ [[ ' THROW-UNWIND ]] DEFER! ▪ EXCEPTION-STACK ! ▪ RSP! ▪ 0 ; -: PARSE-AREA ( -- c-addr u ) SOURCE >IN @ /STRING ; +: PARSE-AREA ( -- c-addr u ) SOURCE >IN @ /STRING ; >>UTILITY -: PARSE-EMPTY? ( -- flag ) SOURCE NIP >IN @ = ; +: PARSE-EMPTY? ( -- flag ) SOURCE NIP >IN @ = ; -: PEEK-CHAR ( -- c ) +: PEEK-CHAR ( -- c ) PARSE-AREA 0= "Unexpected end of input" ?FAIL C@ ; -: SKIP-CHAR ( -- ) 1 >IN +! ; +: SKIP-CHAR 1 >IN +! ; -: NEXT-CHAR ( -- c ) PEEK-CHAR SKIP-CHAR ; +: NEXT-CHAR ( -- c ) PEEK-CHAR SKIP-CHAR ; -: SKIP-SPACES ( "" -- ) - BEGIN PARSE-EMPTY? OR-ELSE PEEK-CHAR SPACE? DUP IF SKIP-CHAR THEN 0= THEN UNTIL ; +: SKIP-SPACES ( "" -- ) + BEGIN ▪ PARSE-EMPTY? 0= WHILE ▪ PEEK-CHAR SPACE? WHILE ▪ SKIP-CHAR ▪ REPEAT ; >>FORTH \ Comments; ignore all characters until the next EOL or ) character, respectively -: \ ( "ccc" -- ) IMMEDIATE BEGIN NEXT-CHAR LF = UNTIL ; -: ( ( "ccc" -- ) IMMEDIATE BEGIN NEXT-CHAR [[ CHAR ) ]] = UNTIL ; +: \ ( "ccc" -- ) IMMEDIATE BEGIN NEXT-CHAR LF = UNTIL ; +: ( ( "ccc" -- ) IMMEDIATE BEGIN NEXT-CHAR [[ CHAR ) ]] = UNTIL ; \ Placeholder to be replaced before switching to terminal input DEFER REFILL @@ -1180,111 +1189,130 @@ DEFER REFILL \ Skip whitespace; read and return the next word delimited by whitespace \ The delimiting whitespace character is left in the parse area -: PARSE-NAME ( "ccc" -- c-addr u ) +: PARSE-NAME ( "name" -- c-addr u ) BEGIN - SKIP-SPACES - PARSE-EMPTY? + SKIP-SPACES ▪ PARSE-EMPTY? WHILE - REFILL 0= IF NULL 0 EXIT THEN + REFILL 0= IF EXCP-UNEXPECTED-EOF THROW THEN REPEAT PARSE-AREA DROP - BEGIN - PARSE-EMPTY? 0= AND-THEN PEEK-CHAR SPACE? 0= THEN - WHILE - SKIP-CHAR - REPEAT + BEGIN ▪ PARSE-EMPTY? 0= WHILE ▪ PEEK-CHAR SPACE? 0= WHILE ▪ SKIP-CHAR ▪ REPEAT PARSE-AREA DROP OVER - ; +\ Read the next word and return the first character +: CHAR ( "name" -- c ) + PARSE-NAME DROP C@ ; + >>SYSTEM \ Create the header for a word in the data space and return its xt \ The word is NOT added to the current compilation word list \ The start and end of the header are both cell-aligned -: (CREATE-RAW) ( c-addr u link dfa cfa -- xt ) +: (CREATE-RAW) ( c-addr u link dfa cfa -- xt ) 2>R >R ▪ F_LENMASK UMIN NAME, ▪ R> , ▪ 2R> , , ▪ HERE 2 CELLS- ; \ 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 ! ; +: (DOES) ( dfa -- ) LATEST DODOES OVER >CFA ! >DFA ! ; + +\ The runtime effect of MARK, after the string label is pushed onto the stack +: (MARK) ( c-addr u -- ) "-- " TYPE TYPE " --\n" TYPE .S R> .RS >R ; + +\ The default target for DEFER words until initialized with DEFER! or IS +: (DEFER-UNINITIALIZED) EXCP-DEFER-UNINITIALIZED THROW ; >>UTILITY \ Use to create words programmatically without reading the name from the input -: (CREATE) ( c-addr u -- ) +: (CREATE) ( c-addr u -- ) LATEST NULL DODATA (CREATE-RAW) HERE OVER >DFA ! LATEST! ; ->>FORTH - -: CREATE ( "ccc" -- ) - PARSE-NAME (CREATE) ; - -\ Append " (DOES) EXIT" to the current definition -\ where 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 NULL , ▪ POSTPONE (DOES) POSTPONE EXIT ▪ HERE SWAP ! ; - -\ Debugging aid; shows a label and the contents of the stacks at runtime -: (MARK) "-- " TYPE TYPE " --\n" TYPE .S R> .RS >R ; -: MARK IMMEDIATE PARSE-NAME 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 -: : ( "ccc" -- ) - CREATE LATEST ▪ DUP (HIDE) ▪ DOCOL SWAP >CFA ! ▪ POSTPONE ] ; +: (:) ( c-addr u -- ) + (CREATE) LATEST ▪ DUP (HIDE) ▪ DOCOL SWAP >CFA ! ▪ POSTPONE ] ; + +>>FORTH + +\ Append " (DOES) EXIT" to the current definition +\ where 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 NULL , ▪ POSTPONE (DOES) POSTPONE EXIT ▪ HERE SWAP ! ; \ End a definition by appending EXIT and leaving compilation mode \ Unhide the name if it isn't empty (e.g. from :NONAME) -: ; ( -- ) IMMEDIATE +: ; IMMEDIATE POSTPONE EXIT POSTPONE [ LATEST DUP >NAME NIP IF (UNHIDE) ELSE DROP THEN ; +>>UTILITY + +\ Create a deferred word; the target is stored in the DFA field +\ The default target throws an exception — replace it using DEFER! or IS +: (DEFER) ( c-addr u -- ) + (CREATE) [[ ' (DEFER-UNINITIALIZED) ]] LATEST DODEFER OVER >CFA ! >DFA ! ; + \ Use the deferred-word mechanism to create an alternate name for the given xt \ A deferred word, while indirect, is more compact than a single-word colon \ definition and avoids the setup and teardown of a redundant return stack frame -: ALIAS ( xt "ccc" -- ) - CREATE LATEST DODEFER OVER >CFA ! >DFA ! ; +: (ALIAS) ( xt c-addr u -- ) (DEFER) LATEST DEFER! ; \ Define a named constant -\ Execution: ( value "name" -- ) +\ Execution: ( value "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 ! ; +\ : (CONSTANT) (:) POSTPONE LITERAL POSTPONE ; ; +: (CONSTANT) ( x c-addr u -- ; -- x ) (CREATE) LATEST >DFA ! ; \ Same for double-cell constants; no DFA trick this time -: 2CONSTANT ( x1 x2 -- ) CREATE HERE 2 CELLS ALLOT 2! - DOES> ( -- x1 x2 ) 2@ ; +: (2CONSTANT) ( x1 x2 -- ) (CREATE) ▪ HERE ▪ 2 CELLS ALLOT ▪ 2! + DOES> ( -- x1 x2 ) 2@ ; -\ Define a single-cell named variable which returns its data address when executed. +\ Define a named variables which return the address of their data when executed. \ The initial value is formally undefined. This implementation sets it to NULL. -\ Execution: ( "name" -- ) -\ name Execution: ( -- a-addr ) -: VARIABLE CREATE NULL , ; - -\ Same for double-cell variables (two-variables) -: 2VARIABLE CREATE [ NULL NULL ] 2LITERAL 2, ; +: (VARIABLE) ( c-addr u -- ; -- a-addr ) (CREATE) NULL , ; +: (2VARIABLE) ( c-addr u -- ; -- a-addr ) (CREATE) [ NULL NULL ] 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 "name" -- ) +\ Execution: ( x "name" -- ) \ name execution: ( -- value ) -: VALUE CREATE , DOLOAD LATEST >CFA ! ; +: (VALUE) ( x c-addr u -- ; -- x' ) (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 "name" -- ) - CREATE CELLS ALLOT DOES> SWAP CELL * + ; +\ Define an array of u1 single-cell elements; word returns address of element u ( ( u -- a-addr ) SWAP CELL * + ; -\ 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 "name" -- ) - CREATE 2* CELLS ALLOT DOES> SWAP [[ 2 CELLS ]] * + ; +\ Define an array of u1 double-cell elements; word returns address of element u ( ( u -- a-addr ) SWAP [[ 2 CELLS ]] * + ; + +\ Debugging aid; shows a label and the contents of the stacks at runtime +: MARK ( "name" ) IMMEDIATE + PARSE-NAME POSTPONE SLITERAL POSTPONE (MARK) ; + +>>FORTH + +\ The utility words defined previously, but with the name read from the parse area +: CREATE PARSE-NAME (CREATE) ; +: : PARSE-NAME (:) ; +: DEFER PARSE-NAME (DEFER) ; +: ALIAS PARSE-NAME (ALIAS) ; +: CONSTANT PARSE-NAME (CONSTANT) ; +: 2CONSTANT PARSE-NAME (2CONSTANT) ; +: VARIABLE PARSE-NAME (VARIABLE) ; +: 2VARIABLE PARSE-NAME (2VARIABLE) ; +: VALUE PARSE-NAME (VALUE) ; +: ARRAY PARSE-NAME (ARRAY) ; +: 2ARRAY PARSE-NAME (2ARRAY) ; + +\ Define a word with no name, leaving its xt on the stack +: :NONAME "" (:) LATEST ; \ Structures begin with byte alignment and an offset of zero 1 0 2CONSTANT STRUCT @@ -1324,27 +1352,21 @@ DEFER REFILL \ Within STRUCT … ENDSTRUCT, define a field with the given alignment and size \ Each field word has runtime effect ( struct-addr -- field-addr) \ If field offset is zero then the word is marked as immediate and generates no code -: FIELD ( align1 offset1 field-align field-bytes -- align2 offset2 ) +: FIELD ( align1 offset1 field-align field-bytes -- align2 offset2 ) : -ROT NATURALLY-ALIGNED ▪ DUP >R ▪ ALIGNED-TO DUP ?DUP IF POSTPONE LITERAL POSTPONE + ELSE POSTPONE IMMEDIATE THEN POSTPONE ; ▪ + SWAP R> UMAX SWAP ; \ Consume the final alignment and offset and define a type descriptor for the struct -: ENDSTRUCT ( align offset "name" -- ) +: ENDSTRUCT ( align offset "name" -- ) SWAP NATURALLY-ALIGNED TUCK ALIGNED-TO 2CONSTANT ; \ Accessors for type descriptors -: %SIZEOF ( align size -- size ) IMMEDIATE +: %SIZEOF ( align size -- size ) IMMEDIATE STATE @ IF POSTPONE NIP ELSE NIP THEN ; -: %ALIGNOF ( align size -- align ) IMMEDIATE +: %ALIGNOF ( align size -- align ) IMMEDIATE STATE @ IF POSTPONE DROP ELSE DROP THEN ; -\ Like : but the definition has no name -\ The zero-length name is 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 ( -- ) - "" (CREATE) LATEST ▪ DUP (HIDE) ▪ DOCOL OVER >CFA ! ▪ POSTPONE ] ; - \ Inline :NONAME-style function literals. "{ }" has the runtime effect \ of placing the execution token for an anonymous function with the runtime \ effect of on the top of the data stack. A branch is emitted to skip @@ -1364,28 +1386,29 @@ DEFER REFILL \ 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 +: { ( -- {outer-xt orig} inner-xt state ) IMMEDIATE STATE @ DUP IF LATEST NULL OVER >LINK XCHG LATEST! - POSTPONE AHEAD + POSTPONE (AHEAD) ROT POSTPONE [ THEN :NONAME SWAP ; +\ Terminate a definition started with { . \ 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 +: } ( {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 + -ROT POSTPONE (THEN) \ Re-append the outer definition to the word list LATEST OVER >LINK ! LATEST! \ Return to compilation mode (was ended by ; ) @@ -1396,49 +1419,40 @@ DEFER REFILL ( S: inner-xt ) THEN ; -\ Create a deferred word; the target is stored in the DFA field -\ The default target throws an exception — replace it using DEFER! or IS -: DEFER ( "ccc" -- ) - CREATE { EXCP-DEFER-UNINITIALIZED THROW } LATEST DODEFER OVER >CFA ! >DFA ! ; - \ Conditional compilation / interpreted conditions \ No effect if flag is true, otherwise skips words until matching [ELSE] or [THEN] \ Skips over nested [IF] … [THEN] or [IF] … [ELSE] … [THEN] structures \ The skipped words are not interpreted, so \ ( " etc. have no special meaning -: [IF] IMMEDIATE +: [IF] ( flag -- ) IMMEDIATE 0= IF 0 BEGIN PARSE-NAME 2>R 2R@ "[IF]" COMPARE 0= IF 1+ - ELSE 2R@ "[THEN]" COMPARE 0= OR-ELSE 2R@ "[ELSE]" COMPARE 0= THEN IF + ELSE-IF 2R@ "[THEN]" COMPARE 0= OR-ELSE 2R@ "[ELSE]" COMPARE 0= THEN THEN-IF ?DUP 0= IF 2RDROP EXIT THEN 1- - THEN THEN + THEN 2RDROP AGAIN THEN ; \ Skips words until matching [THEN] \ Skips over nested [IF] … [THEN] or [IF] … [ELSE] … [THEN] structures -: [ELSE] IMMEDIATE +: [ELSE] IMMEDIATE 0 BEGIN PARSE-NAME 2>R 2R@ "[IF]" COMPARE 0= IF 1+ - ELSE 2R@ "[THEN]" COMPARE 0= IF + ELSE-IF 2R@ "[THEN]" COMPARE 0= THEN-IF ?DUP 0= IF 2RDROP EXIT THEN 1- - THEN THEN + THEN 2RDROP AGAIN ; \ [THEN] is just a placeholder to terminate [IF] or [ELSE]; no compilation effect -: [THEN] IMMEDIATE ; - -\ Read the next word and return the first character -: CHAR ( "name" -- c ) - PARSE-NAME DROP C@ ; +: [THEN] IMMEDIATE ; >>SYSTEM @@ -1446,26 +1460,30 @@ DEFER REFILL 32 CONSTANT BUDDY-MIN-BYTES 18 CONSTANT BUDDY-ORDERS -: BUDDY-ORDER-BYTES ( order -- n-bytes ) BUDDY-MIN-BYTES SWAP LSHIFT ; +: BUDDY-ORDER-BYTES ( order -- n-bytes ) BUDDY-MIN-BYTES SWAP LSHIFT ; BUDDY-ORDERS 1- BUDDY-ORDER-BYTES CONSTANT BUDDY-MAX-BYTES BUDDY-ORDERS ARRAY BUDDY-HEADS { BUDDY-ORDERS 0 ?DO 0 I BUDDY-HEADS ! LOOP } EXECUTE -: BUDDY-FREE ( a-addr order -- ) - TUCK 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 +: ?BUDDY-ORDER ( order -- ) + BUDDY-ORDERS U>= "order out of bounds" ?FAIL ; + +: ?BUDDY-ALIGNED ( a-addr order -- ) + SWAP BUDDY-ORDER-BYTES 1- AND "address is not naturally aligned" ?FAIL ; + +: BUDDY-FREE ( a-addr order -- ) + TUCK ?BUDDY-ORDER ▪ 2DUP ?BUDDY-ALIGNED ▪ >R DUP BUDDY-HEADS BEGIN - ( S: order head-addr ) ( R: a-addr ) + ( S: order head-addr R: a-addr ) DUP @ DUP NULL= IF \ Append to end of list DROP NULL R@ ! R> SWAP ! DROP EXIT THEN - ( S: order head-addr block-addr ) ( R: freed-addr ) + ( S: order head-addr block-addr R: freed-addr ) 2 PICK 1+ BUDDY-ORDERS < AND-THEN DUP 3 PICK BUDDY-ORDER-BYTES XOR R@ = THEN AND-THEN @@ -1483,26 +1501,27 @@ BUDDY-ORDERS ARRAY BUDDY-HEADS THEN AGAIN ; -: BUDDY-ALLOCATE ( order -- a-addr ) RECURSIVE - DUP BUDDY-ORDERS U>= "order out of bounds" ?FAIL +: BUDDY-ALLOCATE ( order -- a-addr ) RECURSIVE + DUP ?BUDDY-ORDER 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 + SWAP BUDDY-FREE ; -: BUDDY-ORDER-FROM-BYTES ( u-bytes -- order ) +: BUDDY-ORDER-FROM-BYTES ( u-bytes -- order ) DUP 0= OR-ELSE DUP DUP 1- AND THEN "buddy allocator block size is not a power of two" ?FAIL DUP BUDDY-MIN-BYTES - [[ BUDDY-MAX-BYTES BUDDY-MIN-BYTES - ]] 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 ; +: BUDDY-COUNT ( order -- u ) + DUP ?BUDDY-ORDER ▪ BUDDY-HEADS @ 0 SWAP BEGIN ?DUP WHILE @ SWAP 1+ SWAP REPEAT ; VARIABLE TOTAL >>UTILITY -: BUDDY-STATS ( -- ) +: BUDDY-STATS 0 TOTAL ! BUDDY-ORDERS 0 DO I BUDDY-COUNT ?DUP IF @@ -1528,15 +1547,15 @@ VARIABLE TOTAL >>UTILITY \ Simple wrapper for munmap() that retries on EINTR -: MMAP-UNMAP ( addr length -- ) +: MMAP-UNMAP ( addr length -- ) DUP IF SYS_MUNMAP SYSCALL2-RETRY DROP ELSE 2DROP THEN ; -: MMAP-ALLOCATE ( size -- a-addr ) +: MMAP-ALLOCATE ( size -- a-addr ) NULL SWAP PROT_READ PROT_WRITE OR MAP_PRIVATE MAP_ANONYMOUS OR -1 0 SYS_MMAP2 SYSCALL6-RETRY DUP -4095 U>= IF EXCP-HEAP-OVERFLOW THROW THEN ; -: MMAP-ALLOCATE-ALIGNED ( size -- a-addr ) +: MMAP-ALLOCATE-ALIGNED ( size -- a-addr ) NATURALLY-ALIGNED DUP 2* MMAP-ALLOCATE SWAP ( S: addr size ) @@ -1560,15 +1579,15 @@ ENDSTRUCT MEMBLOCK% 0 MEMBLOCK>DATA CONSTANT MEMBLOCK-DATA-OFFSET -: MEMBLOCK-CHECK-MAGIC ( memblock-addr -- ) +: MEMBLOCK-CHECK-MAGIC ( memblock-addr -- ) MEMBLOCK>MAGIC @ MEMBLOCK-MAGIC <> IF EXCP-INVALID-ADDRESS THROW THEN ; -: DATA>MEMBLOCK ( obj-addr -- memblock-addr ) +: DATA>MEMBLOCK ( obj-addr -- memblock-addr ) MEMBLOCK-DATA-OFFSET - DUP MEMBLOCK-CHECK-MAGIC ; >>FORTH -: ALLOCATE ( size -- obj-addr ) +: ALLOCATE ( size -- obj-addr ) DUP 0= IF EXIT THEN MEMBLOCK-DATA-OFFSET + DUP BUDDY-MAX-BYTES U> IF PAGESIZE ALIGNED-TO DUP MMAP-ALLOCATE @@ -1584,7 +1603,7 @@ ENDSTRUCT MEMBLOCK% MEMBLOCK-MAGIC OVER MEMBLOCK>MAGIC ! MEMBLOCK>DATA ; -: FREE ( obj-addr -- ) +: FREE ( obj-addr -- ) ?DUP IF DATA>MEMBLOCK ▪ 0 OVER MEMBLOCK>MAGIC ! ▪ DUP MEMBLOCK>SIZE @ DUP BUDDY-ORDERS U< IF BUDDY-FREE ELSE MMAP-UNMAP THEN @@ -1592,7 +1611,7 @@ ENDSTRUCT MEMBLOCK% >>UTILITY -: OBJECT-SIZE ( obj-addr -- size ) +: OBJECT-SIZE ( obj-addr -- size ) DUP IF DATA>MEMBLOCK DUP MEMBLOCK>MAGIC @ MEMBLOCK-MAGIC <> IF EXCP-INVALID-ADDRESS THROW THEN @@ -1609,7 +1628,7 @@ ENDSTRUCT MEMBLOCK% \ size or the original object size, whichever is less \ The returned address may be equal to obj-addr1; if it is not, the original \ obj-addr1 is freed and no longer valid -: RESIZE ( obj-addr1 size -- obj-addr1 | obj-addr2 | NULL ) +: RESIZE ( obj-addr1 size -- obj-addr1 | obj-addr2 | NULL ) DUP 0= IF DROP FREE NULL EXIT THEN OVER NULL= IF NIP ALLOCATE EXIT THEN OVER OBJECT-SIZE MEMBLOCK-DATA-OFFSET + @@ -1632,7 +1651,7 @@ ENDSTRUCT MEMBLOCK% \ Allocate memory to hold a copy of the data describe by c-addr and u \ This can be used to duplicate strings -: DUPLICATE ( c-addr u -- obj-addr u ) +: DUPLICATE ( c-addr u -- obj-addr u ) DUP ALLOCATE >R >R 2R@ CMOVE 2R> ; >>SYSTEM @@ -1642,28 +1661,28 @@ ENDSTRUCT MEMBLOCK% \ The cell count includes the xt and must be >=1 \ For example, if a-addr points to "4 xt x1 x2 x3" (ascending addresses) then \ this is equivalent to the sequence "x3 x2 x1 xt EXECUTE" -: (CLOSURE) ( i*x a-addr -- j*x ) +: (CLOSURE) ( i*x a-addr -- j*x ) DUP @ SWAP CELL+ N@ EXECUTE ; >>FORTH \ Read one cell and increment -: @(+) ( a-addr1 -- a-addr2 x ) DUP CELL+ SWAP @ ; +: @(+) ( a-addr1 -- a-addr2 x ) DUP CELL+ SWAP @ ; \ Store cell and increment; note the arguments are opposite of ! to improve flow -: !(+) ( a-addr1 data -- a-addr2 ) OVER ! CELL+ ; +: !(+) ( a-addr1 data -- a-addr2 ) OVER ! CELL+ ; \ Store xt1 and xu ... x1 in a "closure object" and return an execution token. \ The execution token may be passed to FREE-CLOSURE to release the memory when \ the closure is no longer needed. When executed, the closure xt will place \ xu ... x1 on the data stack and then execute the captured xt1. -: CLOSURE ( xu ... x1 xt1 u -- xt2 ) +: CLOSURE ( xu ... x1 xt1 u -- xt2 ) 1+ DUP 5 + CELLS ALLOCATE DUP 2 CELLS+ >R \ name(0) link(NULL) codeword dataword #words xt x1 x2 x3 … 0 !(+) NULL !(+) DODOES !(+) [[ ' (CLOSURE) >DFA @ ]] !(+) OVER !(+) N! R> ; \ Return a closure which executes xt1 followed by xt2 -: COMPOSE ( xt1 xt2 -- xt3 ) +: COMPOSE ( xt1 xt2 -- xt3 ) { >R EXECUTE R> EXECUTE } 2 CLOSURE ; \ The xt points to the codeword, which is two cells above the base of the object @@ -1673,12 +1692,12 @@ ENDSTRUCT MEMBLOCK% \ It is assumed that ALLOCATE (but not ALLOT) returns an address suitably \ aligned for any primitive data type; %ALLOCATE is not suitable for data \ structures with unusually high alignment requirements -: %ALLOT ( align bytes -- a-addr ) SWAP ALIGN-TO HERE SWAP ALLOT ; -: %ALLOCATE ( align bytes -- a-addr ) %SIZEOF ALLOCATE ; +: %ALLOT ( align bytes -- a-addr ) SWAP ALIGN-TO HERE SWAP ALLOT ; +: %ALLOCATE ( align bytes -- a-addr ) %SIZEOF ALLOCATE ; \ Reserve data space for a data structure and give it a name \ The content is indeterminate and must be initialized before the first use -: %VARIABLE ( align bytes "name" -- ) %ALLOT CONSTANT ; +: %VARIABLE ( align bytes "name" -- ) %ALLOT CONSTANT ; >>SYSTEM @@ -1694,32 +1713,32 @@ NULL CURRENT-ORDER ! >>FORTH \ Return the current search order -: GET-ORDER ( -- widn ... wid1 n ) +: GET-ORDER ( -- widn ... wid1 n ) { ?DUP IF DUP ORDER>WID @ >R ORDER>LINK @ RECURSE R> SWAP 1+ THEN } 0 CURRENT-ORDER @ ROT EXECUTE ; \ Add the word list wid as the first word list in the search order \ Semantically equivalent to: -\ : PUSH-ORDER ( wid -- ) >R GET-ORDER R> SWAP 1+ SET-ORDER ; -: PUSH-ORDER ( wid -- ) +\ : PUSH-ORDER ( wid -- ) >R GET-ORDER R> SWAP 1+ SET-ORDER ; +: PUSH-ORDER ( wid -- ) ORDER% %ALLOCATE TUCK ORDER>WID ! DUP CURRENT-ORDER XCHG SWAP ORDER>LINK ! ; \ Remove and return the first word list in the search order \ Semantically equivalent to: -\ : POP-ORDER ( -- wid ) GET-ORDER 1- SWAP >R SET-ORDER R> ; -: POP-ORDER ( -- wid | NULL ) +\ : POP-ORDER ( -- wid ) GET-ORDER 1- SWAP >R SET-ORDER R> ; +: POP-ORDER ( -- wid | NULL ) CURRENT-ORDER @ DUP IF DUP ORDER>LINK @ CURRENT-ORDER ! DUP ORDER>WID @ SWAP FREE THEN ; \ Return the first word list in the search order -: PEEK-ORDER ( -- wid | NULL ) +: PEEK-ORDER ( -- wid | NULL ) CURRENT-ORDER @ DUP IF ORDER>WID @ THEN ; \ Set the current search order -: SET-ORDER ( widn ... wid1 n | -n -- ) +: SET-ORDER ( widn ... wid1 n | -n -- ) DUP 0< IF DROP FORTH-WORDLIST 1 THEN \ Free the previous search order linked list NULL CURRENT-ORDER XCHG BEGIN ?DUP WHILE DUP ORDER>LINK @ SWAP FREE REPEAT @@ -1734,35 +1753,35 @@ BOOTSTRAP-GET-ORDER SET-ORDER \ Create a new wordlist \ In this implementation a word list is just a pointer to the most recent word -: WORDLIST ( -- wid ) +: WORDLIST ( -- wid ) ALIGN HERE NULL , ; \ Make the first list in the search order the current compilation word list -: DEFINITIONS ( -- ) PEEK-ORDER SET-CURRENT ; +: DEFINITIONS PEEK-ORDER SET-CURRENT ; \ 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 ) +\ 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 ) +: 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 ; +: 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 ; +: 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 ) +: SEARCH-WORDLIST ( c-addr u wid -- c-addr u 0 | xt 1 | xt -1 ) SWAP F_LENMASK UMIN 0 ROT { >R DROP 2DUP R@ >NAME COMPARE 0= IF 2DROP R> DUP IMMEDIATE? 1 OR TRUE @@ -1772,24 +1791,25 @@ BOOTSTRAP-GET-ORDER SET-ORDER } WITH-VISIBLE ; \ Search-Order extension words -: ALSO ( -- ) PEEK-ORDER PUSH-ORDER ; -: ONLY ( -- ) -1 SET-ORDER ; -: ORDER ( -- ) +: ALSO PEEK-ORDER PUSH-ORDER ; +: ONLY -1 SET-ORDER ; +: ORDER "Order:" TYPE GET-ORDER 0 ?DO SPACE U. LOOP EOL "Current: " TYPE GET-CURRENT U. EOL ; -: PREVIOUS ( -- ) POP-ORDER DROP ; +: PREVIOUS POP-ORDER DROP ; \ Define a new named wordlist \ Executing the word will replace the first item in the search order -: VOCABULARY WORDLIST CREATE , DOES> @ POP-ORDER DROP PUSH-ORDER ; +: VOCABULARY ( "name" ) + CREATE NULL , + DOES> POP-ORDER DROP PUSH-ORDER ; \ Names to select the predefined word lists \ FORTH is a Search-Order extension word -\ SYSTEM-WORDLIST has been deliberately omitted here -: FORTH ( -- ) FORTH-WORDLIST POP-ORDER DROP PUSH-ORDER ; -: LINUX ( -- ) LINUX-WORDLIST POP-ORDER DROP PUSH-ORDER ; -: UTILITY ( -- ) UTILITY-WORDLIST POP-ORDER DROP PUSH-ORDER ; -: SYSTEM ( -- ) SYSTEM-WORDLIST POP-ORDER DROP PUSH-ORDER ; +: FORTH FORTH-WORDLIST POP-ORDER DROP PUSH-ORDER ; +: LINUX LINUX-WORDLIST POP-ORDER DROP PUSH-ORDER ; +: UTILITY UTILITY-WORDLIST POP-ORDER DROP PUSH-ORDER ; +: SYSTEM SYSTEM-WORDLIST POP-ORDER DROP PUSH-ORDER ; \ Create a word to revert the search order, data space, and compilation word list \ to their respective states from immediately before the marker was defined. @@ -1798,10 +1818,10 @@ BOOTSTRAP-GET-ORDER SET-ORDER : MARKER ( "name" -- ) HERE ▪ LATEST ▪ GET-CURRENT ▪ GET-ORDER CREATE ▪ DUP 4 + ▪ DUP 1+ ▪ HERE ▪ OVER CELLS ALLOT ▪ N! - DOES> ( -- ) @(+) SWAP N@ ▪ SET-ORDER ▪ SET-CURRENT ▪ LATEST! ▪ CP ! ; + DOES> @(+) SWAP N@ ▪ SET-ORDER ▪ SET-CURRENT ▪ LATEST! ▪ CP ! ; \ Apply SEARCH-WORDLIST to each word list in the current search order -: FIND ( c-addr u -- c-addr u 0 | xt 1 | xt -1 ) +: FIND ( c-addr u -- c-addr u 0 | xt 1 | xt -1 ) 2>R GET-ORDER BEGIN ?DUP @@ -1816,17 +1836,20 @@ BOOTSTRAP-GET-ORDER SET-ORDER >>UTILITY \ 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-OR-THROW ( c-addr u -- xt 1 | xt -1 ) FIND ?DUP 0= IF EXCP-UNDEFINED-WORD -ROT THROW-STRING THEN ; >>FORTH \ 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 -: ' ( "ccc" -- xt ) PARSE-NAME FIND-OR-THROW DROP ; +: ' ( "name" -- xt ) PARSE-NAME FIND-OR-THROW DROP ; + +\ "Append to"; set the compilation namespace to the given vocabulary (e.g. FORTH) +: >> ( "name" -- ) ' ALSO EXECUTE DEFINITIONS PREVIOUS ; \ Read a word and append its compilation semantics to the current definition. -: POSTPONE ( "name" -- ) IMMEDIATE +: POSTPONE ( "name" -- ) IMMEDIATE PARSE-NAME FIND-OR-THROW 0< IF COMPILE, ELSE @@ -1836,34 +1859,34 @@ BOOTSTRAP-GET-ORDER SET-ORDER \ Shorthand for { ' DEFER! } or { [[ ' ]] DEFER! } depending on STATE \ If used during compilation, capture the name immediately but set target at runtime -: IS ( "ccc" -- ; xt -- ) IMMEDIATE - ( Interpret: xt "ccc" -- ) +: IS ( "name" -- ; xt -- ) IMMEDIATE + ( Interpret: xt "name" -- ) ' STATE @ IF POSTPONE LITERAL POSTPONE DEFER! ELSE DEFER! THEN ; \ 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 "name" -- ) IMMEDIATE +: TO ( x "name" -- ) IMMEDIATE ' >BODY STATE @ IF POSTPONE LITERAL POSTPONE ! ELSE ! THEN ; \ Hide the named word: HIDE -: HIDE ( "ccc" -- ) ' (HIDE) ; +: HIDE ( "name" -- ) ' (HIDE) ; \ Begin a new colon definition; hide & redirect the previous \ (deferred) word with the same name to the new definition -: :FINALIZE ( "ccc" -- ) +: :FINALIZE ( "name" -- ) : LATEST DUP >NAME FIND-OR-THROW DROP DUP (HIDE) DEFER! ; \ Produce the size or alignment of the subsequent type descriptor as a literal \ The type-name should be a word like CELL% returning an alignment and a size -: SIZEOF ( "" -- size ) IMMEDIATE +: SIZEOF ( "" -- size ) IMMEDIATE ' EXECUTE %SIZEOF STATE @ IF POSTPONE LITERAL THEN ; -: ALIGNOF ( "" -- size ) IMMEDIATE +: ALIGNOF ( "" -- size ) IMMEDIATE ' EXECUTE %ALIGNOF STATE @ IF POSTPONE LITERAL THEN ; \ Product the offset of the subsequent field name as a literal \ The field-name should be a word which adds a field offset to a given address -: OFFSETOF ( "" -- offset ) IMMEDIATE +: OFFSETOF ( "" -- offset ) IMMEDIATE 0 ' EXECUTE STATE @ IF POSTPONE LITERAL THEN ; \ Save the single-cell value at addr and then execute xt @@ -1871,7 +1894,7 @@ BOOTSTRAP-GET-ORDER SET-ORDER : PRESERVED ( i*x xt addr -- j*x ) DUP @ >R >R CATCH 2R> ! RETHROW ; ->>SYSTEM +>> SYSTEM \ The size of this buffer will determine the maximum line length 4096 CONSTANT TERMINAL-BUFFER-BYTES @@ -1881,7 +1904,7 @@ TERMINAL-BUFFER-BYTES ALLOCATE CONSTANT TERMINAL-BUFFER 2VARIABLE TIB-LEFTOVER NULL 0 TIB-LEFTOVER 2! ->>FORTH +>> FORTH \ Attempt to replace the parse area with the next line from the current source \ Return TRUE if the parse area was refilled, or FALSE otherwise @@ -1921,12 +1944,19 @@ NULL 0 TIB-LEFTOVER 2! DUP IF 0 >IN ! THEN 0<> ; ->>UTILITY +>> UTILITY -: ESCAPED-CHAR ( "" | "c" -- c ) +\ Parse up to limit digits in the given base, appending them to u1 to produce u2. +: ESCAPED-DIGITS ( u1 base limit -- u2 ) + 0 ?DO + PEEK-CHAR OVER >DIGIT-BASE 0= IF LEAVE THEN + SKIP-CHAR ▪ >R TUCK * ▪ R> + SWAP + LOOP ▪ DROP ; + +\ Read one logical string character, which may be an escape sequence +: ESCAPED-CHAR ( "" | "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 @@ -1934,45 +1964,56 @@ NULL 0 TIB-LEFTOVER 2! [[ CHAR v ]] OF 11 ENDOF [[ CHAR f ]] OF 12 ENDOF [[ CHAR r ]] OF 13 ENDOF + [[ CHAR e ]] OF 27 ENDOF [[ CHAR " ]] OF [[ CHAR " ]] ENDOF [[ CHAR ' ]] OF [[ CHAR ' ]] ENDOF [[ CHAR \ ]] OF [[ CHAR \ ]] ENDOF - "Unknown escape sequence" FAIL + TO-LOWER [[ CHAR x ]] OF + NEXT-CHAR 16 >DIGIT-BASE 0= "Invalid \\x… escape sequence" ?FAIL + 16 1 ESCAPED-DIGITS + ENDOF + DUP 8 >DIGIT-BASE 0= "Unknown escape sequence" ?FAIL + 8 2 ESCAPED-DIGITS SWAP ENDCASE THEN ; ->>SYSTEM +>> SYSTEM 2VARIABLE STRING-BUFFER NULL 0 STRING-BUFFER 2! ->>UTILITY +>> UTILITY \ Read a literal character string up to the next double-quote character \ The string is stored in a transient buffer and will become invalid when \ the next string is read; both the address and content may change \ The delimiting double-quote character is removed from the input buffer \ Double-quote and backslash characters can be escaped with a backslash -: READSTRING ( "ccc" -- c-addr u ) +: READSTRING ( "ccc" -- c-addr u ) STRING-BUFFER 2@ 0 ( S: addr length index ) BEGIN - PARSE-EMPTY? OR-ELSE PEEK-CHAR [[ CHAR " ]] = DUP IF SKIP-CHAR THEN THEN 0= + PARSE-EMPTY? 0= + WHILE + PEEK-CHAR [[ CHAR " ]] <> + DUP 0= IF SKIP-CHAR THEN WHILE 2DUP <= IF \ Grow the buffer by at least 50% + 16 bytes \ Store the actual allocated object size, not the requested size - -ROT DUP 2/ + 16 + RESIZE DUP OBJECT-SIZE + -ROT DUP U2/ + 16 + RESIZE DUP OBJECT-SIZE 2DUP STRING-BUFFER 2! ROT THEN ROT 2DUP + ESCAPED-CHAR SWAP C! -ROT 1+ REPEAT ▪ NIP ; ->>SYSTEM +>> SYSTEM -\ Read a word, number, or string and either execute it or compile it +: ?STACK SP@ S0 > IF ▪ S0 SP! ▪ EXCP-STACK-UNDERFLOW THROW ▪ THEN ; + +\ Read a series of words, numbers, and strings and execute them or compile them \ The stack effect depends on the input and the current value of STATE -: INTERPRET ( i*x "ccc" -- j*x ) +: INTERPRET ( i*x "ccc…" -- j*x ) BEGIN SKIP-SPACES PARSE-EMPTY? 0= @@ -1995,19 +2036,20 @@ NULL 0 STRING-BUFFER 2! 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 + 0< ▪ OR-ELSE STATE @ 0= THEN ▪ IF EXECUTE ELSE COMPILE, THEN THEN THEN + ?STACK REPEAT ; ->>FORTH +>> FORTH -: EVALUATE ( i*x c-addr u -- j*x ) +: EVALUATE ( i*x c-addr u -- j*x ) SAVE-INPUT N>R ▪ SOURCE 2>R ▪ SOURCE-ID >R 0 >IN ! ▪ INPUT-BUFFER 2! ▪ -1 CURRENT-SOURCE-ID ! ▪ INTERPRET R> CURRENT-SOURCE-ID ! ▪ 2R> INPUT-BUFFER 2! ▪ NR> RESTORE-INPUT DROP ; ->>LINUX +>> LINUX ' unsigned-char% ALIAS cc% ' unsigned-int% ALIAS speed% @@ -2026,19 +2068,19 @@ ENDSTRUCT termios% 0x5401 CONSTANT IOCTL_TCGETS ->>SYSTEM +>> SYSTEM termios% %VARIABLE SCRATCH-TERMIOS ->>FORTH +>> FORTH -: TTY? ( fd -- flag ) +: TTY? ( fd -- flag ) IOCTL_TCGETS SCRATCH-TERMIOS SYS_IOCTL SYSCALL3 0= ; STDIN TTY? CONSTANT INTERACTIVE? \ Empty the return stack, make stdin the input source, and enter interpretation state -{ ( -- ) +:FINALIZE QUIT ( -- ) CATCHING? IF EXCP-QUIT THROW THEN R0 RSP! 0 CURRENT-SOURCE-ID ! @@ -2050,10 +2092,9 @@ STDIN TTY? CONSTANT INTERACTIVE? [ INTERACTIVE? ] [IF] STATE @ 0= IF "OK\n" TYPE THEN [THEN] - AGAIN -} IS QUIT + AGAIN ; ->>SYSTEM +>> SYSTEM 32 CONSTANT #REPORTERS #REPORTERS 2ARRAY REPORTERS ( reporter-xt exception-code ) @@ -2071,14 +2112,14 @@ REVERT THEN ▪ 2DROP LOOP ▪ DROP NULL FALSE ; ->>UTILITY +>> UTILITY \ Set the reporter for the given exception code : REPORTER! ( xt n -- ) ( xt: -- ) DUP REPORTER DROP ▪ DUP NULL= "hash table is full" ?FAIL ▪ 2! ; \ Run the reporter for the given exception code, or give the default report -: REPORT ( n -- ) +: REPORT ( n -- ) DUP REPORTER IF NIP THROWN-STRING 2@ ROT 2@ DROP EXECUTE ELSE @@ -2086,7 +2127,7 @@ REVERT DUP ▪ ABS 0 <# #S ROT SIGN #> ▪ TYPE-ERR EOL ; THEN ; ->>SYSTEM +>> SYSTEM { ( no message for ABORT ) } EXCP-ABORT REPORTER! { THROWN-STRING 2@ TYPE-ERR "\n" TYPE-ERR } EXCP-FAIL REPORTER! @@ -2103,6 +2144,7 @@ REVERT EXCP-PNO-OVERFLOW REPORTER! { "Invalid numeric argument\n" TYPE-ERR } EXCP-BAD-NUMERIC-ARGUMENT REPORTER! { "File I/O exception\n" TYPE-ERR } EXCP-FILE-IO REPORTER! +{ "Unexpected end of file\n" TYPE-ERR } EXCP-UNEXPECTED-EOF REPORTER! { "Quit\n" TYPE-ERR } EXCP-QUIT REPORTER! { "Out of memory\n" TYPE-ERR } EXCP-HEAP-OVERFLOW REPORTER! @@ -2126,74 +2168,63 @@ DEFINITIONS ALSO UTILITY \ Define a threaded word which also displays its name and the data stack when called -: (TRACE) >NAME TYPE SPACE .S ; -: :TRACE : LATEST POSTPONE LITERAL POSTPONE (TRACE) ; -HIDE (TRACE) +>> UTILITY +: (TRACE) ( xt -- ) >NAME TYPE SPACE .S ; +>> FORTH +: :TRACE ( "name" -- ) : LATEST POSTPONE LITERAL POSTPONE (TRACE) ; \ 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 +: WORD? ( addr -- flag ) + >R ▪ GET-ORDER ▪ GET-CURRENT SWAP 1+ + BEGIN ?DUP WHILE 1- SWAP R@ FALSE ROT - ( S: widn ... wid1 n addr FALSE wid ) ( R: addr ) + ( 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 ; + 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 -- "" | "" ) - \ Is it some kind of word, and if so, is the name zero-length (:NONAME)? - DUP WORD? AND-THEN DUP >NAME DUP ?DUP 0= IF NIP THEN THEN IF +: .W ( addr -- "" | "" ) + \ Is it some kind of word, and if so, is the name not zero-length (:NONAME)? + DUP WORD? ▪ AND-THEN DUP >NAME NIP 0<> THEN ▪ IF \ Is the name hidden? - 2 PICK HIDDEN? IF + DUP 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 + DUP >NAME FIND ▪ AND-THEN OVER = ELSE NIP NIP THEN ▪ 0= IF "¤" TYPE THEN THEN - TYPE - DROP + >NAME TYPE ELSE \ Not a named word in the current search order or compilation word list "∷" TYPE U. THEN ; +>> UTILITY + \ Display a string in escaped (double-quoted) format, without the delimiters -: TYPE-ESCAPED ( c-addr u -- "" ) - 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 ; +: CONTROL-CHAR? ( ch -- flag ) DUP 32 U< SWAP 127 = OR ; +: TYPE-ESCAPED ( c-addr u -- "" ) + 0 ?DO DUP C@ + DUP 7 14 WITHIN IF + DUP 7 - 2* "\\a\\b\\t\\n\\v\\f\\r" DROP + 2 + ELSE-IF DUP 27 = THEN-IF "\\e" + ELSE-IF DUP [[ CHAR " ]] = THEN-IF "\\\"" + ELSE-IF DUP [[ CHAR \ ]] = THEN-IF "\\\\" + ELSE DUP 0 + <# OVER CONTROL-CHAR? IF 16 #B 16 #B "\\x" HOLDS ELSE OVER HOLD THEN #> + THEN ▪ TYPE ▪ DROP 1+ + LOOP ▪ DROP ; \ Recognize the pattern BRANCH a:{c-a} {name} {link} b:{codeword} {…} c:LIT d:{b} \ This pattern is generated by the { … } inline :NONAME syntax -: NONAME-LITERAL? ( a-addr -- flag ) +: NONAME-LITERAL? ( a-addr -- flag ) @(+) [[ ' BRANCH ]] = AND-THEN DUP @ DUP 5 CELLS >= AND-THEN ( S: addr-a offset-c-a ) @@ -2206,53 +2237,42 @@ HIDE (TRACE) ELSE NIP THEN THEN NIP ; -ALSO UTILITY +>> UTILITY \ 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 +: UNTHREAD ( a-addr -- ) RECURSIVE DUP >R BEGIN - @(+) - DUP [[ ' EXIT ]] = AND-THEN OVER R@ U> THEN IF - 2DROP RDROP EXIT + @(+) DUP [[ ' EXIT ]] <> OR-ELSE OVER R@ U<= THEN + WHILE + DUP [[ ' LIT ]] = IF + DROP @(+) DUP WORD? IF "[[ ' " TYPE .W " ]] " TYPE ELSE . SPACE THEN + ELSE-IF DUP [[ ' 2LIT ]] = THEN-IF + DROP "[ " TYPE + @(+) >R @(+) DUP WORD? IF "' " TYPE .W ELSE U. THEN SPACE + R> DUP WORD? IF "' " TYPE .W ELSE U. THEN + " ] 2LITERAL " TYPE + ELSE-IF DUP [[ ' LITSTRING ]] = THEN-IF + DROP DUP 1+ SWAP C@ 2DUP "\"" TYPE TYPE-ESCAPED "\" " TYPE + ALIGNED + ELSE-IF OVER CELL- NONAME-LITERAL? THEN-IF + DROP DUP @ OVER + 2 CELLS+ DUP R> UMAX >R SWAP + "{ " TYPE 3 CELLS+ >DFA @ UNTHREAD "} " TYPE + ELSE-IF DUP [[ ' BRANCH ]] = OR-ELSE DUP [[ ' 0BRANCH ]] = THEN 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 - CASE - [[ ' LIT ]] OF - @(+) DUP WORD? IF "[[ ' " TYPE .W " ]] " TYPE ELSE . SPACE THEN - ENDOF - [[ ' 2LIT ]] OF - "[ " TYPE @(+) >R @(+) U. SPACE R> . " ] 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 3 CELLS+ >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 ; + REPEAT ▪ 2DROP RDROP ; -HIDE NONAME-LITERAL? - -: (SEE) ( xt -- ) +: (SEE) ( xt -- ) DUP >CFA @ CASE DOCOL OF - ": " TYPE DUP >NAME TYPE " " TYPE + DUP >NAME DUP IF ": " TYPE TYPE SPACE ELSE 2DROP ":NONAME " TYPE THEN DUP IMMEDIATE? IF "IMMEDIATE " TYPE THEN >DFA @ UNTHREAD ";\n" TYPE ENDOF @@ -2274,13 +2294,11 @@ HIDE NONAME-LITERAL? SWAP "CREATE " TYPE >NAME TYPE " … ;CODE … END-CODE\n" TYPE ENDCASE ; -PREVIOUS +>> FORTH -: SEE ( "name" -- ) ' (SEE) ; +: SEE ( "name" -- ) ' (SEE) ; -HIDE UNTHREAD - -: WORDS ( -- ) +: WORDS GET-ORDER ?DUP IF 1- SWAP >R NDROP R> SHOW-WORDLIST THEN ; \ In the next few definitions link-xt is a function that takes a node address @@ -2291,14 +2309,16 @@ HIDE UNTHREAD \ node at the beginning of a list, or NULL if the list is empty. &link is the \ address of either a cell holding the head of the list or a node's link field. +>> UTILITY + \ Put the even items from head into head1 and the odd items into head2 -: SPLIT ( head link-xt -- head1 head2 ) +: SPLIT ( head link-xt -- head1 head2 ) >R NULL NULL ROT BEGIN ?DUP WHILE TUCK R@ EXECUTE XCHG >R SWAP R> REPEAT RDROP SWAP ; \ Merge two sorted lists into a single sorted list -: MERGE ( head1 head2 link-xt compare-xt -- head ) +: MERGE ( head1 head2 link-xt compare-xt -- head ) 2>R NULL >R RSP@ BEGIN ( S: head1 head2 &link R: link-xt compare-xt head ) \ If either list is empty we're done; append the other to the result and exit @@ -2315,8 +2335,10 @@ HIDE UNTHREAD ( S: head1 head2' &link2 R: link-xt compare-xt head ) AGAIN ; +>> FORTH + \ Return TRUE if the given list is sorted, or FALSE otherwise -: SORTED? ( head link-xt compare-xt -- flag ) +: SORTED? ( head link-xt compare-xt -- flag ) \ An empty list is trivially sorted 2>R ?DUP NULL= IF 2RDROP TRUE EXIT THEN BEGIN @@ -2334,21 +2356,19 @@ HIDE UNTHREAD \ 2. Otherwise, split the list into two approximately equal sublists. \ 3. Sort both sublists recursively. \ 4. Merge the sorted sublists into a single sorted list. -: MERGE-SORT ( head1 link-xt compare-xt -- head2 ) RECURSIVE +: MERGE-SORT ( head1 link-xt compare-xt -- head2 ) RECURSIVE 2>R DUP 2R@ SORTED? 0= IF 1 RPICK SPLIT 2R@ MERGE-SORT SWAP 2R@ MERGE-SORT 2R@ MERGE THEN 2RDROP ; \ Sort in descending order by negating the result of compare-xt -: MERGE-SORT> ( head1 link-xt compare-xt -- head2 ) +: MERGE-SORT> ( head1 link-xt compare-xt -- head2 ) [[ ' NEGATE ]] COMPOSE DUP >R MERGE-SORT R> FREE-CLOSURE ; -HIDE SPLIT -HIDE MERGE - FORTH-WORDLIST 1 SET-ORDER +DEFINITIONS -: BANNER "JumpForth version " TYPE VERSION . ", by Jesse McDonald\n" TYPE ; +: BANNER "JumpForth version " TYPE VERSION . ", by Jesse McDonald\n" TYPE ; INTERACTIVE? [IF] BANNER [THEN] QUIT diff --git a/test/multi-if.4th b/test/multi-if.4th new file mode 100644 index 0000000..1ecf5cf --- /dev/null +++ b/test/multi-if.4th @@ -0,0 +1,10 @@ +: TEST + DUP . ": " TYPE + DUP 1 = IF "1\n" TYPE + ELSE-IF DUP 2 = THEN-IF "2\n" TYPE + ELSE-IF DUP 0<= THEN-IF "nonpositive\n" TYPE + ELSE-IF DUP 5 <= THEN-IF "3…5\n" TYPE + ELSE "other\n" TYPE + THEN DROP ; + +{ 7 0 ?DO I TEST LOOP } EXECUTE diff --git a/test/multi-if.exp b/test/multi-if.exp new file mode 100644 index 0000000..f8265bd --- /dev/null +++ b/test/multi-if.exp @@ -0,0 +1,8 @@ +0: nonpositive +1: 1 +2: 2 +3: 3…5 +4: 3…5 +5: 3…5 +6: other +exit-code: 0 diff --git a/test/numeric-literals.4th b/test/numeric-literals.4th index 73f5507..83e6d03 100644 --- a/test/numeric-literals.4th +++ b/test/numeric-literals.4th @@ -1,4 +1,6 @@ +ALSO UTILITY : INSPECT ( c-addr u -- ) "\"" TYPE TYPE-ESCAPED "\"" TYPE ; +PREVIOUS : REPORT ( c-addr1 u1 c-addr2 u2 xt -- ) -ROT 2>R >R 2DUP INSPECT " ( " TYPE EVALUATE DUP R@ EXECUTE " ) ⇔ " TYPE