simplify conditionals; rename ONWARD-IF to AND-IF; remove AND-THEN and OR-ELSE
This commit is contained in:
parent
e533756d25
commit
ff2d91b66b
265
startup.4th
265
startup.4th
|
|
@ -870,77 +870,55 @@ __O_TMPFILE O_DIRECTORY OR ⇒ O_TMPFILE
|
|||
\ ELSE inserts an unconditional branch (to THEN) and also resolves the
|
||||
\ 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
|
||||
\ 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
|
||||
\ 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
|
||||
\ \ 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
|
||||
\ 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.
|
||||
|
||||
' 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)
|
||||
|
||||
\ <cond1> IF <code1>
|
||||
\ {ELSE-IF <cond2> THEN-IF <code2>}…
|
||||
\ {ELSE <code3>}
|
||||
\ 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) ;
|
||||
\ <cond1> IF <code1> {ELSE <code3>} THEN
|
||||
: ALWAYS ( C: -- orig ) IMMEDIATE
|
||||
NULL ;
|
||||
: AND-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 ;
|
||||
|
||||
\ Short-circuit logical operators
|
||||
\ Examples:
|
||||
\ <cond1> AND-THEN <cond2> THEN
|
||||
\ <cond1> OR-ELSE <cond2> THEN
|
||||
: AND-THEN ( C: -- orig ) ( Runtime: flag -- FALSE | <dropped> ) IMMEDIATE
|
||||
POSTPONE ?0DUP POSTPONE IF ;
|
||||
: OR-ELSE ( C: -- orig ) ( Runtime: flag -- nonzero-flag | <dropped> ) IMMEDIATE
|
||||
POSTPONE ?DUP POSTPONE 0= POSTPONE IF ;
|
||||
: IF ( C: -- orig ; flag -- ) IMMEDIATE
|
||||
POSTPONE ALWAYS POSTPONE AND-IF ;
|
||||
: AHEAD ( C: -- orig ; flag -- ) IMMEDIATE
|
||||
POSTPONE ALWAYS POSTPONE ONWARD-AHEAD ;
|
||||
|
||||
: ELSE ( C: orig1 -- orig2 ) IMMEDIATE
|
||||
POSTPONE AHEAD SWAP POSTPONE THEN ;
|
||||
|
||||
\ Unbounded loop: BEGIN <body> AGAIN
|
||||
\ Simple conditional loop: BEGIN <condition> UNTIL
|
||||
\ 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
|
||||
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 AND-IF SWAP ;
|
||||
: REPEAT ( C: orig dest -- ) IMMEDIATE
|
||||
POSTPONE AGAIN ;
|
||||
|
||||
|
|
@ -958,21 +936,24 @@ __O_TMPFILE O_DIRECTORY OR ⇒ O_TMPFILE
|
|||
\
|
||||
\ Begin by creating a placeholder for the unresolved ENDOF forward references
|
||||
: CASE ( C: -- null-orig ) IMMEDIATE
|
||||
POSTPONE (ALWAYS) ;
|
||||
POSTPONE ALWAYS ;
|
||||
\ 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
|
||||
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
|
||||
\ 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 OF? ;
|
||||
: OF ( C: orign ... orig1 n -- orign ... orig1 n orig-of ; x y -- {x} ) IMMEDIATE
|
||||
POSTPONE OVER POSTPONE = POSTPONE OF? 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) ;
|
||||
SWAP POSTPONE ONWARD-AHEAD SWAP POSTPONE THEN ;
|
||||
\ Drop the <x> value in case none of the OF...ENDOF clauses matched
|
||||
\ Resolve all the forward branches from ENDOF to the location after ENDCASE
|
||||
: ENDCASE ( C: orig-case -- ) IMMEDIATE
|
||||
POSTPONE DROP POSTPONE (THEN) ;
|
||||
POSTPONE DROP POSTPONE THEN ;
|
||||
|
||||
\ Range loop: <limit> <index> DO <code> LOOP
|
||||
\ <limit> <index> DO <code> <step> +LOOP
|
||||
|
|
@ -981,19 +962,19 @@ __O_TMPFILE O_DIRECTORY OR ⇒ O_TMPFILE
|
|||
CREATE LEAVE-ORIG NULL ,
|
||||
: 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 ; 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: -- ; -- R: limit index -- ) IMMEDIATE
|
||||
LEAVE-ORIG @ POSTPONE (ONWARD-AHEAD) LEAVE-ORIG ! ;
|
||||
LEAVE-ORIG @ POSTPONE ONWARD-AHEAD LEAVE-ORIG ! ;
|
||||
: UNLOOP ( R: limit index -- ) IMMEDIATE
|
||||
POSTPONE 2RDROP ;
|
||||
: +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 ! ;
|
||||
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)
|
||||
|
|
@ -1112,7 +1093,7 @@ CREATE DISPLAY-ITEM-LIMIT 6 ,
|
|||
|
||||
\ Remove trailing whitespace from a string (only affects length)
|
||||
: -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
|
||||
: 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
|
||||
: >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
|
||||
\ 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
|
||||
>NUMBER
|
||||
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
|
||||
ELSE-IF NIP 0= THEN-IF
|
||||
ELSE NIP 0= IF
|
||||
DROP 1
|
||||
ELSE
|
||||
2DROP 0
|
||||
THEN ;
|
||||
THEN THEN ;
|
||||
|
||||
' PARSENUMBER ' BOOTSTRAP-PARSENUMBER DEFER!
|
||||
|
||||
|
|
@ -1470,7 +1451,7 @@ DEFER REFILL
|
|||
DUP IF
|
||||
LATEST
|
||||
NULL OVER >LINK XCHG LATEST!
|
||||
POSTPONE (AHEAD)
|
||||
POSTPONE AHEAD
|
||||
ROT
|
||||
POSTPONE [
|
||||
THEN
|
||||
|
|
@ -1487,7 +1468,7 @@ DEFER REFILL
|
|||
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 ; )
|
||||
|
|
@ -1508,10 +1489,11 @@ DEFER REFILL
|
|||
PARSE-NAME 2>R
|
||||
2R@ "[IF]" COMPARE 0= IF
|
||||
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
|
||||
1-
|
||||
THEN
|
||||
THEN THEN
|
||||
2RDROP
|
||||
AGAIN
|
||||
THEN ;
|
||||
|
|
@ -1523,10 +1505,10 @@ DEFER REFILL
|
|||
PARSE-NAME 2>R
|
||||
2R@ "[IF]" COMPARE 0= IF
|
||||
1+
|
||||
ELSE-IF 2R@ "[THEN]" COMPARE 0= THEN-IF
|
||||
ELSE 2R@ "[THEN]" COMPARE 0= IF
|
||||
?DUP 0= IF 2RDROP EXIT THEN
|
||||
1-
|
||||
THEN
|
||||
THEN THEN
|
||||
2RDROP
|
||||
AGAIN ;
|
||||
|
||||
|
|
@ -1563,16 +1545,15 @@ BUDDY-ORDERS ARRAY BUDDY-HEADS
|
|||
DROP EXIT
|
||||
THEN
|
||||
( S: order head-addr block-addr R: freed-addr )
|
||||
2 PICK 1+ BUDDY-ORDERS < AND-THEN
|
||||
DUP 3 PICK BUDDY-ORDER-BYTES XOR R@ =
|
||||
THEN AND-THEN
|
||||
2 PICK 1+ BUDDY-ORDERS <= IF
|
||||
DUP 3 PICK BUDDY-ORDER-BYTES XOR R@ = AND-IF
|
||||
\ Found the buddy on the free list; coalesce
|
||||
@ SWAP !
|
||||
\ Pick the lower (naturally aligned) block address
|
||||
DUP BUDDY-ORDER-BYTES INVERT R> AND >R
|
||||
\ Repeat process with the next-higher order
|
||||
1+ DUP BUDDY-HEADS TRUE
|
||||
THEN 0= IF
|
||||
1+ DUP BUDDY-HEADS
|
||||
ELSE
|
||||
\ Insert before first item with address >= this addr
|
||||
DUP R@ U>= IF R@ ! R> SWAP ! DROP EXIT THEN
|
||||
\ 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 ;
|
||||
|
||||
: 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
|
||||
DUP BUDDY-MIN-BYTES - [[ BUDDY-MAX-BYTES BUDDY-MIN-BYTES - ]] U>
|
||||
"buddy allocator block size out of bounds" ?FAIL
|
||||
|
|
@ -2080,10 +2061,10 @@ FORTH DEFINITIONS
|
|||
THEN
|
||||
\ At this point if index equals length then buffer is full or read returned 0
|
||||
\ Either way, we won't be reading any more into the buffer
|
||||
2DUP = OR-ELSE
|
||||
\ Check if the next character is a linefeed
|
||||
1+ DUP 1- TERMINAL-BUFFER + C@ LF =
|
||||
THEN
|
||||
2DUP <>
|
||||
WHILE
|
||||
\ Check if the next character is a linefeed
|
||||
1+ DUP 1- TERMINAL-BUFFER + C@ LF =
|
||||
UNTIL
|
||||
( S: length idx )
|
||||
\ 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
|
||||
DUP TO-LOWER [[ CHAR x ]] = OF?
|
||||
DUP TO-LOWER [[ CHAR x ]] = OF? DROP
|
||||
NEXT-CHAR 16 >DIGIT-BASE 0= "Invalid \\x… escape sequence" ?FAIL
|
||||
16 1 ESCAPED-DIGITS
|
||||
ENDOF
|
||||
|
|
@ -2183,16 +2164,16 @@ SYSTEM DEFINITIONS
|
|||
2RDROP
|
||||
STATE @ 0= IF
|
||||
DROP
|
||||
ELSE-IF 2 = THEN-IF
|
||||
ELSE 2 = IF
|
||||
POSTPONE 2LITERAL
|
||||
ELSE
|
||||
POSTPONE LITERAL
|
||||
THEN
|
||||
THEN THEN
|
||||
ELSE
|
||||
2R> 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> IF ▪ STATE @ AND-IF ▪ COMPILE, ▪ ELSE EXECUTE ▪ THEN
|
||||
THEN
|
||||
THEN
|
||||
?STACK
|
||||
|
|
@ -2434,14 +2415,14 @@ FORTH DEFINITIONS
|
|||
\ Words with zero-length names (e.g. from :NONAME) are displayed as numbers
|
||||
: .W ( addr -- "<name>" | "<digits>" )
|
||||
\ 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?
|
||||
DUP HIDDEN? IF
|
||||
"⌀" TYPE
|
||||
ELSE
|
||||
\ Does FIND with the same name fail to return the same word?
|
||||
DUP >NAME FIND ▪ AND-THEN OVER = ELSE NIP NIP THEN ▪ 0= IF
|
||||
"¤" TYPE
|
||||
DUP >NAME FIND IF ▪ OVER = AND-IF ▪ ELSE
|
||||
2DROP "¤" TYPE
|
||||
THEN
|
||||
THEN
|
||||
>NAME TYPE
|
||||
|
|
@ -2456,25 +2437,26 @@ UTILITY DEFINITIONS
|
|||
: CONTROL-CHAR? ( ch -- flag ) DUP 32 U< SWAP 127 = OR ;
|
||||
: TYPE-ESCAPED ( c-addr u -- "<escapeseq*>" )
|
||||
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+
|
||||
CASE
|
||||
DUP 7 14 WITHIN OF? 7 - 2* "\\a\\b\\t\\n\\v\\f\\r" DROP + 2 ENDOF
|
||||
27 OF "\\e" ENDOF
|
||||
[[ CHAR " ]] OF "\\\"" ENDOF
|
||||
[[ CHAR \ ]] OF "\\\\" ENDOF
|
||||
OTHERWISE
|
||||
0 <# OVER CONTROL-CHAR? IF 16 #B 16 #B "\\x" HOLDS ELSE OVER HOLD THEN #>
|
||||
ENDOF
|
||||
ENDCASE ▪ TYPE ▪ 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 )
|
||||
@(+) [[ ' BRANCH ]] = AND-THEN
|
||||
DUP @ DUP 5 CELLS >= AND-THEN
|
||||
@(+) [[ ' BRANCH ]] = ?0DUP IF
|
||||
DUP @ DUP 5 CELLS >= ?0DUP IF
|
||||
( S: addr-a offset-c-a )
|
||||
OVER + @(+) [[ ' LIT ]] = AND-THEN
|
||||
OVER + @(+) [[ ' LIT ]] = ?0DUP IF
|
||||
( S: addr-a addr-d )
|
||||
@ SWAP 3 CELLS+ OVER = AND-THEN
|
||||
@ SWAP 3 CELLS+ OVER = ?0DUP IF
|
||||
DUP WORD?
|
||||
THEN
|
||||
ELSE NIP THEN
|
||||
|
|
@ -2489,28 +2471,38 @@ UTILITY DEFINITIONS
|
|||
: UNTHREAD ( a-addr -- ) RECURSIVE
|
||||
DUP >R
|
||||
BEGIN
|
||||
@(+) DUP [[ ' EXIT ]] <> OR-ELSE OVER R@ U<= THEN
|
||||
@(+) ▪ DUP [[ ' EXIT ]] <> ▪ ?DUP 0= IF 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 @(+) DUP WORD? IF "' " TYPE .W ELSE U. THEN SPACE
|
||||
R> DUP WORD? IF "' " TYPE .W ELSE U. THEN
|
||||
" ] 2LITERAL " TYPE
|
||||
ENDOF
|
||||
[[ ' LITSTRING ]] OF
|
||||
DUP 1+ SWAP C@ 2DUP "\"" TYPE TYPE-ESCAPED "\" " TYPE + ALIGNED
|
||||
ENDOF
|
||||
OVER CELL- NONAME-LITERAL? OF? DROP
|
||||
DUP @ OVER + 2 CELLS+ DUP R> UMAX >R SWAP
|
||||
"{ " TYPE 3 CELLS+ >DFA @ UNTHREAD "} " TYPE
|
||||
ENDOF
|
||||
[[ ' BRANCH ]] OF
|
||||
"BRANCH " TYPE
|
||||
@(+) DUP "{" TYPE DUP 0>= IF "+" TYPE THEN . "} " TYPE
|
||||
OVER CELL- + R> UMAX >R
|
||||
ENDOF
|
||||
[[ ' 0BRANCH ]] OF
|
||||
"0BRANCH " TYPE
|
||||
@(+) 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 ;
|
||||
|
||||
: (SEE) ( xt -- )
|
||||
|
|
@ -2617,12 +2609,14 @@ SYSTEM DEFINITIONS
|
|||
DUP NULL= IF NIP NIP NULL EXIT THEN
|
||||
LOCALS| x tree node |
|
||||
x node tree AA>VALUE @ EXECUTE ▪ tree AA>COMPARE @ EXECUTE
|
||||
DUP 0< IF DROP
|
||||
x tree node AA>LEFT DUP >R @ AA-DELETE-NODE R> !
|
||||
ELSE-IF 0> THEN-IF
|
||||
x tree node AA>RIGHT DUP >R @ AA-DELETE-NODE R> !
|
||||
ELSE
|
||||
node AA-LEAF? IF node NULL UNLOCALS EXIT THEN
|
||||
CASE
|
||||
DUP 0< OF? DROP
|
||||
x tree node AA>LEFT DUP >R @ AA-DELETE-NODE R> !
|
||||
ENDOF
|
||||
DUP 0> OF? DROP
|
||||
x tree node AA>RIGHT DUP >R @ AA-DELETE-NODE R> !
|
||||
ENDOF
|
||||
node AA-LEAF? IF DROP node NULL UNLOCALS EXIT THEN
|
||||
node AA>LEFT @ NULL= IF
|
||||
\ swap current node with its successor in the right subtree
|
||||
node AA>RIGHT @ AA>LEFT @ NULL= IF
|
||||
|
|
@ -2654,7 +2648,8 @@ SYSTEM DEFINITIONS
|
|||
\ recurse into left subtree
|
||||
x tree node AA>LEFT DUP >R @ AA-DELETE-NODE R> !
|
||||
THEN
|
||||
THEN ( S: aa-node2|NULL )
|
||||
SWAP
|
||||
ENDCASE ( S: aa-node2|NULL )
|
||||
node
|
||||
ENDLOCALS
|
||||
\ Rebalance the tree
|
||||
|
|
@ -2830,8 +2825,9 @@ O_RDWR CONSTANT R/W ( -- fam )
|
|||
AT_FDCWD ▪ name ▪ open-how ▪ SIZEOF open_how%
|
||||
SYS_OPENAT2 SYSCALL4-RETRY
|
||||
name FREE
|
||||
DUP ERRNO_ENOENT = OR-ELSE DUP ERRNO_ENOTDIR = THEN IF
|
||||
DROP file FREE EXCP-NON-EXISTENT-FILE THROW THEN
|
||||
DUP ERRNO_ENOENT <> IF ▪ DUP ERRNO_ENOTDIR <> AND-IF ▪ ELSE
|
||||
DROP file FREE EXCP-NON-EXISTENT-FILE THROW
|
||||
THEN
|
||||
DUP 0< IF DROP file FREE EXCP-FILE-IO THROW THEN
|
||||
DUP file FILE>FD !
|
||||
file FILES AA-LOOKUP NULL<> "internal error - duplicate key in FILES" ?FAIL
|
||||
|
|
@ -2993,19 +2989,16 @@ FORTH DEFINITIONS
|
|||
|
||||
SYSTEM DEFINITIONS
|
||||
|
||||
: MAIN
|
||||
{
|
||||
ONLY FORTH DEFINITIONS
|
||||
ARGC 2 U>= IF
|
||||
1 ARGV [[ ' INCLUDED ]] CATCH
|
||||
DUP EXCP-QUIT = IF
|
||||
DROP 2DROP QUIT
|
||||
ELSE-IF ?DUP THEN-IF
|
||||
ELSE ?DUP IF
|
||||
REPORT 2DROP
|
||||
THEN
|
||||
THEN THEN
|
||||
BYE
|
||||
ELSE
|
||||
[ INTERACTIVE? ] [IF] BANNER [THEN]
|
||||
QUIT
|
||||
THEN ;
|
||||
|
||||
MAIN
|
||||
THEN
|
||||
[ INTERACTIVE? ] [IF] BANNER [THEN]
|
||||
} EXECUTE
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
Loading…
Reference in New Issue