From ff2d91b66b4b2924aaff81af484c98f33398df3f Mon Sep 17 00:00:00 2001 From: Jesse McDonald Date: Wed, 11 Nov 2020 00:18:57 -0600 Subject: [PATCH] simplify conditionals; rename ONWARD-IF to AND-IF; remove AND-THEN and OR-ELSE --- startup.4th | 265 ++++++++++++++++---------------- test/case.4th | 11 ++ test/{multi-if.exp => case.exp} | 0 test/multi-if.4th | 10 -- 4 files changed, 140 insertions(+), 146 deletions(-) create mode 100644 test/case.4th rename test/{multi-if.exp => case.exp} (100%) delete mode 100644 test/multi-if.4th diff --git a/startup.4th b/startup.4th index f7ba181..9f006f4 100644 --- a/startup.4th +++ b/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 if the condition is false +\ \ The IF and AND-IF both branch to if the condition is false \ \ This is functionally a short-circuit AND condition \ \ Without the ELSE they would both branch to -\ IF ONWARD-IF ELSE THEN +\ IF AND-IF ELSE THEN \ \ 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) -\ 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) ; +\ IF {ELSE } 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: -\ AND-THEN THEN -\ OR-ELSE THEN -: AND-THEN ( C: -- orig ) ( Runtime: flag -- FALSE | ) IMMEDIATE - POSTPONE ?0DUP POSTPONE IF ; -: OR-ELSE ( C: -- orig ) ( Runtime: flag -- nonzero-flag | ) 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 AGAIN \ Simple conditional loop: BEGIN UNTIL \ Mid-loop condition(s): BEGIN WHILE { WHILE}… REPEAT -\ Mixed WHILE/UNTIL loop: BEGIN WHILE UNTIL +\ Mixed WHILE/UNTIL loop: BEGIN WHILE { 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 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 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: DO LOOP \ DO +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 -- "" | "" ) \ 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 -- "" ) 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 diff --git a/test/case.4th b/test/case.4th new file mode 100644 index 0000000..a3be601 --- /dev/null +++ b/test/case.4th @@ -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 diff --git a/test/multi-if.exp b/test/case.exp similarity index 100% rename from test/multi-if.exp rename to test/case.exp diff --git a/test/multi-if.4th b/test/multi-if.4th deleted file mode 100644 index 1ecf5cf..0000000 --- a/test/multi-if.4th +++ /dev/null @@ -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