Make unix-system-call retry the call immediately upon hitting EINTR. Use unix-system...

diff --git a/basis/io/backend/unix/unix.factor b/basis/io/backend/unix/unix.factor
index a8070525c7d3ca676b5d3d2389811de801d5043a..2ab5bdca05daca9f6d326cf762ead5fd16feb200 100644 (file)
--- 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 ;
 
 : <fd> ( 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 3af4c09f28e23f0647c369feeca69993c9d59fbb..c5678fae9c2e08fe3c49e54545af1527f5cfe8df 100644 (file)
--- 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 <struct>
     f <void*>
-    [ 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 06ba73bb462b14d3f60517af57f3a2de1d58da35..b1f659675981f5d13d733ddabf4fed59a48859f7 100644 (file)
--- 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 <struct>
     f <void*>
-    [ 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 eedf8de47ae35e93ef859a46bd6e359fd83902b2..180f194c89064c2662da5378365689d0e8528ccd 100644 (file)
--- 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 f41adfa7311e2f948eaebbeef96d12ff53b57e3d..ced4c11c59713ac51e6da3a7a4454f7c75ca65c5 100644 (file)
--- 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 9518d1c754366e135344ad1c181c03984a3e29ec..783e40a70cef5c6bb2e04651fbfbd454a687f4b3 100644 (file)
--- 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 [ <byte-array> ] keep getcwd
+    MAXPATHLEN [ <byte-array> ] 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 cdf7e54408337a1da0fb7a9e0de6ff800b6abc07..4f25435985a839faa351a19f36a49b7ba11c94bc 100644 (file)
--- 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 e9cb9d59188aca5fc0ab8a95a883df54fffe770f..86b8646bdd9afa3f7c626bf206e74c973fd7f575 100644 (file)
--- 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
     ] ;