add a COMPOSE combinator and ALIAS defining word

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
+\ Use the deferred-word mechanism to create an alternate name for the given xt
-\ The default target throws an exception — replace it using DEFER! or IS
+\ A deferred word, while indirect, is faster than a single-word colon definition
-: (DEFERRED-UNINIT) "Uninitialized deferred word" FAIL ;
+\ and avoids the creation of a redundant return stack frame
-: DEFER ( "<spaces>ccc" -- )
+: ALIAS ( xt "<spaces>ccc" -- )
-   CREATE ['] (DEFERRED-UNINIT) LATEST DEFER! ;
+   CREATE LATEST DEFER! ;
-' (DEFERRED-UNINIT) (HIDE)
 
 \ Inline :NONAME-style function literals. "{ <code> }" 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 ( "<spaces>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
+\ 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
+\ The execution token may be passed to FREE-CLOSURE to release the memory when
-\ be passed to FREE to release the memory when the closure is no longer needed
+\ the closure is no longer needed. When executed, the closure xt will place
-\ When executed, the closure object will place xu ... x1 on the data stack
+\ xu ... x1 on the data stack and then execute the captured xt1.
-\ 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 )
+\ Return a closure which executes xt1 followed by xt2
-   { EXECUTE NEGATE } 1 CLOSURE ;
+: COMPOSE ( xt1 xt2 -- xt3 )
+   { >R EXECUTE R> EXECUTE } 2 CLOSURE ;
 
-: MERGE-SORT-DESCENDING ( head1 link-xt compare-xt -- head2 )
+\ Sort in descending order by negating the result of compare-xt
-   NEGATED DUP >R MERGE-SORT R> FREE ;
+: MERGE-SORT> ( head1 link-xt compare-xt -- head2 )
+   ['] NEGATE COMPOSE DUP >R MERGE-SORT R> FREE-CLOSURE ;
 
 HIDE SPLIT
 HIDE MERGE

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