diff --git a/startup.4th b/startup.4th index 75219a5..62fb5ed 100644 --- a/startup.4th +++ b/startup.4th @@ -106,6 +106,7 @@ UTILITY SET-CURRENT -13 CONSTANT EXCP-UNDEFINED-WORD -17 CONSTANT EXCP-PNO-OVERFLOW -24 CONSTANT EXCP-BAD-NUMERIC-ARGUMENT +-36 CONSTANT EXCP-NON-EXISTENT-FILE -37 CONSTANT EXCP-FILE-IO -39 CONSTANT EXCP-UNEXPECTED-EOF -56 CONSTANT EXCP-QUIT @@ -165,6 +166,8 @@ DEFER QUIT : ?FAIL ( flag c-addr u -- | ) ROT IF FAIL ELSE 2DROP THEN ; +: …TODO… "not implemented" FAIL ; + \ Get the execution token of the most recent word in the compilation word list \ If the word list is empty the result will be zero : LATEST ( -- xt | NULL ) GET-CURRENT @ ; @@ -220,7 +223,6 @@ DEFER QUIT 12 ⇒ SYS_CHDIR 13 ⇒ SYS_TIME 15 ⇒ SYS_CHMOD - 19 ⇒ SYS_LSEEK 20 ⇒ SYS_GETPID 21 ⇒ SYS_MOUNT 25 ⇒ SYS_STIME @@ -531,6 +533,21 @@ DEFER QUIT \ Special dirfd for *at syscalls to resolve path relative to current directory -100 ⇒ AT_FDCWD +\ Common flags for *at syscalls +1 8 LSHIFT ⇒ AT_SYMLINK_NOFOLLOW +1 9 LSHIFT ⇒ AT_REMOVEDIR ( only for unlinkat ) +1 9 LSHIFT ⇒ AT_EACCESS ( only for faccessat ) +1 10 LSHIFT ⇒ AT_SYMLINK_FOLLOW +1 11 LSHIFT ⇒ AT_NO_AUTOMOUNT +1 12 LSHIFT ⇒ AT_EMPTY_PATH +3 13 LSHIFT ⇒ AT_STATX_SYNC_TYPE ( mask ) +1 15 LSHIFT ⇒ AT_RECURSIVE + +\ Sync types for statx +0 13 LSHIFT ⇒ AT_STATX_SYNC_AS_STAT +1 13 LSHIFT ⇒ AT_STATX_FORCE_SYNC +2 13 LSHIFT ⇒ AT_STATX_DONT_SYNC + \ errno values \ System calls return -errno in the range [-4095, -1] 1 ⇒ ERRNO_EPERM @@ -611,9 +628,29 @@ DEFER QUIT \ openat2() flags 1 6 LSHIFT ⇒ O_CREAT 1 7 LSHIFT ⇒ O_EXCL +1 8 LSHIFT ⇒ O_NOCTTY 1 9 LSHIFT ⇒ O_TRUNC 1 10 LSHIFT ⇒ O_APPEND 1 11 LSHIFT ⇒ O_NONBLOCK +1 12 LSHIFT ⇒ O_DSYNC +1 13 LSHIFT ⇒ FASYNC +1 14 LSHIFT ⇒ O_DIRECT +1 15 LSHIFT ⇒ O_LARGEFILE +1 16 LSHIFT ⇒ O_DIRECTORY +1 17 LSHIFT ⇒ O_NOFOLLOW +1 18 LSHIFT ⇒ O_NOATIME +1 19 LSHIFT ⇒ O_CLOEXEC +1 20 LSHIFT ⇒ __O_SYNC +1 21 LSHIFT ⇒ O_PATH +1 22 LSHIFT ⇒ __O_TMPFILE + +__O_SYNC O_DSYNC OR ⇒ O_SYNC +__O_TMPFILE O_DIRECTORY OR ⇒ O_TMPFILE + +\ Achor location for whence argument to _llseek +0 ⇒ SEEK_SET +1 ⇒ SEEK_CUR +2 ⇒ SEEK_END \ Names for the standard file descriptor numbers 0 ⇒ STDIN @@ -2232,6 +2269,7 @@ SYSTEM DEFINITIONS { "Pictured numeric output string overflow\n" TYPE-ERR } EXCP-PNO-OVERFLOW REPORTER! { "Invalid numeric argument\n" TYPE-ERR } EXCP-BAD-NUMERIC-ARGUMENT REPORTER! +{ "Non-existent file\n" TYPE-ERR } EXCP-NON-EXISTENT-FILE REPORTER! { "File I/O exception\n" TYPE-ERR } EXCP-FILE-IO REPORTER! { "Unexpected end of file\n" TYPE-ERR } EXCP-UNEXPECTED-EOF REPORTER! { "Quit\n" TYPE-ERR } EXCP-QUIT REPORTER! @@ -2730,6 +2768,12 @@ UTILITY DEFINITIONS LINUX DEFINITIONS +STRUCT + uint64% FIELD open_how>flags + uint64% FIELD open_how>mode + uint64% FIELD open_how>resolve +ENDSTRUCT open_how% + STRUCT unsigned-long-long% FIELD stat64>dev unsigned-char% 4 * FIELD stat64>__pad0 @@ -2752,35 +2796,120 @@ STRUCT unsigned-long-long% FIELD stat64>ino ENDSTRUCT stat64% +SYSTEM DEFINITIONS + +STRUCT + AA-NODE% FIELD FILE>NODE + CELL% FIELD FILE>FD + CELL% FIELD FILE>BUFFER + 2CELL% FIELD FILE>LEFTOVER + 2CELL% FIELD FILE>POSITION +ENDSTRUCT FILE% + +{ CONTAINEROF FILE>NODE ▪ FILE>FD @ } ' <=> NEW-AA-TREE CONSTANT FILES + +ALSO LINUX +open_how% %VARIABLE OPEN-HOW +stat64% %VARIABLE STAT64-RESULT +signed-long-long% %VARIABLE LLSEEK-RESULT +PREVIOUS + +: FD>FILE ( fileid -- file-addr ) + FILES AA-LOOKUP ?DUP 0= "unknown file ID" ?FAIL ; + +UTILITY DEFINITIONS + +4096 CONSTANT FILE-BUFFER-BYTES + +: MAKE-CSTRING ( c-addr1 u -- c-addr2 ) + TUCK ▪ DUP 1+ ALLOCATE ▪ DUP >R ▪ SWAP CMOVE ▪ 0 ▪ SWAP R@ + C! ▪ R> ; + +: EMPTY-CSTRING "\0" DROP ; + FORTH DEFINITIONS ALSO LINUX + O_RDONLY CONSTANT R/O ( -- fam ) O_WRONLY CONSTANT W/O ( -- fam ) O_RDWR CONSTANT R/W ( -- fam ) -PREVIOUS +\ All files are treated as binary files : BIN ( fam1 -- fam2 ) IMMEDIATE ; -: CREATE-FILE ( c-addr u fam -- fileid ) ; -: OPEN-FILE ( c-addr u fam -- fileid ) ; -: REPOSITION-FILE ( ud fileid -- ) ; -: FILE-POSITION ( fileid -- ud ) ; -: RESIZE-FILE ( ud fileid -- ) ; -: FILE-SIZE ( fileid -- ud ) ; +: OPEN-FILE ( c-addr u fam -- fileid ) + FILE% %ALLOCATE >R + FILE-BUFFER-BYTES ALLOCATE R@ FILE>BUFFER ! + [ NULL 0 ] 2LITERAL R@ FILE>LEFTOVER 2! + 0# R@ FILE>POSITION 2! + OPEN-HOW SIZEOF open_how% 0 FILL + DUP 0 SWAP OPEN-HOW open_how>flags 2! + [[ O_CREAT __O_TMPFILE OR ]] AND IF + 0 0666 OPEN-HOW open_how>mode 2! + THEN + AT_FDCWD ▪ -ROT MAKE-CSTRING DUP >R ▪ OPEN-HOW ▪ SIZEOF open_how% + SYS_OPENAT2 SYSCALL4-RETRY + R> FREE + DUP ERRNO_ENOENT = OR-ELSE DUP ERRNO_ENOTDIR = THEN IF + DROP EXCP-NON-EXISTENT-FILE THROW THEN + DUP 0< IF DROP EXCP-FILE-IO THROW THEN + DUP R@ FILE>FD ! + R@ FILES AA-LOOKUP 0<> "internal error - duplicate key in FILES" ?FAIL + R> FILES AA-INSERT ; + +: CREATE-FILE ( c-addr u fam -- fileid ) + [[ O_CREAT O_TRUNC OR ]] OR OPEN-FILE ; + +: REPOSITION-FILE ( ud fileid -- ) + DUP ▪ FD>FILE >R ▪ -ROT SWAP ▪ LLSEEK-RESULT ▪ SEEK_SET + SYS__LLSEEK SYSCALL5-RETRY + [ NULL 0 ] 2LITERAL R@ FILE>LEFTOVER 2! + 0<> IF RDROP EXCP-FILE-IO THROW THEN + LLSEEK-RESULT 2@ SWAP R@ FILE>POSITION 2! + RDROP ; + +: FILE-POSITION ( fileid -- ud ) FD>FILE FILE>POSITION 2@ ; + +: FLUSH-FILE ( fileid -- ) DUP FILE-POSITION ROT REPOSITION-FILE ; + +: RESIZE-FILE ( ud fileid -- ) …TODO… ; + +: FILE-SIZE ( fileid -- ud ) + 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 ; + : READ-FILE ( c-addr u1 fileid -- u2 ) ; : READ-LINE ( c-addr u1 fileid -- u2 t=eof ) ; -: WRITE-FILE ( c-addr u fileid -- ) ; -: WRITE-LINE ( c-addr u fileid -- ) ; -: FLUSH-FILE ( fileid -- ) ; -: CLOSE-FILE ( fileid -- ) ; -: RENAME-FILE ( c-addr1 u1 c-addr2 u2 -- ) ; -: DELETE-FILE ( c-addr u -- ) ; -: INCLUDE-FILE ( i*x fileid -- j*x ) ; -: INCLUDED ( i*x c-addr u -- j*x ) ; +: WRITE-FILE ( c-addr u fileid -- ) + FD>FILE >R + R@ FILE>LEFTOVER 2@ NIP IF R@ FILE>FD @ FLUSH-FILE THEN + BEGIN DUP WHILE + 2DUP R@ FILE>FD @ -ROT SYS_WRITE SYSCALL3-RETRY + DUP -4095 1 WITHIN IF DROP EXCP-FILE-IO THROW THEN + DUP OVER U> "wrote more data than requested" ?FAIL + DUP 0 R@ FILE>POSITION 2@ D+ R@ FILE>POSITION 2! + /STRING + REPEAT ▪ 2DROP ▪ RDROP ; -: FILE-STATUS ( c-addr u -- x ) ; +: WRITE-LINE ( c-addr u fileid -- ) + DUP >R WRITE-FILE (EOL) R> WRITE-FILE ; + +: CLOSE-FILE ( fileid -- ) + FD>FILE ▪ DUP FILE>FD @ FILES AA-DELETE DROP + DUP FILE>FD @ SYS_CLOSE SYSCALL1 DROP ( do not retry close ) + DUP FILE>BUFFER @ FREE ▪ FREE ; + +: RENAME-FILE ( c-addr1 u1 c-addr2 u2 -- ) …TODO… ; +: DELETE-FILE ( c-addr u -- ) …TODO… ; + +: INCLUDE-FILE ( i*x fileid -- j*x ) …TODO… ; +: INCLUDED ( i*x c-addr u -- j*x ) …TODO… ; + +: FILE-STATUS ( c-addr u -- x ) …TODO… ; ONLY FORTH DEFINITIONS