Move cd and cwd primitives to native I/O, fix Windows normalize-pathname

core/bootstrap/primitives.factor

@@ -553,8 +553,6 @@ builtins get num-tags get tail f union-class define-class
     { "millis" "system" }
     { "type" "kernel.private" }
     { "tag" "kernel.private" }
-    { "cwd" "io.files" }
-    { "cd" "io.files" }
     { "modify-code-heap" "compiler.units" }
     { "dlopen" "alien" }
     { "dlsym" "alien" }

core/bootstrap/stage2.factor

@@ -1,11 +1,11 @@
-! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: init command-line namespaces words debugger io
 kernel.private math memory continuations kernel io.files
 io.backend system parser vocabs sequences prettyprint
 vocabs.loader combinators splitting source-files strings
 definitions assocs compiler.errors compiler.units
-math.parser ;
+math.parser generic ;
 IN: bootstrap.stage2
 
 ! Wrap everything in a catch which starts a listener so
@@ -88,5 +88,5 @@ IN: bootstrap.stage2
         "output-image" get resource-path save-image-and-exit
     ] if
 ] [
-    print-error :c "listener" vocab-main execute
+    print-error :c "listener" vocab-main execute 1 exit
 ] recover

core/io/files/files-docs.factor

@@ -52,12 +52,12 @@ HELP: <file-appender>
 { $description "Outputs an output stream for writing to the specified pathname. The stream begins writing at the end of the file." }
 { $errors "Throws an error if the file cannot be opened for writing." } ;
 
-HELP: cwd ( -- path )
+HELP: cwd
 { $values { "path" "a pathname string" } }
 { $description "Outputs the current working directory of the Factor process." }
 { $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ;
 
-HELP: cd ( path -- )
+HELP: cd
 { $values { "path" "a pathname string" } }
 { $description "Changes the current working directory of the Factor process." }
 { $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ;

core/io/files/files.factor

@@ -1,10 +1,14 @@
-! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: io.files
 USING: io.backend io.files.private io hashtables kernel math
 memory namespaces sequences strings assocs arrays definitions
 system combinators splitting sbufs ;
 
+HOOK: cd io-backend ( path -- )
+
+HOOK: cwd io-backend ( -- path )
+
 HOOK: <file-reader> io-backend ( path -- stream )
 
 HOOK: <file-writer> io-backend ( path -- stream )

extra/io/unix/files/files.factor

@@ -1,9 +1,16 @@
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: io.backend io.nonblocking io.unix.backend io.files io
 unix kernel math continuations math.bitfields ;
 IN: io.unix.files
 
+M: unix-io cwd
+    MAXPATHLEN dup <byte-array> getcwd
+    [ alien>char-string ] [ (io-error) ] if* ;
+
+M: unix-io cd
+    chdir io-error ;
+
 : read-flags O_RDONLY ; inline
 
 : open-read ( path -- fd )

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

@@ -2,45 +2,10 @@ USING: alien alien.c-types arrays assocs combinators
 continuations destructors io io.backend io.nonblocking
 io.windows libc kernel math namespaces sequences
 threads tuples.lib windows windows.errors windows.kernel32
-strings splitting io.files qualified ascii ;
+strings splitting io.files qualified ascii combinators.lib ;
 QUALIFIED: windows.winsock
 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
-    {
-        ! empty
-        { [ dup empty? ] [ "empty path" throw ] }
-        ! .\\foo
-        { [ dup ".\\" head? ] [
-            >r unicode-prefix cwd r> 1 tail 3append
-        ] }
-        ! c:\\foo
-        { [ dup 1 tail ":" head? ] [ >r unicode-prefix r> append ] }
-        ! \\\\?\\c:\\foo
-        { [ dup unicode-prefix head? ] [ ] }
-        ! foo.txt ..\\foo.txt
-        { [ t ] [
-            [
-                unicode-prefix % cwd %
-                dup first CHAR: \\ = [ CHAR: \\ , ] unless %
-            ] "" make
-        ] }
-    } cond [ "/\\." member? ] right-trim
-    dup peek CHAR: : = [ "\\" append ] when ;
-
 SYMBOL: io-hash
 
 TUPLE: io-callback port continuation ;

extra/io/windows/nt/files/files.factor

@@ -1,8 +1,64 @@
-USING: continuations destructors io.buffers io.nonblocking
+USING: continuations destructors io.buffers io.files io.backend
-io.windows io.windows.nt.backend kernel libc math threads
+io.nonblocking io.windows io.windows.nt.backend kernel libc math
-windows windows.kernel32 ;
+threads windows windows.kernel32 alien.c-types alien.arrays
+sequences combinators combinators.lib ascii splitting alien
+strings ;
 IN: io.windows.nt.files
 
+M: windows-nt-io cwd
+    MAX_UNICODE_PATH dup "ushort" <c-array>
+    [ GetCurrentDirectory win32-error=0/f ] keep
+    alien>u16-string ;
+
+M: windows-nt-io cd
+    SetCurrentDirectory win32-error=0/f ;
+
+: unicode-prefix ( -- seq )
+    "\\\\?\\" ; inline
+
+M: windows-nt-io root-directory? ( path -- ? )
+    dup length 2 = [
+        dup first Letter?
+        swap second CHAR: : = and
+    ] [
+        drop f
+    ] if ;
+
+: root-directory ( string -- string' )
+    {
+        [ dup length 2 >= ]
+        [ dup second CHAR: : = ]
+        [ dup first Letter? ]
+    } && [ 2 head ] [ "Not an absolute path" throw ] if ;
+
+: prepend-prefix ( string -- string' )
+    unicode-prefix swap append ;
+
+: windows-path+ ( cwd path -- newpath )
+    {
+        ! empty
+        { [ dup empty? ] [ "empty path" throw ] }
+        ! \\\\?\\c:\\foo
+        { [ dup unicode-prefix head? ] [ nip ] }
+        ! ..\\foo
+        { [ dup "..\\" head? ] [ >r parent-directory r> 2 tail windows-path+ ] }
+        ! .\\foo
+        { [ dup ".\\" head? ] [ 1 tail append prepend-prefix ] }
+        ! \\foo
+        { [ dup "\\" head? ] [ >r root-directory r> append prepend-prefix ] }
+        ! c:\\foo
+        { [ dup second CHAR: : = ] [ nip prepend-prefix ] }
+        ! foo.txt
+        { [ t ] [ [ first CHAR: \\ = "" "\\" ? ] keep 3append prepend-prefix ] }
+    } cond ;
+
+M: windows-nt-io normalize-pathname ( string -- string )
+    dup string? [ "pathname must be a string" throw ] unless
+    "/" split "\\" join
+    cwd swap windows-path+
+    [ "/\\." member? ] right-trim
+    dup peek CHAR: : = [ "\\" append ] when ;
+
 M: windows-nt-io CreateFile-flags ( DWORD -- DWORD )
     FILE_FLAG_OVERLAPPED bitor ;
 

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

@@ -1,4 +1,4 @@
-USING: io.files kernel tools.test ;
+USING: io.files kernel tools.test io.backend splitting ;
 IN: temporary
 
 [ "c:\\foo\\" ] [ "c:\\foo\\bar" parent-directory ] unit-test
@@ -14,3 +14,7 @@ IN: temporary
 [ f ] [ "c:\\foo" root-directory? ] unit-test
 [ f ] [ "." root-directory? ] unit-test
 [ f ] [ ".." root-directory? ] unit-test
+
+[ ] [ "" resource-path cd ] unit-test
+
+[ "\\foo\\bar" ] [ "/foo/bar" normalize-pathname ":" split1 nip ] unit-test

extra/unix/bsd/bsd.factor

@@ -5,6 +5,8 @@ USING: alien.syntax ;
 
 ! FreeBSD
 
+: MAXPATHLEN 1024 ; inline
+
 : O_RDONLY  HEX: 0000 ; inline
 : O_WRONLY  HEX: 0001 ; inline
 : O_RDWR    HEX: 0002 ; inline

extra/unix/linux/linux.factor

@@ -5,6 +5,8 @@ USING: alien.syntax ;
 
 ! Linux.
 
+: MAXPATHLEN 1024 ; inline
+
 : O_RDONLY  HEX: 0000 ; inline
 : O_WRONLY  HEX: 0001 ; inline
 : O_RDWR    HEX: 0002 ; inline

extra/unix/unix.factor

@@ -124,6 +124,7 @@ FUNCTION: void freeaddrinfo ( addrinfo* ai ) ;
 FUNCTION: int futimes ( int id, timeval[2] times ) ;
 FUNCTION: char* gai_strerror ( int ecode ) ;
 FUNCTION: int getaddrinfo ( char* hostname, char* servname, addrinfo* hints, addrinfo** res ) ;
+FUNCTION: char* getcwd ( char* buf, size_t size ) ;
 FUNCTION: int getdtablesize ;
 FUNCTION: gid_t getegid ;
 FUNCTION: uid_t geteuid ;

extra/windows/kernel32/kernel32.factor

@@ -892,7 +892,8 @@ FUNCTION: DWORD GetConsoleTitleW ( LPWSTR lpConsoleTitle, DWORD nSize ) ;
 ! FUNCTION: GetCurrentActCtx
 ! FUNCTION: GetCurrentConsoleFont
 ! FUNCTION: GetCurrentDirectoryA
-! FUNCTION: GetCurrentDirectoryW
+FUNCTION: BOOL GetCurrentDirectoryW ( DWORD len, LPTSTR buf ) ;
+: GetCurrentDirectory GetCurrentDirectoryW ; inline
 FUNCTION: HANDLE GetCurrentProcess ( ) ;
 ! FUNCTION: GetCurrentProcessId
 FUNCTION: HANDLE GetCurrentThread ( ) ;
@@ -1387,7 +1388,8 @@ FUNCTION: BOOL SetConsoleTitleW ( LPCWSTR lpConsoleTitle ) ;
 ! FUNCTION: SetCPGlobal
 ! FUNCTION: SetCriticalSectionSpinCount
 ! FUNCTION: SetCurrentDirectoryA
-! FUNCTION: SetCurrentDirectoryW
+FUNCTION: BOOL SetCurrentDirectoryW ( LPCWSTR lpDirectory ) ;
+: SetCurrentDirectory SetCurrentDirectoryW ; inline
 ! FUNCTION: SetDefaultCommConfigA
 ! FUNCTION: SetDefaultCommConfigW
 ! FUNCTION: SetDllDirectoryA

vm/io.h

@@ -13,5 +13,3 @@ DECLARE_PRIMITIVE(fread);
 DECLARE_PRIMITIVE(open_file);
 DECLARE_PRIMITIVE(stat);
 DECLARE_PRIMITIVE(read_dir);
-DECLARE_PRIMITIVE(cwd);
-DECLARE_PRIMITIVE(cd);

vm/os-unix.c

@@ -115,19 +115,6 @@ DEFINE_PRIMITIVE(read_dir)
 	dpush(result);
 }
 
-DEFINE_PRIMITIVE(cwd)
-{
-	char wd[MAXPATHLEN];
-	if(getcwd(wd,MAXPATHLEN) == NULL)
-		io_error();
-	box_char_string(wd);
-}
-
-DEFINE_PRIMITIVE(cd)
-{
-	chdir(unbox_char_string());
-}
-
 DEFINE_PRIMITIVE(os_envs)
 {
 	GROWABLE_ARRAY(result);

vm/os-windows-ce.c

@@ -10,16 +10,6 @@ s64 current_millis(void)
 		| (s64)ft.dwHighDateTime<<32) - EPOCH_OFFSET) / 10000;
 }
 
-DEFINE_PRIMITIVE(cwd)
-{
-	not_implemented_error();
-}
-
-DEFINE_PRIMITIVE(cd)
-{
-	not_implemented_error();
-}
-
 char *strerror(int err)
 {
 	/* strerror() is not defined on WinCE */

vm/os-windows-nt.c

@@ -8,21 +8,6 @@ s64 current_millis(void)
 		- EPOCH_OFFSET) / 10000;
 }
 
-DEFINE_PRIMITIVE(cwd)
-{
-	F_CHAR buf[MAX_UNICODE_PATH];
-
-	if(!GetCurrentDirectory(MAX_UNICODE_PATH, buf))
-		io_error();
-
-	box_u16_string(buf);
-}
-
-DEFINE_PRIMITIVE(cd)
-{
-	SetCurrentDirectory(unbox_u16_string());
-}
-
 DEFINE_PRIMITIVE(os_envs)
 {
 	GROWABLE_ARRAY(result);

vm/os-windows.h

@@ -30,6 +30,7 @@ typedef wchar_t F_CHAR;
 
 F_STRING *get_error_message(void);
 DLLEXPORT F_CHAR *error_message(DWORD id);
+void windows_error(void);
 
 void init_ffi(void);
 void ffi_dlopen(F_DLL *dll, bool error);

vm/primitives.c

@@ -109,8 +109,6 @@ void *primitives[] = {
 	primitive_millis,
 	primitive_type,
 	primitive_tag,
-	primitive_cwd,
-	primitive_cd,
 	primitive_modify_code_heap,
 	primitive_dlopen,
 	primitive_dlsym,