diff --git a/basis/io/backend/unix/unix.factor b/basis/io/backend/unix/unix.factor index a8070525c7..2ab5bdca05 100644 --- a/basis/io/backend/unix/unix.factor +++ b/basis/io/backend/unix/unix.factor @@ -17,8 +17,8 @@ TUPLE: fd < disposable fd ; : init-fd ( fd -- fd ) [ |dispose - dup fd>> F_SETFL O_NONBLOCK fcntl io-error - dup fd>> F_SETFD FD_CLOEXEC fcntl io-error + dup fd>> F_SETFL O_NONBLOCK [ fcntl ] unix-system-call io-error + dup fd>> F_SETFD FD_CLOEXEC [ fcntl ] unix-system-call io-error ] with-destructors ; : ( n -- fd ) @@ -50,7 +50,7 @@ M: fd cancel-operation ( fd -- ) ] if ; M: unix tell-handle ( handle -- n ) - fd>> 0 SEEK_CUR lseek [ io-error ] [ ] bi ; + fd>> 0 SEEK_CUR [ lseek ] unix-system-call [ io-error ] [ ] bi ; M: unix seek-handle ( n seek-type handle -- ) swap { @@ -59,7 +59,7 @@ M: unix seek-handle ( n seek-type handle -- ) { io:seek-end [ SEEK_END ] } [ io:bad-seek-type ] } case - [ fd>> swap ] dip lseek io-error ; + [ fd>> swap ] dip [ lseek ] unix-system-call io-error ; SYMBOL: +retry+ ! just try the operation again without blocking SYMBOL: +input+ diff --git a/basis/io/directories/unix/linux/linux.factor b/basis/io/directories/unix/linux/linux.factor index 3af4c09f28..c5678fae9c 100644 --- a/basis/io/directories/unix/linux/linux.factor +++ b/basis/io/directories/unix/linux/linux.factor @@ -7,5 +7,5 @@ IN: io.directories.unix.linux M: unix find-next-file ( DIR* -- dirent ) dirent f - [ readdir64_r 0 = [ (io-error) ] unless ] 2keep + [ [ readdir64_r ] unix-system-call 0 = [ (io-error) ] unless ] 2keep *void* [ drop f ] unless ; diff --git a/basis/io/directories/unix/unix.factor b/basis/io/directories/unix/unix.factor index 06ba73bb46..b1f6596759 100644 --- a/basis/io/directories/unix/unix.factor +++ b/basis/io/directories/unix/unix.factor @@ -17,29 +17,29 @@ M: unix touch-file ( path -- ) ] if ; M: unix move-file ( from to -- ) - [ normalize-path ] bi@ rename io-error ; + [ normalize-path ] bi@ [ rename ] unix-system-call io-error ; M: unix delete-file ( path -- ) normalize-path unlink-file ; M: unix make-directory ( path -- ) - normalize-path OCT: 777 mkdir io-error ; + normalize-path OCT: 777 [ mkdir ] unix-system-call io-error ; M: unix delete-directory ( path -- ) - normalize-path rmdir io-error ; + normalize-path [ rmdir ] unix-system-call io-error ; M: unix copy-file ( from to -- ) [ normalize-path ] bi@ call-next-method ; : with-unix-directory ( path quot -- ) - [ opendir dup [ (io-error) ] unless ] dip - dupd curry swap '[ _ closedir io-error ] [ ] cleanup ; inline + [ [ opendir ] unix-system-call dup [ (io-error) ] unless ] dip + dupd curry swap '[ _ [ closedir ] unix-system-call io-error ] [ ] cleanup ; inline HOOK: find-next-file os ( DIR* -- byte-array ) M: unix find-next-file ( DIR* -- byte-array ) dirent f - [ readdir_r 0 = [ (io-error) ] unless ] 2keep + [ [ readdir_r ] unix-system-call 0 = [ (io-error) ] unless ] 2keep *void* [ drop f ] unless ; : dirent-type>file-type ( ch -- type ) diff --git a/basis/io/files/info/unix/unix.factor b/basis/io/files/info/unix/unix.factor index eedf8de47a..180f194c89 100644 --- a/basis/io/files/info/unix/unix.factor +++ b/basis/io/files/info/unix/unix.factor @@ -109,7 +109,7 @@ M: unix stat>type ( stat -- type ) : chmod-set-bit ( path mask ? -- ) [ dup stat-mode ] 2dip - [ bitor ] [ unmask ] if chmod io-error ; + [ bitor ] [ unmask ] if [ chmod ] unix-system-call io-error ; GENERIC# file-mode? 1 ( obj mask -- ? ) @@ -174,7 +174,7 @@ CONSTANT: ALL-EXECUTE OCT: 0000111 : set-other-execute ( path ? -- ) OTHER-EXECUTE swap chmod-set-bit ; : set-file-permissions ( path n -- ) - [ normalize-path ] dip chmod io-error ; + [ normalize-path ] dip [ chmod ] unix-system-call io-error ; : file-permissions ( path -- n ) normalize-path file-info permissions>> ; @@ -202,7 +202,7 @@ PRIVATE> : set-file-times ( path timestamps -- ) #! set access, write [ normalize-path ] dip - timestamps>byte-array utimes io-error ; + timestamps>byte-array [ utimes ] unix-system-call io-error ; : set-file-access-time ( path timestamp -- ) f 2array set-file-times ; @@ -211,7 +211,8 @@ PRIVATE> f swap 2array set-file-times ; : set-file-ids ( path uid gid -- ) - [ normalize-path ] 2dip [ -1 or ] bi@ chown io-error ; + [ normalize-path ] 2dip [ -1 or ] bi@ + [ chown ] unix-system-call io-error ; GENERIC: set-file-user ( path string/id -- ) diff --git a/basis/io/files/links/unix/unix.factor b/basis/io/files/links/unix/unix.factor index f41adfa731..ced4c11c59 100644 --- a/basis/io/files/links/unix/unix.factor +++ b/basis/io/files/links/unix/unix.factor @@ -5,10 +5,10 @@ io.files sequences ; IN: io.files.links.unix M: unix make-link ( path1 path2 -- ) - normalize-path symlink io-error ; + normalize-path [ symlink ] unix-system-call io-error ; M: unix make-hard-link ( path1 path2 -- ) - normalize-path link io-error ; + normalize-path [ link ] unix-system-call io-error ; M: unix read-link ( path -- path' ) normalize-path read-symbolic-link ; diff --git a/basis/io/files/unix/unix.factor b/basis/io/files/unix/unix.factor index 9518d1c754..783e40a70c 100644 --- a/basis/io/files/unix/unix.factor +++ b/basis/io/files/unix/unix.factor @@ -6,7 +6,8 @@ destructors system ; IN: io.files.unix M: unix cwd ( -- path ) - MAXPATHLEN [ ] keep getcwd + MAXPATHLEN [ ] keep + [ getcwd ] unix-system-call [ (io-error) ] unless* ; M: unix cd ( path -- ) [ chdir ] unix-system-call drop ; @@ -33,7 +34,7 @@ M: unix (file-writer) ( path -- stream ) : open-append ( path -- fd ) [ append-flags file-mode open-file |dispose - dup 0 SEEK_END lseek io-error + dup 0 SEEK_END [ lseek ] unix-system-call io-error ] with-destructors ; M: unix (file-appender) ( path -- stream ) diff --git a/basis/io/sockets/unix/unix.factor b/basis/io/sockets/unix/unix.factor index cdf7e54408..4f25435985 100644 --- a/basis/io/sockets/unix/unix.factor +++ b/basis/io/sockets/unix/unix.factor @@ -59,10 +59,15 @@ M: object (get-remote-address) ( handle local -- sockaddr ) [ (io-error) ] } cond ; -M: object establish-connection ( client-out remote -- ) - [ drop ] [ [ handle>> handle-fd ] [ make-sockaddr/size ] bi* connect ] 2bi +M:: object establish-connection ( client-out remote -- ) + client-out remote + [ drop ] + [ + [ handle>> handle-fd ] [ make-sockaddr/size ] bi* connect + ] 2bi { { [ 0 = ] [ drop ] } + { [ errno EINTR = ] [ drop client-out remote establish-connection ] } { [ errno EINPROGRESS = ] [ [ +output+ wait-for-port ] [ wait-to-connect ] bi ] } @@ -70,7 +75,12 @@ M: object establish-connection ( client-out remote -- ) } cond ; : ?bind-client ( socket -- ) - bind-local-address get [ [ fd>> ] dip make-sockaddr/size bind io-error ] [ drop ] if* ; inline + bind-local-address get [ + [ fd>> ] dip make-sockaddr/size + [ bind ] unix-system-call io-error + ] [ + drop + ] if* ; inline M: object ((client)) ( addrspec -- fd ) protocol-family SOCK_STREAM socket-fd @@ -83,7 +93,7 @@ M: object ((client)) ( addrspec -- fd ) : server-socket-fd ( addrspec type -- fd ) [ dup protocol-family ] dip socket-fd [ init-server-socket ] keep - [ handle-fd swap make-sockaddr/size bind io-error ] keep ; + [ handle-fd swap make-sockaddr/size [ bind ] unix-system-call io-error ] keep ; M: object (server) ( addrspec -- handle ) [ diff --git a/basis/unix/unix.factor b/basis/unix/unix.factor index e9cb9d5918..86b8646bdd 100644 --- a/basis/unix/unix.factor +++ b/basis/unix/unix.factor @@ -1,11 +1,12 @@ ! Copyright (C) 2005, 2010 Slava Pestov. ! Copyright (C) 2008 Eduardo Cavazos. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types alien.syntax kernel libc sequences -continuations byte-arrays strings math namespaces system -combinators combinators.smart vocabs.loader accessors -stack-checker macros locals generalizations unix.types io vocabs -classes.struct unix.time alien.libraries ; +USING: accessors alien alien.c-types alien.libraries +alien.syntax byte-arrays classes.struct combinators +combinators.short-circuit combinators.smart continuations +generalizations io kernel libc locals macros math namespaces +sequences stack-checker strings system unix.time unix.types +vocabs vocabs.loader ; IN: unix CONSTANT: PROT_NONE 0 @@ -47,17 +48,32 @@ ERROR: unix-error errno message ; ERROR: unix-system-call-error args errno message word ; +: unix-call-failed? ( ret -- ? ) + { + [ { [ integer? ] [ 0 < ] } 1&& ] + [ not ] + } 1|| ; + MACRO:: unix-system-call ( quot -- ) quot inputs :> n quot first :> word + 0 :> ret! + f :> failed! [ - n ndup quot call dup 0 < [ - drop + [ + n ndup quot call ret! + ret { + [ unix-call-failed? dup failed! ] + [ drop errno EINTR = ] + } 1&& + ] loop + failed [ n narray errno dup strerror word unix-system-call-error ] [ - n nnip + n ndrop + ret ] if ] ;