Merge git://factorcode.org/git/factor

core/io/files/files.factor

@@ -19,17 +19,17 @@ HOOK: make-directory io-backend ( path -- )
 
 HOOK: delete-directory io-backend ( path -- )
 
+: path-separator? ( ch -- ? ) windows? "/\\" "/" ? member? ;
+
 HOOK: root-directory? io-backend ( path -- ? )
 
-M: object root-directory? ( path -- ? ) "/" = ;
+M: object root-directory? ( path -- ? ) path-separator? ;
 
-! Words for accessing filesystem meta-data.
+: trim-path-separators ( str -- newstr )
-
+    [ path-separator? ] right-trim ;
-: path-separator? ( ch -- ? )
-    "/\\" member? ;
 
 : path+ ( str1 str2 -- str )
-    >r [ path-separator? ] right-trim "/" r>
+    >r trim-path-separators "/" r>
     [ path-separator? ] left-trim 3append ;
 
 : stat ( path -- directory? permissions length modified )
@@ -39,12 +39,15 @@ M: object root-directory? ( path -- ? ) "/" = ;
 
 : directory? ( path -- ? ) stat 3drop ;
 
+: special-directory? ( name -- ? )
+    { "." ".." } member? ;
+
 : fixup-directory ( path seq -- newseq )
     [
         dup string?
         [ tuck path+ directory? 2array ] [ nip ] if
     ] curry* map
-    [ first { "." ".." } member? not ] subset ;
+    [ first special-directory? not ] subset ;
 
 : directory ( path -- seq )
     normalize-directory dup (directory) fixup-directory ;
@@ -62,17 +65,17 @@ TUPLE: no-parent-directory path ;
     \ no-parent-directory construct-boa throw ;
 
 : parent-directory ( path -- parent )
-    {
+    trim-path-separators
-        { [ dup root-directory? ] [ ] }
+    dup root-directory? [ ] [
-        { [ dup "/\\" split ".." over member? "." rot member? or ]
+        dup last-path-separator drop [
-            [ no-parent-directory ] }
+            1+ cut
-        { [ t ] [ dup last-path-separator
+            special-directory?
-            [ 1+ head ] [ 2drop "." ] if ] }
+            [ no-parent-directory ] when
-    } cond ;
+        ] when*
+    ] if ;
 
 : file-name ( path -- string )
-    dup last-path-separator
+    dup last-path-separator [ 1+ tail ] [ drop ] if ;
-    [ 1+ tail ] [ drop ] if ;
 
 : resource-path ( path -- newpath )
     \ resource-path get [ image parent-directory ] unless*
@@ -82,8 +85,7 @@ TUPLE: no-parent-directory path ;
     "resource:" ?head [ resource-path ] when ;
 
 : make-directories ( path -- )
-    normalize-pathname
+    normalize-pathname trim-path-separators {
-    {
         { [ dup "." = ] [ ] }
         { [ dup root-directory? ] [ ] }
         { [ dup empty? ] [ ] }
@@ -94,19 +96,6 @@ TUPLE: no-parent-directory path ;
         ] }
     } cond drop ;
 
-TUPLE: pathname string ;
-
-C: <pathname> pathname
-
-M: pathname <=> [ pathname-string ] compare ;
-
-: home ( -- dir )
-    {
-        { [ winnt? ] [ "USERPROFILE" os-env ] }
-        { [ wince? ] [ "" resource-path ] }
-        { [ unix? ] [ "HOME" os-env ] }
-    } cond ;
-
 : copy-file ( from to -- )
     dup parent-directory make-directories
     <file-writer> [
@@ -121,3 +110,16 @@ M: pathname <=> [ pathname-string ] compare ;
     >r dup directory swap r> [
         >r >r first r> over path+ r> rot path+ copy-file
     ] 2curry each ;
+
+: home ( -- dir )
+    {
+        { [ winnt? ] [ "USERPROFILE" os-env ] }
+        { [ wince? ] [ "" resource-path ] }
+        { [ unix? ] [ "HOME" os-env ] }
+    } cond ;
+
+TUPLE: pathname string ;
+
+C: <pathname> pathname
+
+M: pathname <=> [ pathname-string ] compare ;

extra/io/server/server.factor

@@ -80,7 +80,8 @@ SYMBOL: log-stream
 
 : datagram-loop ( quot datagram -- )
     [
-        [ receive dup log-datagram >r swap call r> ] keep send
+        [ receive dup log-datagram >r swap call r> ] keep
+        pick [ send ] [ 3drop ] keep
     ] 2keep datagram-loop ; inline
 
 : spawn-datagrams ( quot addrspec -- )
@@ -91,4 +92,4 @@ SYMBOL: log-stream
 : with-datagrams ( seq service quot -- )
     [
         [ swap spawn-datagrams ] curry concurrency:parallel-each
-    ] with-logging ; inline
+    ] curry with-logging ; inline

extra/io/unix/files/files.factor

@@ -4,9 +4,6 @@ USING: io.backend io.nonblocking io.unix.backend io.files io
 unix kernel math continuations ;
 IN: io.unix.files
 
-M: unix-io root-directory? ( path -- ? )
-    "/" = ;
-
 : open-read ( path -- fd )
     O_RDONLY file-mode open dup io-error ;
 

extra/io/windows/nt/backend/backend.factor

@@ -8,6 +8,14 @@ IN: io.windows.nt.backend
 : unicode-prefix ( -- seq )
     "\\\\?\\" ; inline
 
+M: windows-nt-io root-directory? ( path -- ? )
+    dup length 2 = [
+        dup first Letter?
+        swap second CHAR: : = and
+    ] [
+        drop f
+    ] if ;
+
 M: windows-nt-io normalize-pathname ( string -- string )
     dup string? [ "pathname must be a string" throw ] unless
     "/" split "\\" join

extra/io/windows/nt/nt-tests.factor

@@ -5,12 +5,12 @@ IN: temporary
 [ "c:\\" ] [ "c:\\foo\\" parent-directory ] unit-test
 [ "c:\\" ] [ "c:\\foo" parent-directory ] unit-test
 ! { "c:" "c:\\" "c:/" } [ directory ] each -- all do the same thing
-[ "c:\\" ] [ "c:\\" parent-directory ] unit-test
+[ "c:" ] [ "c:\\" parent-directory ] unit-test
-[ "Z:\\" ] [ "Z:\\" parent-directory ] unit-test
+[ "Z:" ] [ "Z:\\" parent-directory ] unit-test
 [ "c:" ] [ "c:" parent-directory ] unit-test
 [ "Z:" ] [ "Z:" parent-directory ] unit-test
-[ t ] [ "c:\\" root-directory? ] unit-test
+[ t ] [ "c:\\" trim-path-separators root-directory? ] unit-test
-[ t ] [ "Z:\\" root-directory? ] unit-test
+[ t ] [ "Z:\\" trim-path-separators root-directory? ] unit-test
 [ f ] [ "c:\\foo" root-directory? ] unit-test
 [ f ] [ "." root-directory? ] unit-test
 [ f ] [ ".." root-directory? ] unit-test

extra/io/windows/windows.factor

@@ -15,15 +15,6 @@ M: windows-io (handle-destructor) ( obj -- )
 M: windows-io (socket-destructor) ( obj -- )
     destructor-obj closesocket drop ;
 
-M: windows-io root-directory? ( path -- ? )
-    [ path-separator? ] right-trim
-    dup length 2 = [
-        dup first Letter?
-        swap second CHAR: : = and
-    ] [
-        drop f
-    ] if ;
-
 TUPLE: win32-file handle ptr overlapped ;
 
 : <win32-file>  ( handle ptr -- obj )