From e268cac0a426ba681cb6acc60e24f378d4fa0ed4 Mon Sep 17 00:00:00 2001 From: Jesse McDonald Date: Sun, 25 Oct 2020 02:14:37 -0500 Subject: [PATCH] add a COMPOSE combinator and ALIAS defining word --- startup.4th | 37 ++++++++++++++++++++++--------------- test/merge-sort.4th | 2 +- 2 files changed, 23 insertions(+), 16 deletions(-) diff --git a/startup.4th b/startup.4th index b3bc9ec..33fe448 100644 --- a/startup.4th +++ b/startup.4th @@ -1228,12 +1228,11 @@ DEFER REFILL ALIGN HERE DOCOL , HERE 3 CELLS+ , LATEST , F_HIDDEN C, DUP LATEST! ALIGN POSTPONE ] ; -\ Create a deferred word; the target is stored in the DFA field -\ The default target throws an exception — replace it using DEFER! or IS -: (DEFERRED-UNINIT) "Uninitialized deferred word" FAIL ; -: DEFER ( "ccc" -- ) - CREATE ['] (DEFERRED-UNINIT) LATEST DEFER! ; -' (DEFERRED-UNINIT) (HIDE) +\ Use the deferred-word mechanism to create an alternate name for the given xt +\ A deferred word, while indirect, is faster than a single-word colon definition +\ and avoids the creation of a redundant return stack frame +: ALIAS ( xt "ccc" -- ) + CREATE LATEST DEFER! ; \ Inline :NONAME-style function literals. "{ }" has the runtime effect \ of placing the execution token for an anonymous function with the runtime @@ -1287,6 +1286,10 @@ 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" -- ) { "Uninitialized deferred word" FAIL } ALIAS ; + \ Conditional compilation \ No effect if flag is true, otherwise skips words until matching [ELSE] or [THEN] \ Skips over nested [IF] … [THEN] or [IF] … [ELSE] … [THEN] structures @@ -1540,16 +1543,18 @@ ENDSTRUCT MEMBLOCK% >>FORTH -\ Store xt1 and xu ... x1 in a "closure object" and return an execution token -\ The execution token is located at the start of the "closure object" and may -\ be passed to FREE to release the memory when the closure is no longer needed -\ When executed, the closure object will place xu ... x1 on the data stack -\ and then execute the captured xt1 +\ 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 ) 1+ DUP 5 + CELLS ALLOCATE DUP >R DODOES OVER ! CELL+ [ ' (CLOSURE) >DFA @ ] LITERAL OVER ! CELL+ 0 OVER ! CELL+ 0 OVER ! CELL+ 2DUP ! CELL+ N! R> ; +\ In the future the closure object and its xt may not share the same address +' FREE ALIAS FREE-CLOSURE + \ Reserve data or heap space for a data structure given alignment and size \ It is assumed that ALLOCATE (but not ALLOT) returns an address suitably \ aligned for any primitive data type; %ALLOCATE is not suitable for data @@ -2183,11 +2188,13 @@ HIDE UNTHREAD 1 RPICK SPLIT 2R@ MERGE-SORT SWAP 2R@ MERGE-SORT 2R@ MERGE THEN 2RDROP ; -: NEGATED ( xt1 -- xt2 ) - { EXECUTE NEGATE } 1 CLOSURE ; +\ Return a closure which executes xt1 followed by xt2 +: COMPOSE ( xt1 xt2 -- xt3 ) + { >R EXECUTE R> EXECUTE } 2 CLOSURE ; -: MERGE-SORT-DESCENDING ( head1 link-xt compare-xt -- head2 ) - NEGATED DUP >R MERGE-SORT R> FREE ; +\ Sort in descending order by negating the result of compare-xt +: MERGE-SORT> ( head1 link-xt compare-xt -- head2 ) + ['] NEGATE COMPOSE DUP >R MERGE-SORT R> FREE-CLOSURE ; HIDE SPLIT HIDE MERGE diff --git a/test/merge-sort.4th b/test/merge-sort.4th index 51b946d..5e9cec4 100644 --- a/test/merge-sort.4th +++ b/test/merge-sort.4th @@ -18,5 +18,5 @@ ENDSTRUCT NODE% 7 5 3 6 8 9 4 2 4 9 MAKE-LIST "Before: " TYPE DUP SHOW-LIST -' NODE>LINK ' COMPARE-NODES MERGE-SORT-DESCENDING +' NODE>LINK ' COMPARE-NODES MERGE-SORT> "After: " TYPE SHOW-LIST