nybble
/
jumpforth
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

simplify conditionals; rename ONWARD-IF to AND-IF; remove AND-THEN and OR-ELSE

This commit is contained in:
Jesse D. McDonald 2020-11-11 00:18:57 -06:00
parent e533756d25
commit ff2d91b66b
4 changed files with 140 additions and 146 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

243
startup.4th
View File

@ -870,77 +870,55 @@ __O_TMPFILE O_DIRECTORY OR ⇒ O_TMPFILE
\ ELSE inserts an unconditional branch (to THEN) and also resolves the \ ELSE inserts an unconditional branch (to THEN) and also resolves the
\ previous forward reference (from IF). \ previous forward reference (from IF).
\ \
\ Via ONWARD-IF and ONWARD-AHEAD the unresolve branch offset cell may be used \ Via AND-IF and ONWARD-AHEAD the unresolve branch offset cell may be used
\ as the link field of a linked list to connect multiple forward branches to \ as the link field of a linked list to connect multiple forward branches to
\ the same THEN. When THEN is executed it will follow the links and update all \ the same THEN. When THEN is executed it will follow the links and update all
\ the connected branches to the same location. The list is terminated with NULL \ the connected branches to the same location. The list is terminated with NULL
\ in the link field. Example: \ in the link field. Example:
\ \
\ \ The IF and ONWARD-IF both branch to <code2> if the condition is false \ \ The IF and AND-IF both branch to <code2> if the condition is false
\ \ This is functionally a short-circuit AND condition \ \ This is functionally a short-circuit AND condition
\ \ Without the ELSE they would both branch to <code3> \ \ Without the ELSE they would both branch to <code3>
\ <cond1> IF <cond2> ONWARD-IF <code1> ELSE <code2> THEN <code3> \ <cond1> IF <cond2> AND-IF <code1> ELSE <code2> THEN <code3>
\ \
\ ALWAYS is provided as a placeholder; it has the same effect as TRUE IF but \ ALWAYS is provided as a placeholder; it has the same effect as TRUE IF but
\ includes no branch. The "orig" value it leaves on the stack (NULL) is ignored \ includes no branch. The "orig" value it leaves on the stack (NULL) is ignored
\ by THEN and marks the end of the list if consumed by ONWARD-IF or ONWARD-AHEAD. \ by THEN and marks the end of the list if consumed by AND-IF or ONWARD-AHEAD.
\ This can be used as a base for control structures with zero or more branches. \ This can be used as a base for control structures with zero or more branches.
' UTILITY (DEFINITIONS)
: (ALWAYS) ( C: -- null-orig ) IMMEDIATE
NULL ;
: (ONWARD-IF) ( C: orig1 -- orig2 ; flag -- ) IMMEDIATE
POSTPONE 0BRANCH HERE SWAP , ;
: (ONWARD-AHEAD) ( C: orig1 -- orig2 ) IMMEDIATE
POSTPONE BRANCH HERE SWAP , ;
: (THEN) ( C: orig -- ) IMMEDIATE
BEGIN ?DUP WHILE HERE OVER - SWAP XCHG REPEAT ;
: (IF) ( C: -- orig ; flag -- ) IMMEDIATE
POSTPONE (ALWAYS) POSTPONE (ONWARD-IF) ;
: (AHEAD) ( C: -- orig ; flag -- ) IMMEDIATE
POSTPONE (ALWAYS) POSTPONE (ONWARD-AHEAD) ;
' FORTH (DEFINITIONS) ' FORTH (DEFINITIONS)
\ <cond1> IF <code1> \ <cond1> IF <code1> {ELSE <code3>} THEN
\ {ELSE-IF <cond2> THEN-IF <code2>}… : ALWAYS ( C: -- orig ) IMMEDIATE
\ {ELSE <code3>} NULL ;
\ THEN : AND-IF ( C: orig1 -- orig2 ; flag -- ) IMMEDIATE
: IF ( C: -- orig-final orig-next ; flag -- ) IMMEDIATE POSTPONE 0BRANCH HERE SWAP , ;
POSTPONE (ALWAYS) POSTPONE (ALWAYS) POSTPONE (ONWARD-IF) ; : ONWARD-AHEAD ( C: orig1 -- orig2 ) IMMEDIATE
: ELSE-IF ( C: orig-final1 orig-next -- orig-final2 ) IMMEDIATE POSTPONE BRANCH HERE SWAP , ;
SWAP POSTPONE (ONWARD-AHEAD) SWAP POSTPONE (THEN) ; : THEN ( C: orig -- ) IMMEDIATE
: THEN-IF ( C: orig-final -- orig-final orig-next ; flag -- ) IMMEDIATE BEGIN ?DUP WHILE HERE OVER - SWAP XCHG REPEAT ;
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 : IF ( C: -- orig ; flag -- ) IMMEDIATE
\ Examples: POSTPONE ALWAYS POSTPONE AND-IF ;
\ <cond1> AND-THEN <cond2> THEN : AHEAD ( C: -- orig ; flag -- ) IMMEDIATE
\ <cond1> OR-ELSE <cond2> THEN POSTPONE ALWAYS POSTPONE ONWARD-AHEAD ;
: AND-THEN ( C: -- orig ) ( Runtime: flag -- FALSE | <dropped> ) IMMEDIATE
POSTPONE ?0DUP POSTPONE IF ; : ELSE ( C: orig1 -- orig2 ) IMMEDIATE
: OR-ELSE ( C: -- orig ) ( Runtime: flag -- nonzero-flag | <dropped> ) IMMEDIATE POSTPONE AHEAD SWAP POSTPONE THEN ;
POSTPONE ?DUP POSTPONE 0= POSTPONE IF ;
\ Unbounded loop: BEGIN <body> AGAIN \ Unbounded loop: BEGIN <body> AGAIN
\ Simple conditional loop: BEGIN <condition> UNTIL \ Simple conditional loop: BEGIN <condition> UNTIL
\ Mid-loop condition(s): BEGIN <cond1> WHILE {<cond2> WHILE}… <body> REPEAT \ Mid-loop condition(s): BEGIN <cond1> WHILE {<cond2> WHILE}… <body> REPEAT
\ Mixed WHILE/UNTIL loop: BEGIN <cond1> WHILE <cond2> UNTIL \ Mixed WHILE/UNTIL loop: BEGIN <cond1> WHILE {<cond2> WHILE}… <condN> UNTIL
: BEGIN ( C: -- null-orig dest ) IMMEDIATE : BEGIN ( C: -- null-orig dest ) IMMEDIATE
POSTPONE (ALWAYS) ▪ HERE ; POSTPONE ALWAYS ▪ HERE ;
: AGAIN ( C: orig dest -- ) IMMEDIATE : AGAIN ( C: orig dest -- ) IMMEDIATE
POSTPONE BRANCH ▪ HERE - , ▪ POSTPONE (THEN) ; POSTPONE BRANCH ▪ HERE - , ▪ POSTPONE THEN ;
: UNTIL ( C: orig dest -- ) ( Runtime: flag -- ) IMMEDIATE : 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 : WHILE ( C: orig1 dest -- orig2 dest ) ( Runtime: flag -- ) IMMEDIATE
SWAP POSTPONE (ONWARD-IF) SWAP ; SWAP POSTPONE AND-IF SWAP ;
: REPEAT ( C: orig dest -- ) IMMEDIATE : REPEAT ( C: orig dest -- ) IMMEDIATE
POSTPONE AGAIN ; POSTPONE AGAIN ;
@ -958,21 +936,24 @@ __O_TMPFILE O_DIRECTORY OR ⇒ O_TMPFILE
\ \
\ Begin by creating a placeholder for the unresolved ENDOF forward references \ Begin by creating a placeholder for the unresolved ENDOF forward references
: CASE ( C: -- null-orig ) IMMEDIATE : CASE ( C: -- null-orig ) IMMEDIATE
POSTPONE (ALWAYS) ; POSTPONE ALWAYS ;
\ At runtime test the flag on top of the stack; branch to ENDOF if false \ At runtime test the flag on top of the stack; branch to ENDOF if false
: OF? ( C: orig-case -- orig-case orig-of ; x flag -- x ) IMMEDIATE : OF? ( C: orig-case -- orig-case orig-of ; x flag -- x ) IMMEDIATE
POSTPONE (ALWAYS) POSTPONE (ONWARD-IF) POSTPONE DROP ; POSTPONE IF ;
\ Equivalent to TRUE OF?, but with one less branch
: OTHERWISE ( C: orig-case -- orig-case orig-of ; x -- x ) IMMEDIATE
POSTPONE ALWAYS ;
\ At runtime compare the values on the top of the stack; branch to ENDOF if unequal \ 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 \ Keep the first value for the next OF if unequal, otherwise consume both
: OF ( C: orign ... orig1 n -- orign ... orig1 n orig-of ) IMMEDIATE : OF ( C: orign ... orig1 n -- orign ... orig1 n orig-of ; x y -- {x} ) IMMEDIATE
POSTPONE OVER POSTPONE = POSTPONE OF? ; POSTPONE OVER POSTPONE = POSTPONE OF? POSTPONE DROP ;
\ Create a forward branch to ENDCASE and resolve the one from OF \ Create a forward branch to ENDCASE and resolve the one from OF
: ENDOF ( C: orig-case1 orig-of -- orig-case2 ) IMMEDIATE : ENDOF ( C: orig-case1 orig-of -- orig-case2 ) IMMEDIATE
SWAP POSTPONE (ONWARD-AHEAD) SWAP POSTPONE (THEN) ; SWAP POSTPONE ONWARD-AHEAD SWAP POSTPONE THEN ;
\ Drop the <x> value in case none of the OF...ENDOF clauses matched \ 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 \ Resolve all the forward branches from ENDOF to the location after ENDCASE
: ENDCASE ( C: orig-case -- ) IMMEDIATE : ENDCASE ( C: orig-case -- ) IMMEDIATE
POSTPONE DROP POSTPONE (THEN) ; POSTPONE DROP POSTPONE THEN ;
\ Range loop: <limit> <index> DO <code> LOOP \ Range loop: <limit> <index> DO <code> LOOP
\ <limit> <index> DO <code> <step> +LOOP \ <limit> <index> DO <code> <step> +LOOP
@ -981,19 +962,19 @@ __O_TMPFILE O_DIRECTORY OR ⇒ O_TMPFILE
CREATE LEAVE-ORIG NULL , CREATE LEAVE-ORIG NULL ,
: DO ( C: -- outer-stack dest ; limit index -- R: -- limit index ) IMMEDIATE : DO ( C: -- outer-stack dest ; limit index -- R: -- limit index ) IMMEDIATE
POSTPONE 2>R LEAVE-ORIG @ POSTPONE 2>R LEAVE-ORIG @
POSTPONE (ALWAYS) LEAVE-ORIG ! POSTPONE ALWAYS LEAVE-ORIG !
POSTPONE BEGIN ; POSTPONE BEGIN ;
: ?DO ( C: -- outer-stack dest ; limit index -- R: -- limit index ) IMMEDIATE : ?DO ( C: -- outer-stack dest ; limit index -- R: -- limit index ) IMMEDIATE
POSTPONE 2>R LEAVE-ORIG @ POSTPONE 2>R LEAVE-ORIG @
POSTPONE 2R@ POSTPONE <> POSTPONE (IF) LEAVE-ORIG ! POSTPONE 2R@ POSTPONE <> POSTPONE IF LEAVE-ORIG !
POSTPONE BEGIN ; POSTPONE BEGIN ;
: LEAVE ( C: -- ; -- R: limit index -- ) IMMEDIATE : LEAVE ( C: -- ; -- R: limit index -- ) IMMEDIATE
LEAVE-ORIG @ POSTPONE (ONWARD-AHEAD) LEAVE-ORIG ! ; LEAVE-ORIG @ POSTPONE ONWARD-AHEAD LEAVE-ORIG ! ;
: UNLOOP ( R: limit index -- ) IMMEDIATE : UNLOOP ( R: limit index -- ) IMMEDIATE
POSTPONE 2RDROP ; POSTPONE 2RDROP ;
: +LOOP ( C: outer-stack dest -- ; n -- R: {limit index} -- ) IMMEDIATE : +LOOP ( C: outer-stack dest -- ; n -- R: {limit index} -- ) IMMEDIATE
POSTPONE RSP@ POSTPONE +! POSTPONE 2R@ POSTPONE = POSTPONE UNTIL POSTPONE RSP@ POSTPONE +! POSTPONE 2R@ POSTPONE = POSTPONE UNTIL
LEAVE-ORIG @ POSTPONE (THEN) POSTPONE UNLOOP LEAVE-ORIG ! ; LEAVE-ORIG @ POSTPONE THEN POSTPONE UNLOOP LEAVE-ORIG ! ;
: LOOP ( C: outer-stack dest -- ; -- R: {limit index} -- ) IMMEDIATE : LOOP ( C: outer-stack dest -- ; -- R: {limit index} -- ) IMMEDIATE
1 POSTPONE LITERAL POSTPONE +LOOP ; 1 POSTPONE LITERAL POSTPONE +LOOP ;
' LEAVE-ORIG (HIDE) ' LEAVE-ORIG (HIDE)
@ -1112,7 +1093,7 @@ CREATE DISPLAY-ITEM-LIMIT 6 ,
\ Remove trailing whitespace from a string (only affects length) \ 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 ; BEGIN DUP WHILE 2DUP 1- + C@ SPACE? WHILE 1- REPEAT ;
\ Convert a character to lowercase or uppercase, respectively \ Convert a character to lowercase or uppercase, respectively
: TO-LOWER ( ch1 -- ch2 ) : TO-LOWER ( ch1 -- ch2 )
@ -1130,7 +1111,7 @@ CREATE DISPLAY-ITEM-LIMIT 6 ,
\ Like >DIGIT but only returns TRUE if ch is a valid digit for the given base \ Like >DIGIT but only returns TRUE if ch is a valid digit for the given base
: >DIGIT-BASE ( ch base -- u TRUE | FALSE ) : >DIGIT-BASE ( ch base -- u TRUE | FALSE )
SWAP >DIGIT AND-THEN SWAP 2DUP U< DUP 0= IF NIP THEN THEN NIP ; SWAP >DIGIT ?0DUP IF SWAP 2DUP U< DUP 0= IF NIP THEN THEN NIP ;
\ Convert a string in the given base to an unsigned double-cell number \ 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 \ Stop at the end of the string or when the next character is not valid for the base
@ -1165,13 +1146,13 @@ CREATE DISPLAY-ITEM-LIMIT 6 ,
R@ IF 1/STRING DUP 0= IF RDROP NIP EXIT THEN THEN R@ IF 1/STRING DUP 0= IF RDROP NIP EXIT THEN THEN
>NUMBER >NUMBER
R> IF 2SWAP DNEGATE 2SWAP THEN R> IF 2SWAP DNEGATE 2SWAP THEN
DUP 1 = AND-THEN OVER C@ [[ CHAR # ]] = THEN IF DUP 1 = IF OVER C@ [[ CHAR # ]] = AND-IF
2DROP 2 2DROP 2
ELSE-IF NIP 0= THEN-IF ELSE NIP 0= IF
DROP 1 DROP 1
ELSE ELSE
2DROP 0 2DROP 0
THEN ; THEN THEN ;
' PARSENUMBER ' BOOTSTRAP-PARSENUMBER DEFER! ' PARSENUMBER ' BOOTSTRAP-PARSENUMBER DEFER!
@ -1470,7 +1451,7 @@ DEFER REFILL
DUP IF DUP IF
LATEST LATEST
NULL OVER >LINK XCHG LATEST! NULL OVER >LINK XCHG LATEST!
POSTPONE (AHEAD) POSTPONE AHEAD
ROT ROT
POSTPONE [ POSTPONE [
THEN THEN
@ -1487,7 +1468,7 @@ DEFER REFILL
IF IF
( S: outer-xt orig inner-xt ) ( S: outer-xt orig inner-xt )
\ Resolve the forward branch over the inner definition \ Resolve the forward branch over the inner definition
-ROT POSTPONE (THEN) -ROT POSTPONE THEN
\ Re-append the outer definition to the word list \ Re-append the outer definition to the word list
LATEST OVER >LINK ! LATEST! LATEST OVER >LINK ! LATEST!
\ Return to compilation mode (was ended by ; ) \ Return to compilation mode (was ended by ; )
@ -1508,10 +1489,11 @@ DEFER REFILL
PARSE-NAME 2>R PARSE-NAME 2>R
2R@ "[IF]" COMPARE 0= IF 2R@ "[IF]" COMPARE 0= IF
1+ 1+
ELSE-IF 2R@ "[THEN]" COMPARE 0= OR-ELSE 2R@ "[ELSE]" COMPARE 0= THEN THEN-IF ELSE 2R@ "[THEN]" COMPARE 0<> IF 2R@ "[ELSE]" COMPARE 0<> AND-IF
ELSE
?DUP 0= IF 2RDROP EXIT THEN ?DUP 0= IF 2RDROP EXIT THEN
1- 1-
THEN THEN THEN
2RDROP 2RDROP
AGAIN AGAIN
THEN ; THEN ;
@ -1523,10 +1505,10 @@ DEFER REFILL
PARSE-NAME 2>R PARSE-NAME 2>R
2R@ "[IF]" COMPARE 0= IF 2R@ "[IF]" COMPARE 0= IF
1+ 1+
ELSE-IF 2R@ "[THEN]" COMPARE 0= THEN-IF ELSE 2R@ "[THEN]" COMPARE 0= IF
?DUP 0= IF 2RDROP EXIT THEN ?DUP 0= IF 2RDROP EXIT THEN
1- 1-
THEN THEN THEN
2RDROP 2RDROP
AGAIN ; AGAIN ;
@ -1563,16 +1545,15 @@ BUDDY-ORDERS ARRAY BUDDY-HEADS
DROP EXIT DROP EXIT
THEN 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 2 PICK 1+ BUDDY-ORDERS <= IF
DUP 3 PICK BUDDY-ORDER-BYTES XOR R@ = DUP 3 PICK BUDDY-ORDER-BYTES XOR R@ = AND-IF
THEN AND-THEN
\ Found the buddy on the free list; coalesce \ Found the buddy on the free list; coalesce
@ SWAP ! @ SWAP !
\ Pick the lower (naturally aligned) block address \ Pick the lower (naturally aligned) block address
DUP BUDDY-ORDER-BYTES INVERT R> AND >R DUP BUDDY-ORDER-BYTES INVERT R> AND >R
\ Repeat process with the next-higher order \ Repeat process with the next-higher order
1+ DUP BUDDY-HEADS TRUE 1+ DUP BUDDY-HEADS
THEN 0= IF ELSE
\ Insert before first item with address >= this addr \ Insert before first item with address >= this addr
DUP R@ U>= IF R@ ! R> SWAP ! DROP EXIT THEN DUP R@ U>= IF R@ ! R> SWAP ! DROP EXIT THEN
\ Otherwise advance to next block \ Otherwise advance to next block
@ -1587,7 +1568,7 @@ BUDDY-ORDERS ARRAY BUDDY-HEADS
DUP 1+ BUDDY-ALLOCATE SWAP 2DUP BUDDY-ORDER-BYTES + SWAP BUDDY-FREE ; 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 DUP 0= ?DUP 0= IF DUP DUP 1- AND THEN
"buddy allocator block size is not a power of two" ?FAIL "buddy allocator block size is not a power of two" ?FAIL
DUP BUDDY-MIN-BYTES - [[ BUDDY-MAX-BYTES BUDDY-MIN-BYTES - ]] U> DUP BUDDY-MIN-BYTES - [[ BUDDY-MAX-BYTES BUDDY-MIN-BYTES - ]] U>
"buddy allocator block size out of bounds" ?FAIL "buddy allocator block size out of bounds" ?FAIL
@ -2080,10 +2061,10 @@ FORTH DEFINITIONS
THEN THEN
\ At this point if index equals length then buffer is full or read returned 0 \ 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 \ Either way, we won't be reading any more into the buffer
2DUP = OR-ELSE 2DUP <>
WHILE
\ Check if the next character is a linefeed \ Check if the next character is a linefeed
1+ DUP 1- TERMINAL-BUFFER + C@ LF = 1+ DUP 1- TERMINAL-BUFFER + C@ LF =
THEN
UNTIL UNTIL
( S: length idx ) ( S: length idx )
\ idx is the next location after the linefeed, if found, or else equal to length \ idx is the next location after the linefeed, if found, or else equal to length
@ -2119,7 +2100,7 @@ UTILITY DEFINITIONS
[[ CHAR " ]] OF [[ CHAR " ]] ENDOF [[ CHAR " ]] OF [[ CHAR " ]] ENDOF
[[ CHAR ' ]] OF [[ CHAR ' ]] ENDOF [[ CHAR ' ]] OF [[ CHAR ' ]] ENDOF
[[ CHAR \ ]] OF [[ CHAR \ ]] ENDOF [[ CHAR \ ]] OF [[ CHAR \ ]] ENDOF
DUP TO-LOWER [[ CHAR x ]] = OF? DUP TO-LOWER [[ CHAR x ]] = OF? DROP
NEXT-CHAR 16 >DIGIT-BASE 0= "Invalid \\x… escape sequence" ?FAIL NEXT-CHAR 16 >DIGIT-BASE 0= "Invalid \\x… escape sequence" ?FAIL
16 1 ESCAPED-DIGITS 16 1 ESCAPED-DIGITS
ENDOF ENDOF
@ -2183,16 +2164,16 @@ SYSTEM DEFINITIONS
2RDROP 2RDROP
STATE @ 0= IF STATE @ 0= IF
DROP DROP
ELSE-IF 2 = THEN-IF ELSE 2 = IF
POSTPONE 2LITERAL POSTPONE 2LITERAL
ELSE ELSE
POSTPONE LITERAL POSTPONE LITERAL
THEN THEN THEN
ELSE ELSE
2R> FIND-OR-THROW 2R> FIND-OR-THROW
\ -1 => immediate word; execute regardless of STATE \ -1 => immediate word; execute regardless of STATE
\ 1 => read STATE; compile if true, execute if false \ 1 => read STATE; compile if true, execute if false
0< ▪ OR-ELSE STATE @ 0= THEN ▪ IF EXECUTE ELSE COMPILE, THEN 0> IF ▪ STATE @ AND-IF ▪ COMPILE, ▪ ELSE EXECUTE ▪ THEN
THEN THEN
THEN THEN
?STACK ?STACK
@ -2434,14 +2415,14 @@ FORTH DEFINITIONS
\ Words with zero-length names (e.g. from :NONAME) are displayed as numbers \ Words with zero-length names (e.g. from :NONAME) are displayed as numbers
: .W ( addr -- "<name>" | "<digits>" ) : .W ( addr -- "<name>" | "<digits>" )
\ Is it some kind of word, and if so, is the name not zero-length (:NONAME)? \ 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 DUP WORD? IF ▪ DUP >NAME NIP 0<> AND-IF
\ Is the name hidden? \ Is the name hidden?
DUP HIDDEN? IF DUP HIDDEN? IF
"⌀" TYPE "⌀" TYPE
ELSE ELSE
\ Does FIND with the same name fail to return the same word? \ Does FIND with the same name fail to return the same word?
DUP >NAME FIND ▪ AND-THEN OVER = ELSE NIP NIP THEN ▪ 0= IF DUP >NAME FIND IF ▪ OVER = AND-IF ▪ ELSE
"¤" TYPE 2DROP "¤" TYPE
THEN THEN
THEN THEN
>NAME TYPE >NAME TYPE
@ -2456,25 +2437,26 @@ UTILITY DEFINITIONS
: CONTROL-CHAR? ( ch -- flag ) DUP 32 U< SWAP 127 = OR ; : CONTROL-CHAR? ( ch -- flag ) DUP 32 U< SWAP 127 = OR ;
: TYPE-ESCAPED ( c-addr u -- "<escapeseq*>" ) : TYPE-ESCAPED ( c-addr u -- "<escapeseq*>" )
0 ?DO DUP C@ 0 ?DO DUP C@
DUP 7 14 WITHIN IF CASE
DUP 7 - 2* "\\a\\b\\t\\n\\v\\f\\r" DROP + 2 DUP 7 14 WITHIN OF? 7 - 2* "\\a\\b\\t\\n\\v\\f\\r" DROP + 2 ENDOF
ELSE-IF DUP 27 = THEN-IF "\\e" 27 OF "\\e" ENDOF
ELSE-IF DUP [[ CHAR " ]] = THEN-IF "\\\"" [[ CHAR " ]] OF "\\\"" ENDOF
ELSE-IF DUP [[ CHAR \ ]] = THEN-IF "\\\\" [[ CHAR \ ]] OF "\\\\" ENDOF
ELSE DUP 0 OTHERWISE
<# OVER CONTROL-CHAR? IF 16 #B 16 #B "\\x" HOLDS ELSE OVER HOLD THEN #> 0 <# OVER CONTROL-CHAR? IF 16 #B 16 #B "\\x" HOLDS ELSE OVER HOLD THEN #>
THEN ▪ TYPE ▪ DROP 1+ ENDOF
ENDCASE ▪ TYPE ▪ 1+
LOOP ▪ DROP ; LOOP ▪ DROP ;
\ Recognize the pattern BRANCH a:{c-a} {name} {link} b:{codeword} {…} c:LIT d:{b} \ Recognize the pattern BRANCH a:{c-a} {name} {link} b:{codeword} {…} c:LIT d:{b}
\ This pattern is generated by the { … } inline :NONAME syntax \ This pattern is generated by the { … } inline :NONAME syntax
: NONAME-LITERAL? ( a-addr -- flag ) : NONAME-LITERAL? ( a-addr -- flag )
@(+) [[ ' BRANCH ]] = AND-THEN @(+) [[ ' BRANCH ]] = ?0DUP IF
DUP @ DUP 5 CELLS >= AND-THEN DUP @ DUP 5 CELLS >= ?0DUP IF
( S: addr-a offset-c-a ) ( S: addr-a offset-c-a )
OVER + @(+) [[ ' LIT ]] = AND-THEN OVER + @(+) [[ ' LIT ]] = ?0DUP IF
( S: addr-a addr-d ) ( S: addr-a addr-d )
@ SWAP 3 CELLS+ OVER = AND-THEN @ SWAP 3 CELLS+ OVER = ?0DUP IF
DUP WORD? DUP WORD?
THEN THEN
ELSE NIP THEN ELSE NIP THEN
@ -2489,28 +2471,38 @@ UTILITY DEFINITIONS
: UNTHREAD ( a-addr -- ) RECURSIVE : UNTHREAD ( a-addr -- ) RECURSIVE
DUP >R DUP >R
BEGIN BEGIN
@(+) DUP [[ ' EXIT ]] <> OR-ELSE OVER R@ U<= THEN @(+) ▪ DUP [[ ' EXIT ]] <> ▪ ?DUP 0= IF OVER R@ U<= THEN
WHILE WHILE
DUP [[ ' LIT ]] = IF CASE
DROP @(+) DUP WORD? IF "[[ ' " TYPE .W " ]] " TYPE ELSE . SPACE THEN [[ ' LIT ]] OF
ELSE-IF DUP [[ ' 2LIT ]] = THEN-IF @(+) DUP WORD? IF "[[ ' " TYPE .W " ]] " TYPE ELSE . SPACE THEN
DROP "[ " TYPE ENDOF
[[ ' 2LIT ]] OF
"[ " TYPE
@(+) >R @(+) DUP WORD? IF "' " TYPE .W ELSE U. THEN SPACE @(+) >R @(+) DUP WORD? IF "' " TYPE .W ELSE U. THEN SPACE
R> DUP WORD? IF "' " TYPE .W ELSE U. THEN R> DUP WORD? IF "' " TYPE .W ELSE U. THEN
" ] 2LITERAL " TYPE " ] 2LITERAL " TYPE
ELSE-IF DUP [[ ' LITSTRING ]] = THEN-IF ENDOF
DROP DUP 1+ SWAP C@ 2DUP "\"" TYPE TYPE-ESCAPED "\" " TYPE + ALIGNED [[ ' LITSTRING ]] OF
ELSE-IF OVER CELL- NONAME-LITERAL? THEN-IF DUP 1+ SWAP C@ 2DUP "\"" TYPE TYPE-ESCAPED "\" " TYPE + ALIGNED
DROP DUP @ OVER + 2 CELLS+ DUP R> UMAX >R SWAP ENDOF
OVER CELL- NONAME-LITERAL? OF? DROP
DUP @ OVER + 2 CELLS+ DUP R> UMAX >R SWAP
"{ " TYPE 3 CELLS+ >DFA @ UNTHREAD "} " TYPE "{ " TYPE 3 CELLS+ >DFA @ UNTHREAD "} " TYPE
ELSE-IF DUP [[ ' BRANCH ]] = OR-ELSE DUP [[ ' 0BRANCH ]] = THEN THEN-IF ENDOF
>NAME TYPE SPACE [[ ' BRANCH ]] OF
"BRANCH " TYPE
@(+) DUP "{" TYPE DUP 0>= IF "+" TYPE THEN . "} " TYPE @(+) DUP "{" TYPE DUP 0>= IF "+" TYPE THEN . "} " TYPE
OVER CELL- + R> UMAX >R OVER CELL- + R> UMAX >R
ELSE ENDOF
DUP WORD? AND-THEN DUP IMMEDIATE? THEN IF "POSTPONE " TYPE THEN [[ ' 0BRANCH ]] OF
.W SPACE "0BRANCH " TYPE
THEN @(+) DUP "{" TYPE DUP 0>= IF "+" TYPE THEN . "} " TYPE
OVER CELL- + R> UMAX >R
ENDOF
DUP WORD? IF DUP IMMEDIATE? AND-IF "POSTPONE " TYPE THEN
DUP .W SPACE
ENDCASE
REPEAT ▪ 2DROP RDROP ; REPEAT ▪ 2DROP RDROP ;
: (SEE) ( xt -- ) : (SEE) ( xt -- )
@ -2617,12 +2609,14 @@ SYSTEM DEFINITIONS
DUP NULL= IF NIP NIP NULL EXIT THEN DUP NULL= IF NIP NIP NULL EXIT THEN
LOCALS| x tree node | LOCALS| x tree node |
x node tree AA>VALUE @ EXECUTE ▪ tree AA>COMPARE @ EXECUTE x node tree AA>VALUE @ EXECUTE ▪ tree AA>COMPARE @ EXECUTE
DUP 0< IF DROP CASE
DUP 0< OF? DROP
x tree node AA>LEFT DUP >R @ AA-DELETE-NODE R> ! x tree node AA>LEFT DUP >R @ AA-DELETE-NODE R> !
ELSE-IF 0> THEN-IF ENDOF
DUP 0> OF? DROP
x tree node AA>RIGHT DUP >R @ AA-DELETE-NODE R> ! x tree node AA>RIGHT DUP >R @ AA-DELETE-NODE R> !
ELSE ENDOF
node AA-LEAF? IF node NULL UNLOCALS EXIT THEN node AA-LEAF? IF DROP node NULL UNLOCALS EXIT THEN
node AA>LEFT @ NULL= IF node AA>LEFT @ NULL= IF
\ swap current node with its successor in the right subtree \ swap current node with its successor in the right subtree
node AA>RIGHT @ AA>LEFT @ NULL= IF node AA>RIGHT @ AA>LEFT @ NULL= IF
@ -2654,7 +2648,8 @@ SYSTEM DEFINITIONS
\ recurse into left subtree \ recurse into left subtree
x tree node AA>LEFT DUP >R @ AA-DELETE-NODE R> ! x tree node AA>LEFT DUP >R @ AA-DELETE-NODE R> !
THEN THEN
THEN ( S: aa-node2|NULL ) SWAP
ENDCASE ( S: aa-node2|NULL )
node node
ENDLOCALS ENDLOCALS
\ Rebalance the tree \ Rebalance the tree
@ -2830,8 +2825,9 @@ O_RDWR CONSTANT R/W ( -- fam )
AT_FDCWD ▪ name ▪ open-how ▪ SIZEOF open_how% AT_FDCWD ▪ name ▪ open-how ▪ SIZEOF open_how%
SYS_OPENAT2 SYSCALL4-RETRY SYS_OPENAT2 SYSCALL4-RETRY
name FREE name FREE
DUP ERRNO_ENOENT = OR-ELSE DUP ERRNO_ENOTDIR = THEN IF DUP ERRNO_ENOENT <> IF ▪ DUP ERRNO_ENOTDIR <> AND-IF ▪ ELSE
DROP file FREE EXCP-NON-EXISTENT-FILE THROW THEN DROP file FREE EXCP-NON-EXISTENT-FILE THROW
THEN
DUP 0< IF DROP file FREE EXCP-FILE-IO THROW THEN DUP 0< IF DROP file FREE EXCP-FILE-IO THROW THEN
DUP file FILE>FD ! DUP file FILE>FD !
file FILES AA-LOOKUP NULL<> "internal error - duplicate key in FILES" ?FAIL file FILES AA-LOOKUP NULL<> "internal error - duplicate key in FILES" ?FAIL
@ -2993,19 +2989,16 @@ FORTH DEFINITIONS
SYSTEM DEFINITIONS SYSTEM DEFINITIONS
: MAIN {
ONLY FORTH DEFINITIONS ONLY FORTH DEFINITIONS
ARGC 2 U>= IF ARGC 2 U>= IF
1 ARGV [[ ' INCLUDED ]] CATCH 1 ARGV [[ ' INCLUDED ]] CATCH
DUP EXCP-QUIT = IF DUP EXCP-QUIT = IF
DROP 2DROP QUIT DROP 2DROP QUIT
ELSE-IF ?DUP THEN-IF ELSE ?DUP IF
REPORT 2DROP REPORT 2DROP
THEN THEN THEN
BYE BYE
ELSE THEN
[ INTERACTIVE? ] [IF] BANNER [THEN] [ INTERACTIVE? ] [IF] BANNER [THEN]
QUIT } EXECUTE
THEN ;
MAIN

11
test/case.4th Normal file
View File

@ -0,0 +1,11 @@
: TEST
DUP . ": " TYPE
DUP CASE
1 OF "1\n" TYPE ENDOF
2 OF "2\n" TYPE ENDOF
DUP 0<= OF? "nonpositive\n" TYPE ENDOF
DUP 5 <= OF? "3…5\n" TYPE ENDOF
"other\n" TYPE
ENDCASE DROP ;
{ 7 0 ?DO I TEST LOOP } EXECUTE

0
test/multi-if.exp → test/case.exp
View File

10
test/multi-if.4th
View File

@ -1,10 +0,0 @@
: 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