diff --git a/Makefile b/Makefile index e28ebaa..a1fa167 100644 --- a/Makefile +++ b/Makefile @@ -30,7 +30,7 @@ test-refresh: $(TEST_RESULTS) .PHONY: $(TEST_RESULTS) $(TEST_RESULTS): %.act: %.4th $(TARGET) @printf '%s … ' $(notdir $<) && \ - { ./$(TARGET) < $< >& $@; echo exit-code: $$? >> $@; } && \ + { ./$(TARGET) $< >& $@; echo exit-code: $$? >> $@; } && \ if [[ ! -e $(@:%.act=%.exp) ]]; then echo '(new)'; cp $@ $(@:%.act=%.exp); \ elif diff -q $(@:%.act=%.exp) $@ >/dev/null; then echo '✓'; \ else echo '✗'; diff -u $(@:%.act=%.exp) $@; :; fi diff --git a/lib/merge-sort.4th b/lib/merge-sort.4th new file mode 100644 index 0000000..a750f79 --- /dev/null +++ b/lib/merge-sort.4th @@ -0,0 +1,73 @@ +GET-ORDER + +ONLY FORTH + +VOCABULARY MERGE-SORT +ALSO MERGE-SORT DEFINITIONS + +VOCABULARY MERGE-SORT-INTERNALS +ALSO MERGE-SORT-INTERNALS DEFINITIONS + +\ In the next few definitions link-xt is a function that takes a node address +\ and returns a pointer to its link field (holding NULL or the address of the +\ next node); compare-xt takes two node addresses and returns a negative, zero, +\ or positive value if the left node is less than, equal to, or greater than +\ the right node, respectively. The term "head" refers to the address of the +\ node at the beginning of a list, or NULL if the list is empty. &link is the +\ address of either a cell holding the head of the list or a node's link field. + +\ Put the even items from head into head1 and the odd items into head2 +: SPLIT ( head link-xt -- head1 head2 ) + >R NULL NULL ROT BEGIN ?DUP WHILE + TUCK R@ EXECUTE XCHG >R SWAP R> + REPEAT RDROP SWAP ; + +\ Merge two sorted lists into a single sorted list +: MERGE ( head1 head2 link-xt compare-xt -- head ) + 2>R NULL >R RSP@ BEGIN + ( S: head1 head2 &link R: link-xt compare-xt head ) + \ If either list is empty we're done; append the other to the result and exit + OVER NULL= IF NIP ! R> 2RDROP EXIT THEN + 2 PICK NULL= IF ! DROP R> 2RDROP EXIT THEN + \ Otherwise compare the two nodes + \ If head1 is greater than head2 then move head2 to the output, else head1 + >R 2DUP R> -ROT 1 RPICK EXECUTE 0< IF >R SWAP R> THEN + >R DUP 3 RPICK EXECUTE @ SWAP R> + ( S: head1 head2' head2 &link R: link-xt compare-xt head ) + \ Store NULL in head2's link field; save &link2 under head2 on the stack + \ Store head2 at &link + OVER NULL SWAP 2 RPICK EXECUTE DUP >R ! R> -ROT ! + ( S: head1 head2' &link2 R: link-xt compare-xt head ) + AGAIN ; + +PREVIOUS DEFINITIONS ALSO MERGE-SORT-INTERNALS + +\ Return TRUE if the given list is sorted, or FALSE otherwise +: SORTED? ( head link-xt compare-xt -- flag ) + \ An empty list is trivially sorted + 2>R ?DUP NULL= IF 2RDROP TRUE EXIT THEN + BEGIN + \ Get the next node + DUP 1 RPICK EXECUTE @ + \ If there is no next node then the list is sorted + ?DUP NULL= IF DROP 2RDROP TRUE EXIT THEN + \ If the current node is greater than the next node then the list is not sorted + TUCK R@ EXECUTE 0> IF DROP 2RDROP FALSE EXIT THEN + \ Otherwise repeat for the next pair of adjacent nodes + AGAIN ; + +\ Sort the given list using the recursive merge sort algorithm: +\ 1. If the list is already sorted, return it unchanged. +\ 2. Otherwise, split the list into two approximately equal sublists. +\ 3. Sort both sublists recursively. +\ 4. Merge the sorted sublists into a single sorted list. +: MERGE-SORT ( head1 link-xt compare-xt -- head2 ) RECURSIVE + 2>R DUP 2R@ SORTED? 0= IF + 1 RPICK SPLIT 2R@ MERGE-SORT SWAP 2R@ MERGE-SORT 2R@ MERGE + THEN 2RDROP ; + +\ 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 ; + +SET-ORDER diff --git a/startup.4th b/startup.4th index 80d4310..b0729d2 100644 --- a/startup.4th +++ b/startup.4th @@ -1257,8 +1257,10 @@ CREATE EXCEPTION-STACK NULL , ' FORTH (DEFINITIONS) \ Comments; ignore all characters until the next EOL or ) character, respectively -: \ ( "ccc" -- ) IMMEDIATE BEGIN NEXT-CHAR LF = UNTIL ; -: ( ( "ccc" -- ) IMMEDIATE BEGIN NEXT-CHAR [[ CHAR ) ]] = UNTIL ; +: \ ( "ccc" -- ) IMMEDIATE + BEGIN PARSE-EMPTY? 0= WHILE NEXT-CHAR LF = UNTIL ; +: ( ( "ccc" -- ) IMMEDIATE + BEGIN PARSE-EMPTY? 0= WHILE NEXT-CHAR [[ CHAR ) ]] = UNTIL ; \ Placeholder to be replaced before switching to terminal input DEFER REFILL @@ -1920,10 +1922,14 @@ DEFER FIND-HOOK ( c-addr u -- c-addr u 0 | xt 1 | xt -1 ) ROOT DEFINITIONS -' ONLY ALIAS ONLY -' FORTH ALIAS FORTH -' SET-ORDER ALIAS SET-ORDER -' >WORDLIST ALIAS >WORDLIST +' ONLY ALIAS ONLY +' FORTH ALIAS FORTH +' ALSO ALIAS ALSO +' PREVIOUS ALIAS PREVIOUS +' GET-ORDER ALIAS GET-ORDER +' SET-ORDER ALIAS SET-ORDER +' VOCABULARY ALIAS VOCABULARY +' >WORDLIST ALIAS >WORDLIST FORTH DEFINITIONS @@ -2521,70 +2527,6 @@ FORTH DEFINITIONS : WORDS GET-ORDER ?DUP IF 1- SWAP >R NDROP R> SHOW-WORDLIST THEN ; -\ In the next few definitions link-xt is a function that takes a node address -\ and returns a pointer to its link field (holding NULL or the address of the -\ next node); compare-xt takes two node addresses and returns a negative, zero, -\ or positive value if the left node is less than, equal to, or greater than -\ the right node, respectively. The term "head" refers to the address of the -\ node at the beginning of a list, or NULL if the list is empty. &link is the -\ address of either a cell holding the head of the list or a node's link field. - -UTILITY DEFINITIONS - -\ Put the even items from head into head1 and the odd items into head2 -: SPLIT ( head link-xt -- head1 head2 ) - >R NULL NULL ROT BEGIN ?DUP WHILE - TUCK R@ EXECUTE XCHG >R SWAP R> - REPEAT RDROP SWAP ; - -\ Merge two sorted lists into a single sorted list -: MERGE ( head1 head2 link-xt compare-xt -- head ) - 2>R NULL >R RSP@ BEGIN - ( S: head1 head2 &link R: link-xt compare-xt head ) - \ If either list is empty we're done; append the other to the result and exit - OVER NULL= IF NIP ! R> 2RDROP EXIT THEN - 2 PICK NULL= IF ! DROP R> 2RDROP EXIT THEN - \ Otherwise compare the two nodes - \ If head1 is greater than head2 then move head2 to the output, else head1 - >R 2DUP R> -ROT 1 RPICK EXECUTE 0< IF >R SWAP R> THEN - >R DUP 3 RPICK EXECUTE @ SWAP R> - ( S: head1 head2' head2 &link R: link-xt compare-xt head ) - \ Store NULL in head2's link field; save &link2 under head2 on the stack - \ Store head2 at &link - OVER NULL SWAP 2 RPICK EXECUTE DUP >R ! R> -ROT ! - ( S: head1 head2' &link2 R: link-xt compare-xt head ) - AGAIN ; - -FORTH DEFINITIONS - -\ Return TRUE if the given list is sorted, or FALSE otherwise -: SORTED? ( head link-xt compare-xt -- flag ) - \ An empty list is trivially sorted - 2>R ?DUP NULL= IF 2RDROP TRUE EXIT THEN - BEGIN - \ Get the next node - DUP 1 RPICK EXECUTE @ - \ If there is no next node then the list is sorted - ?DUP NULL= IF DROP 2RDROP TRUE EXIT THEN - \ If the current node is greater than the next node then the list is not sorted - TUCK R@ EXECUTE 0> IF DROP 2RDROP FALSE EXIT THEN - \ Otherwise repeat for the next pair of adjacent nodes - AGAIN ; - -\ Sort the given list using the recursive merge sort algorithm: -\ 1. If the list is already sorted, return it unchanged. -\ 2. Otherwise, split the list into two approximately equal sublists. -\ 3. Sort both sublists recursively. -\ 4. Merge the sorted sublists into a single sorted list. -: MERGE-SORT ( head1 link-xt compare-xt -- head2 ) RECURSIVE - 2>R DUP 2R@ SORTED? 0= IF - 1 RPICK SPLIT 2R@ MERGE-SORT SWAP 2R@ MERGE-SORT 2R@ MERGE - THEN 2RDROP ; - -\ 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 ; - UTILITY DEFINITIONS \ AA Tree, a variation on the Red-Black Tree @@ -2891,14 +2833,27 @@ O_RDWR CONSTANT R/W ( -- fam ) : FLUSH-FILE ( fileid -- ) DUP FILE-POSITION ROT REPOSITION-FILE ; -: RESIZE-FILE ( ud fileid -- ) …TODO… ; +: RESIZE-FILE ( ud fileid -- ) + DUP FLUSH-FILE + -ROT SYS_FTRUNCATE64 SYSCALL3-RETRY + 0<> IF EXCP-FILE-IO THROW THEN ; -: FILE-SIZE ( fileid -- ud ) +: FILE-STATUS ( c-addr u -- stat64-addr ) + STAT64-RESULT SIZEOF stat64% 0 FILL + AT_FDCWD -ROT MAKE-CSTRING DUP >R STAT64-RESULT 0 + SYS_FSTATAT64 SYSCALL4-RETRY + R> FREE ▪ 0<> IF EXCP-FILE-IO THROW THEN + STAT64-RESULT ; + +: (FILE-STATUS) ( fileid -- stat64-addr ) STAT64-RESULT SIZEOF stat64% 0 FILL FD>FILE FILE>FD @ EMPTY-CSTRING STAT64-RESULT AT_EMPTY_PATH SYS_FSTATAT64 SYSCALL4-RETRY 0<> IF EXCP-FILE-IO THROW THEN - STAT64-RESULT stat64>size 2@ SWAP ; + STAT64-RESULT ; + +: FILE-SIZE ( fileid -- ud ) + (FILE-STATUS) stat64>size 2@ SWAP ; UTILITY DEFINITIONS @@ -2991,8 +2946,15 @@ FORTH DEFINITIONS DUP FILE>FD @ SYS_CLOSE SYSCALL1 DROP ( do not retry close ) DUP FILE>BUFFER @ FREE ▪ DUP FILE>SOURCE 2@ DROP FREE ▪ FREE ; -: RENAME-FILE ( c-addr1 u1 c-addr2 u2 -- ) …TODO… ; -: DELETE-FILE ( c-addr u -- ) …TODO… ; +: RENAME-FILE ( c-addr1 u1 c-addr2 u2 -- ) + 2>R 2>R AT_FDCWD 2R> MAKE-CSTRING AT_FDCWD OVER 2R> ROT >R MAKE-CSTRING DUP >R 0 + SYS_RENAMEAT2 SYSCALL5-RETRY + R> FREE R> FREE ▪ 0<> IF EXCP-FILE-IO THROW THEN ; + +: DELETE-FILE ( c-addr u -- ) + AT_FDCWD -ROT MAKE-CSTRING DUP >R 0 + SYS_UNLINKAT SYSCALL3-RETRY + R> FREE ▪ 0<> IF EXCP-FILE-IO THROW THEN ; : INCLUDE-FILE ( i*x fileid -- j*x ) SAVE-INPUT N>R ▪ SOURCE 2>R ▪ SOURCE-ID >R @@ -3003,11 +2965,23 @@ FORTH DEFINITIONS : INCLUDED ( i*x c-addr u -- j*x ) R/O OPEN-FILE DUP >R [[ ' INCLUDE-FILE ]] CATCH R> CLOSE-FILE RETHROW ; -: FILE-STATUS ( c-addr u -- x ) …TODO… ; - -ONLY FORTH DEFINITIONS - : BANNER "JumpForth version " TYPE VERSION . ", by Jesse McDonald\n" TYPE ; -INTERACTIVE? [IF] BANNER [THEN] -QUIT +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 + REPORT 2DROP + THEN + BYE + ELSE + [ INTERACTIVE? ] [IF] BANNER [THEN] + QUIT + THEN ; + +MAIN diff --git a/test/merge-sort.4th b/test/merge-sort.4th index 5e9cec4..05daec4 100644 --- a/test/merge-sort.4th +++ b/test/merge-sort.4th @@ -1,3 +1,6 @@ +"lib/merge-sort.4th" INCLUDED +ALSO MERGE-SORT + STRUCT CELL% FIELD NODE>LINK CELL% FIELD NODE>DATA diff --git a/test/preserved.4th b/test/preserved.4th index 85d1f8f..df21b38 100644 --- a/test/preserved.4th +++ b/test/preserved.4th @@ -2,7 +2,7 @@ VARIABLE X 0 X ! "Change X from 0 to 3\n" TYPE -1 2 { 3 X ! } X PRESERVED +{ 1 2 { 3 X ! } X PRESERVED } CATCH DROP .S "X: " TYPE X @ . EOL @@ -11,7 +11,7 @@ EOL "Change X from 4 to 7 and then QUIT\n" TYPE 4 X ! -5 6 { 7 X ! QUIT } X PRESERVED +{ 5 6 { 7 X ! QUIT } X PRESERVED } CATCH DROP .S "X: " TYPE X @ . EOL @@ -20,7 +20,7 @@ EOL "QUIT without changing X from 8\n" TYPE 8 X ! -9 10 ' QUIT X PRESERVED +{ 9 10 ' QUIT X PRESERVED } CATCH DROP .S "X: " TYPE X @ . EOL diff --git a/test/preserved.exp b/test/preserved.exp index ecf1257..4d7cea8 100644 --- a/test/preserved.exp +++ b/test/preserved.exp @@ -3,10 +3,10 @@ S(2): 1 2 X: 0 Change X from 4 to 7 and then QUIT -S(3): 5 6 -56 +S(0): X: 4 QUIT without changing X from 8 -S(3): 9 10 -56 +S(0): X: 8 exit-code: 0