steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Slava Pestov 2008-02-05 13:11:36 -06:00
parent 751a1da3d2
commit ba1a958a32
18 changed files with 93 additions and 93 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
core/bootstrap/primitives.factor
View File

@ -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" }

6
core/bootstrap/stage2.factor
View File

@ -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

4
core/io/files/files-docs.factor
View File

@ -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." } ;

6
core/io/files/files.factor
View File

@ -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 )

9
extra/io/unix/files/files.factor
View File

@ -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 )

37
extra/io/windows/nt/backend/backend.factor
View File

@ -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 ;

62
extra/io/windows/nt/files/files.factor
View File

@ -1,8 +1,64 @@
USING: continuations destructors io.buffers io.nonblocking
io.windows io.windows.nt.backend kernel libc math threads
windows windows.kernel32 ;
USING: continuations destructors io.buffers io.files io.backend
io.nonblocking io.windows io.windows.nt.backend kernel libc math
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 ;

6
extra/io/windows/nt/nt-tests.factor
View File

@ -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

2
extra/unix/bsd/bsd.factor Normal file → Executable file
View File

@ -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

2
extra/unix/linux/linux.factor Normal file → Executable file
View File

@ -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

1
extra/unix/unix.factor
View File

@ -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 ;

6
extra/windows/kernel32/kernel32.factor
View File

@ -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

2
vm/io.h Normal file → Executable file
View File

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

13
vm/os-unix.c
View File

@ -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);

10
vm/os-windows-ce.c
View File

@ -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 */

15
vm/os-windows-nt.c
View File

@ -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);

1
vm/os-windows.h
View File

@ -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);

2
vm/primitives.c
View File

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