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

add a COMPOSE combinator and ALIAS defining word

This commit is contained in:
Jesse D. McDonald 2020-10-25 02:14:37 -05:00
parent 24682b970b
commit e268cac0a4
2 changed files with 23 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
startup.4th
View File

@ -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 ( "<spaces>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 "<spaces>ccc" -- )
CREATE LATEST DEFER! ;
\ 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
\ 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

2
test/merge-sort.4th
View File

@ -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