add remaining file I/O words & script mode

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

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

startup.4th

@@ -1257,8 +1257,10 @@ CREATE EXCEPTION-STACK NULL ,
 ' FORTH (DEFINITIONS)
 
 \ Comments; ignore all characters until the next EOL or ) character, respectively
-: \  ( "ccc<eol>" -- )  IMMEDIATE BEGIN NEXT-CHAR LF = UNTIL ;
+: \  ( "ccc<eol>" -- )  IMMEDIATE
-: (  ( "ccc<closeparen>" -- )  IMMEDIATE BEGIN NEXT-CHAR [[ CHAR ) ]] = UNTIL ;
+   BEGIN PARSE-EMPTY? 0= WHILE NEXT-CHAR LF = UNTIL ;
+: (  ( "ccc<closeparen>" -- )  IMMEDIATE
+   BEGIN PARSE-EMPTY? 0= WHILE NEXT-CHAR [[ CHAR ) ]] = UNTIL ;
 
 \ Placeholder to be replaced before switching to terminal input
 DEFER REFILL
@@ -1922,7 +1924,11 @@ ROOT DEFINITIONS
 
 ' 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… ;
+: RENAME-FILE  ( c-addr1 u1 c-addr2 u2 -- )
-: DELETE-FILE  ( c-addr u -- ) …TODO… ;
+   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]
+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

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

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
 

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