add remaining file I/O words & script mode
This commit is contained in:
parent
d2ca30d177
commit
7d286ddffc
2
Makefile
2
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
136
startup.4th
136
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<closeparen>" -- ) IMMEDIATE BEGIN NEXT-CHAR [[ CHAR ) ]] = UNTIL ;
|
||||
: \ ( "ccc<eol>" -- ) IMMEDIATE
|
||||
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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -1,3 +1,6 @@
|
|||
"lib/merge-sort.4th" INCLUDED
|
||||
ALSO MERGE-SORT
|
||||
|
||||
STRUCT
|
||||
CELL% FIELD NODE>LINK
|
||||
CELL% FIELD NODE>DATA
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue