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

io backend now uses OS singletons

db4
Doug Coleman 2008-04-02 20:09:56 -05:00
parent 72c06fc028
commit c53e75ef0f
25 changed files with 123 additions and 151 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
extra/io/unix/backend/backend.factor
View File

@ -8,8 +8,6 @@ qualified namespaces io.timeouts io.encodings.utf8 accessors ;
QUALIFIED: io QUALIFIED: io
IN: io.unix.backend IN: io.unix.backend
MIXIN: unix-io
! I/O tasks ! I/O tasks
TUPLE: io-task port callbacks ; TUPLE: io-task port callbacks ;
@ -120,7 +118,7 @@ M: integer close-handle ( fd -- )
[ dup reads>> handle-timeout ] [ dup reads>> handle-timeout ]
[ dup writes>> handle-timeout ] 2bi ; [ dup writes>> handle-timeout ] 2bi ;
M: unix-io cancel-io ( port -- ) M: unix cancel-io ( port -- )
mx get-global cancel-io-tasks ; mx get-global cancel-io-tasks ;
! Readers ! Readers
@ -180,10 +178,10 @@ M: write-task do-io-task
M: port port-flush ( port -- ) M: port port-flush ( port -- )
dup buffer-empty? [ drop ] [ (wait-to-write) ] if ; dup buffer-empty? [ drop ] [ (wait-to-write) ] if ;
M: unix-io io-multiplex ( ms/f -- ) M: unix io-multiplex ( ms/f -- )
mx get-global wait-for-events ; mx get-global wait-for-events ;
M: unix-io (init-stdio) ( -- ) M: unix (init-stdio) ( -- )
0 <reader> 0 <reader>
1 <writer> 1 <writer>
2 <writer> ; 2 <writer> ;

10
extra/io/unix/bsd/bsd.factor
View File

@ -3,7 +3,7 @@
IN: io.unix.bsd IN: io.unix.bsd
USING: io.backend io.unix.backend io.unix.kqueue io.unix.select USING: io.backend io.unix.backend io.unix.kqueue io.unix.select
io.launcher io.unix.launcher namespaces kernel assocs io.launcher io.unix.launcher namespaces kernel assocs
threads continuations ; threads continuations system ;
! On Mac OS X, we use select() for the top-level ! On Mac OS X, we use select() for the top-level
! multiplexer, and we hang a kqueue off of it for process exit ! multiplexer, and we hang a kqueue off of it for process exit
@ -12,16 +12,12 @@ threads continuations ;
! kqueue is buggy with files and ptys so we can't use it as the ! kqueue is buggy with files and ptys so we can't use it as the
! main multiplexer. ! main multiplexer.
MIXIN: bsd-io M: bsd init-io ( -- )
INSTANCE: bsd-io unix-io
M: bsd-io init-io ( -- )
<select-mx> mx set-global <select-mx> mx set-global
<kqueue-mx> kqueue-mx set-global <kqueue-mx> kqueue-mx set-global
kqueue-mx get-global <mx-port> <mx-task> dup io-task-fd kqueue-mx get-global <mx-port> <mx-task> dup io-task-fd
2dup mx get-global mx-reads set-at 2dup mx get-global mx-reads set-at
mx get-global mx-writes set-at ; mx get-global mx-writes set-at ;
M: bsd-io register-process ( process -- ) M: bsd register-process ( process -- )
process-handle kqueue-mx get-global add-pid-task ; process-handle kqueue-mx get-global add-pid-task ;

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

@ -3,15 +3,15 @@
USING: io.backend io.nonblocking io.unix.backend io.files io USING: io.backend io.nonblocking io.unix.backend io.files io
unix unix.stat unix.time kernel math continuations unix unix.stat unix.time kernel math continuations
math.bitfields byte-arrays alien combinators calendar math.bitfields byte-arrays alien combinators calendar
io.encodings.binary accessors sequences strings ; io.encodings.binary accessors sequences strings system ;
IN: io.unix.files IN: io.unix.files
M: unix-io cwd ( -- path ) M: unix cwd ( -- path )
MAXPATHLEN [ <byte-array> ] [ ] bi getcwd MAXPATHLEN [ <byte-array> ] [ ] bi getcwd
[ (io-error) ] unless* ; [ (io-error) ] unless* ;
M: unix-io cd ( path -- ) M: unix cd ( path -- )
chdir io-error ; chdir io-error ;
: read-flags O_RDONLY ; inline : read-flags O_RDONLY ; inline
@ -19,7 +19,7 @@ M: unix-io cd ( path -- )
: open-read ( path -- fd ) : open-read ( path -- fd )
O_RDONLY file-mode open dup io-error ; O_RDONLY file-mode open dup io-error ;
M: unix-io (file-reader) ( path -- stream ) M: unix (file-reader) ( path -- stream )
open-read <reader> ; open-read <reader> ;
: write-flags { O_WRONLY O_CREAT O_TRUNC } flags ; inline : write-flags { O_WRONLY O_CREAT O_TRUNC } flags ; inline
@ -27,7 +27,7 @@ M: unix-io (file-reader) ( path -- stream )
: open-write ( path -- fd ) : open-write ( path -- fd )
write-flags file-mode open dup io-error ; write-flags file-mode open dup io-error ;
M: unix-io (file-writer) ( path -- stream ) M: unix (file-writer) ( path -- stream )
open-write <writer> ; open-write <writer> ;
: append-flags { O_WRONLY O_APPEND O_CREAT } flags ; inline : append-flags { O_WRONLY O_APPEND O_CREAT } flags ; inline
@ -36,28 +36,28 @@ M: unix-io (file-writer) ( path -- stream )
append-flags file-mode open dup io-error append-flags file-mode open dup io-error
[ dup 0 SEEK_END lseek io-error ] [ ] [ close ] cleanup ; [ dup 0 SEEK_END lseek io-error ] [ ] [ close ] cleanup ;
M: unix-io (file-appender) ( path -- stream ) M: unix (file-appender) ( path -- stream )
open-append <writer> ; open-append <writer> ;
: touch-mode ( -- n ) : touch-mode ( -- n )
{ O_WRONLY O_APPEND O_CREAT O_EXCL } flags ; foldable { O_WRONLY O_APPEND O_CREAT O_EXCL } flags ; foldable
M: unix-io touch-file ( path -- ) M: unix touch-file ( path -- )
normalize-path normalize-path
touch-mode file-mode open touch-mode file-mode open
dup 0 < [ err_no EEXIST = [ err_no io-error ] unless ] when dup 0 < [ err_no EEXIST = [ err_no io-error ] unless ] when
close ; close ;
M: unix-io move-file ( from to -- ) M: unix move-file ( from to -- )
[ normalize-path ] bi@ rename io-error ; [ normalize-path ] bi@ rename io-error ;
M: unix-io delete-file ( path -- ) M: unix delete-file ( path -- )
normalize-path unlink io-error ; normalize-path unlink io-error ;
M: unix-io make-directory ( path -- ) M: unix make-directory ( path -- )
normalize-path OCT: 777 mkdir io-error ; normalize-path OCT: 777 mkdir io-error ;
M: unix-io delete-directory ( path -- ) M: unix delete-directory ( path -- )
normalize-path rmdir io-error ; normalize-path rmdir io-error ;
: (copy-file) ( from to -- ) : (copy-file) ( from to -- )
@ -68,7 +68,7 @@ M: unix-io delete-directory ( path -- )
] with-disposal ] with-disposal
] with-disposal ; ] with-disposal ;
M: unix-io copy-file ( from to -- ) M: unix copy-file ( from to -- )
[ normalize-path ] bi@ [ normalize-path ] bi@
[ (copy-file) ] [ (copy-file) ]
[ swap file-info file-info-permissions chmod io-error ] [ swap file-info file-info-permissions chmod io-error ]
@ -95,16 +95,16 @@ M: unix-io copy-file ( from to -- )
} cleave } cleave
\ file-info construct-boa ; \ file-info construct-boa ;
M: unix-io file-info ( path -- info ) M: unix file-info ( path -- info )
normalize-path stat* stat>file-info ; normalize-path stat* stat>file-info ;
M: unix-io link-info ( path -- info ) M: unix link-info ( path -- info )
normalize-path lstat* stat>file-info ; normalize-path lstat* stat>file-info ;
M: unix-io make-link ( path1 path2 -- ) M: unix make-link ( path1 path2 -- )
normalize-path symlink io-error ; normalize-path symlink io-error ;
M: unix-io read-link ( path -- path' ) M: unix read-link ( path -- path' )
normalize-path normalize-path
PATH_MAX [ <byte-array> tuck ] [ ] bi readlink PATH_MAX [ <byte-array> tuck ] [ ] bi readlink
dup io-error head-slice >string ; dup io-error head-slice >string ;

6
extra/io/unix/files/unique/unique.factor
View File

@ -1,11 +1,11 @@
USING: kernel io.nonblocking io.unix.backend math.bitfields USING: kernel io.nonblocking io.unix.backend math.bitfields
unix io.files.unique.backend ; unix io.files.unique.backend system ;
IN: io.unix.files.unique IN: io.unix.files.unique
: open-unique-flags ( -- flags ) : open-unique-flags ( -- flags )
{ O_RDWR O_CREAT O_EXCL } flags ; { O_RDWR O_CREAT O_EXCL } flags ;
M: unix-io (make-unique-file) ( path -- ) M: unix (make-unique-file) ( path -- )
open-unique-flags file-mode open dup io-error close ; open-unique-flags file-mode open dup io-error close ;
M: unix-io temporary-path ( -- path ) "/tmp" ; M: unix temporary-path ( -- path ) "/tmp" ;

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

@ -1,8 +1,3 @@
IN: io.unix.freebsd USING: io.unix.bsd io.backend system ;
USING: io.unix.bsd io.backend ;
TUPLE: freebsd-io ; freebsd set-io-backend
INSTANCE: freebsd-io bsd-io
T{ freebsd-io } set-io-backend

8
extra/io/unix/launcher/launcher.factor
View File

@ -79,12 +79,12 @@ USE: unix
(io-error) (io-error)
] [ 255 exit ] recover ; ] [ 255 exit ] recover ;
M: unix-io current-process-handle ( -- handle ) getpid ; M: unix current-process-handle ( -- handle ) getpid ;
M: unix-io run-process* ( process -- pid ) M: unix run-process* ( process -- pid )
[ spawn-process ] curry [ ] with-fork ; [ spawn-process ] curry [ ] with-fork ;
M: unix-io kill-process* ( pid -- ) M: unix kill-process* ( pid -- )
SIGTERM kill io-error ; SIGTERM kill io-error ;
: open-pipe ( -- pair ) : open-pipe ( -- pair )
@ -95,7 +95,7 @@ M: unix-io kill-process* ( pid -- )
2dup first close second close 2dup first close second close
>r first 0 dup2 drop r> second 1 dup2 drop ; >r first 0 dup2 drop r> second 1 dup2 drop ;
M: unix-io (process-stream) M: unix (process-stream)
>r open-pipe open-pipe r> >r open-pipe open-pipe r>
[ >r setup-stdio-pipe r> spawn-process ] curry [ >r setup-stdio-pipe r> spawn-process ] curry
[ -rot 2dup second close first close ] [ -rot 2dup second close first close ]

10
extra/io/unix/linux/linux.factor
View File

@ -7,10 +7,6 @@ namespaces threads continuations init math alien.c-types alien
vocabs.loader accessors ; vocabs.loader accessors ;
IN: io.unix.linux IN: io.unix.linux
TUPLE: linux-io ;
INSTANCE: linux-io unix-io
TUPLE: linux-monitor ; TUPLE: linux-monitor ;
: <linux-monitor> ( wd -- monitor ) : <linux-monitor> ( wd -- monitor )
@ -50,7 +46,7 @@ TUPLE: inotify watches ;
"inotify is not supported by this Linux release" throw "inotify is not supported by this Linux release" throw
] unless ; ] unless ;
M: linux-io <monitor> ( path recursive? -- monitor ) M: linux <monitor> ( path recursive? -- monitor )
check-inotify check-inotify
drop IN_CHANGE_EVENTS add-watch ; drop IN_CHANGE_EVENTS add-watch ;
@ -116,11 +112,11 @@ TUPLE: inotify-task ;
M: inotify-task do-io-task ( task -- ) M: inotify-task do-io-task ( task -- )
io-task-port read-notifications f ; io-task-port read-notifications f ;
M: linux-io init-io ( -- ) M: linux init-io ( -- )
<select-mx> <select-mx>
[ mx set-global ] [ mx set-global ]
[ [ init-inotify ] curry ignore-errors ] bi ; [ [ init-inotify ] curry ignore-errors ] bi ;
T{ linux-io } set-io-backend linux set-io-backend
[ start-wait-thread ] "io.unix.linux" add-init-hook [ start-wait-thread ] "io.unix.linux" add-init-hook

12
extra/io/unix/macosx/macosx.factor
View File

@ -1,13 +1,9 @@
IN: io.unix.macosx
USING: io.unix.bsd io.backend io.monitors io.monitors.private USING: io.unix.bsd io.backend io.monitors io.monitors.private
continuations kernel core-foundation.fsevents sequences continuations kernel core-foundation.fsevents sequences
namespaces arrays ; namespaces arrays system ;
IN: io.unix.macosx
TUPLE: macosx-io ; macosx set-io-backend
INSTANCE: macosx-io bsd-io
T{ macosx-io } set-io-backend
TUPLE: macosx-monitor ; TUPLE: macosx-monitor ;
@ -16,7 +12,7 @@ TUPLE: macosx-monitor ;
[ [ first { +modify-file+ } swap changed-file ] each ] bind [ [ first { +modify-file+ } swap changed-file ] each ] bind
notify-callback ; notify-callback ;
M: macosx-io <monitor> M: macosx <monitor>
drop drop
f macosx-monitor construct-simple-monitor f macosx-monitor construct-simple-monitor
dup [ enqueue-notifications ] curry dup [ enqueue-notifications ] curry

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

@ -1,8 +1,3 @@
IN: io.unix.netbsd USING: io.backend system ;
USING: io.unix.bsd io.backend ;
TUPLE: netbsd-io ; netbsd set-io-backend
INSTANCE: netbsd-io bsd-io
T{ netbsd-io } set-io-backend

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

@ -1,8 +1,3 @@
IN: io.unix.openbsd USING: io.unix.bsd io.backend core-foundation.fsevents system ;
USING: io.unix.bsd io.backend core-foundation.fsevents ;
TUPLE: openbsd-io ; openbsd set-io-backend
INSTANCE: openbsd-io bsd-io
T{ openbsd-io } set-io-backend

8
extra/io/windows/ce/backend/backend.factor
View File

@ -7,10 +7,10 @@ IN: io.windows.ce.backend
: port-errored ( port -- ) : port-errored ( port -- )
win32-error-string swap set-port-error ; win32-error-string swap set-port-error ;
M: windows-ce-io io-multiplex ( ms -- ) M: wince io-multiplex ( ms -- )
60 60 * 1000 * or (sleep) ; 60 60 * 1000 * or (sleep) ;
M: windows-ce-io add-completion ( handle -- ) drop ; M: wince add-completion ( handle -- ) drop ;
GENERIC: wince-read ( port port-handle -- ) GENERIC: wince-read ( port port-handle -- )
@ -26,14 +26,14 @@ M: port port-flush
dup dup port-handle wince-write port-flush dup dup port-handle wince-write port-flush
] if ; ] if ;
M: windows-ce-io init-io ( -- ) M: wince init-io ( -- )
init-winsock ; init-winsock ;
LIBRARY: libc LIBRARY: libc
FUNCTION: void* _getstdfilex int fd ; FUNCTION: void* _getstdfilex int fd ;
FUNCTION: void* _fileno void* file ; FUNCTION: void* _fileno void* file ;
M: windows-ce-io (init-stdio) ( -- ) M: wince (init-stdio) ( -- )
#! We support Windows NT too, to make this I/O backend #! We support Windows NT too, to make this I/O backend
#! easier to debug. #! easier to debug.
512 default-buffer-size [ 512 default-buffer-size [

16
extra/io/windows/ce/ce.factor
View File

@ -1,7 +1,11 @@
USING: io.backend io.windows io.windows.ce.backend USE: io.backend
io.windows.ce.files io.windows.ce.sockets io.windows.ce.launcher USE: io.windows
namespaces io.windows.mmap ; USE: io.windows.ce.backend
IN: io.windows.ce USE: io.windows.ce.files
USE: io.windows.ce.sockets
USE: io.windows.ce.launcher
USE: io.windows.mmap system
USE: io.windows.files USE: io.windows.files
T{ windows-ce-io } set-io-backend USE: system
wince set-io-backend

8
extra/io/windows/ce/files/files.factor
View File

@ -1,15 +1,15 @@
USING: alien alien.c-types combinators io io.backend io.buffers USING: alien alien.c-types combinators io io.backend io.buffers
io.files io.nonblocking io.windows kernel libc math namespaces io.files io.nonblocking io.windows kernel libc math namespaces
prettyprint sequences strings threads threads.private prettyprint sequences strings threads threads.private
windows windows.kernel32 io.windows.ce.backend ; windows windows.kernel32 io.windows.ce.backend system ;
IN: windows.ce.files IN: windows.ce.files
! M: windows-ce-io normalize-path ( string -- string ) ! M: wince normalize-path ( string -- string )
! dup 1 tail* CHAR: \\ = [ "*" append ] [ "\\*" append ] if ; ! dup 1 tail* CHAR: \\ = [ "*" append ] [ "\\*" append ] if ;
M: windows-ce-io CreateFile-flags ( DWORD -- DWORD ) M: wince CreateFile-flags ( DWORD -- DWORD )
FILE_ATTRIBUTE_NORMAL bitor ; FILE_ATTRIBUTE_NORMAL bitor ;
M: windows-ce-io FileArgs-overlapped ( port -- f ) drop f ; M: wince FileArgs-overlapped ( port -- f ) drop f ;
: finish-read ( port status bytes-ret -- ) : finish-read ( port status bytes-ret -- )
swap [ drop port-errored ] [ swap n>buffer ] if ; swap [ drop port-errored ] [ swap n>buffer ] if ;

16
extra/io/windows/ce/sockets/sockets.factor
View File

@ -2,11 +2,11 @@ USING: alien alien.c-types combinators io io.backend io.buffers
io.nonblocking io.sockets io.sockets.impl io.windows kernel libc io.nonblocking io.sockets io.sockets.impl io.windows kernel libc
math namespaces prettyprint qualified sequences strings threads math namespaces prettyprint qualified sequences strings threads
threads.private windows windows.kernel32 io.windows.ce.backend threads.private windows windows.kernel32 io.windows.ce.backend
byte-arrays ; byte-arrays system ;
QUALIFIED: windows.winsock QUALIFIED: windows.winsock
IN: io.windows.ce IN: io.windows.ce
M: windows-ce-io WSASocket-flags ( -- DWORD ) 0 ; M: wince WSASocket-flags ( -- DWORD ) 0 ;
M: win32-socket wince-read ( port port-handle -- ) M: win32-socket wince-read ( port port-handle -- )
win32-file-handle over buffer-end pick buffer-capacity 0 win32-file-handle over buffer-end pick buffer-capacity 0
@ -31,15 +31,15 @@ M: win32-socket wince-write ( port port-handle -- )
windows.winsock:WSAConnect windows.winsock:WSAConnect
windows.winsock:winsock-error!=0/f ; windows.winsock:winsock-error!=0/f ;
M: windows-ce-io (client) ( addrspec -- reader writer ) M: wince (client) ( addrspec -- reader writer )
do-connect <win32-socket> dup <reader&writer> ; do-connect <win32-socket> dup <reader&writer> ;
M: windows-ce-io (server) ( addrspec -- handle ) M: wince (server) ( addrspec -- handle )
windows.winsock:SOCK_STREAM server-fd windows.winsock:SOCK_STREAM server-fd
dup listen-on-socket dup listen-on-socket
<win32-socket> ; <win32-socket> ;
M: windows-ce-io (accept) ( server -- client ) M: wince (accept) ( server -- client )
[ [
dup check-server-port dup check-server-port
[ [
@ -55,7 +55,7 @@ M: windows-ce-io (accept) ( server -- client )
<win32-socket> <reader&writer> <win32-socket> <reader&writer>
] with-timeout ; ] with-timeout ;
M: windows-ce-io <datagram> ( addrspec -- datagram ) M: wince <datagram> ( addrspec -- datagram )
[ [
windows.winsock:SOCK_DGRAM server-fd <win32-socket> windows.winsock:SOCK_DGRAM server-fd <win32-socket>
] keep <datagram-port> ; ] keep <datagram-port> ;
@ -81,7 +81,7 @@ M: windows-ce-io <datagram> ( addrspec -- datagram )
packet-size <byte-array> receive-buffer set-global packet-size <byte-array> receive-buffer set-global
M: windows-ce-io receive ( datagram -- packet addrspec ) M: wince receive ( datagram -- packet addrspec )
dup check-datagram-port dup check-datagram-port
[ [
port-handle win32-file-handle port-handle win32-file-handle
@ -104,7 +104,7 @@ M: windows-ce-io receive ( datagram -- packet addrspec )
dup length receive-buffer rot pick memcpy dup length receive-buffer rot pick memcpy
receive-buffer make-WSABUF ; receive-buffer make-WSABUF ;
M: windows-ce-io send ( packet addrspec datagram -- ) M: wince send ( packet addrspec datagram -- )
3dup check-datagram-send 3dup check-datagram-send
port-handle win32-file-handle port-handle win32-file-handle
rot send-WSABUF rot send-WSABUF

8
extra/io/windows/files/files.factor
View File

@ -3,7 +3,7 @@
USING: alien.c-types io.backend io.files io.windows kernel math USING: alien.c-types io.backend io.files io.windows kernel math
windows windows.kernel32 windows.time calendar combinators windows windows.kernel32 windows.time calendar combinators
math.functions sequences namespaces words symbols math.functions sequences namespaces words symbols
combinators.lib io.nonblocking destructors ; combinators.lib io.nonblocking destructors system ;
IN: io.windows.files IN: io.windows.files
SYMBOLS: +read-only+ +hidden+ +system+ SYMBOLS: +read-only+ +hidden+ +system+
@ -88,10 +88,10 @@ SYMBOLS: +read-only+ +hidden+ +system+
get-file-information BY_HANDLE_FILE_INFORMATION>file-info get-file-information BY_HANDLE_FILE_INFORMATION>file-info
] if ; ] if ;
M: windows-nt-io file-info ( path -- info ) M: winnt file-info ( path -- info )
normalize-path get-file-information-stat ; normalize-path get-file-information-stat ;
M: windows-nt-io link-info ( path -- info ) M: winnt link-info ( path -- info )
file-info ; file-info ;
: file-times ( path -- timestamp timestamp timestamp ) : file-times ( path -- timestamp timestamp timestamp )
@ -125,7 +125,7 @@ M: windows-nt-io link-info ( path -- info )
: set-file-write-time ( path timestamp -- ) : set-file-write-time ( path timestamp -- )
>r f f r> set-file-times ; >r f f r> set-file-times ;
M: windows-nt-io touch-file ( path -- ) M: winnt touch-file ( path -- )
[ [
normalize-path normalize-path
maybe-create-file over close-always maybe-create-file over close-always

4
extra/io/windows/files/unique/unique.factor
View File

@ -2,9 +2,9 @@ USING: kernel system io.files.unique.backend
windows.kernel32 io.windows io.nonblocking windows ; windows.kernel32 io.windows io.nonblocking windows ;
IN: io.windows.files.unique IN: io.windows.files.unique
M: windows-io (make-unique-file) ( path -- ) M: windows (make-unique-file) ( path -- )
GENERIC_WRITE CREATE_NEW 0 open-file GENERIC_WRITE CREATE_NEW 0 open-file
CloseHandle win32-error=0/f ; CloseHandle win32-error=0/f ;
M: windows-io temporary-path ( -- path ) M: windows temporary-path ( -- path )
"TEMP" os-env ; "TEMP" os-env ;

10
extra/io/windows/launcher/launcher.factor
View File

@ -101,7 +101,7 @@ TUPLE: CreateProcess-args
HOOK: fill-redirection io-backend ( process args -- ) HOOK: fill-redirection io-backend ( process args -- )
M: windows-ce-io fill-redirection 2drop ; M: wince fill-redirection 2drop ;
: make-CreateProcess-args ( process -- args ) : make-CreateProcess-args ( process -- args )
default-CreateProcess-args default-CreateProcess-args
@ -111,10 +111,10 @@ M: windows-ce-io fill-redirection 2drop ;
fill-startup-info fill-startup-info
nip ; nip ;
M: windows-io current-process-handle ( -- handle ) M: windows current-process-handle ( -- handle )
GetCurrentProcessId ; GetCurrentProcessId ;
M: windows-io run-process* ( process -- handle ) M: windows run-process* ( process -- handle )
[ [
dup make-CreateProcess-args dup make-CreateProcess-args
tuck fill-redirection tuck fill-redirection
@ -122,7 +122,7 @@ M: windows-io run-process* ( process -- handle )
lpProcessInformation>> lpProcessInformation>>
] with-destructors ; ] with-destructors ;
M: windows-io kill-process* ( handle -- ) M: windows kill-process* ( handle -- )
PROCESS_INFORMATION-hProcess PROCESS_INFORMATION-hProcess
255 TerminateProcess win32-error=0/f ; 255 TerminateProcess win32-error=0/f ;
@ -161,7 +161,7 @@ SYMBOL: wait-flag
<flag> wait-flag set-global <flag> wait-flag set-global
[ wait-loop t ] "Process wait" spawn-server drop ; [ wait-loop t ] "Process wait" spawn-server drop ;
M: windows-io register-process M: windows register-process
drop wait-flag get-global raise-flag ; drop wait-flag get-global raise-flag ;
[ start-wait-thread ] "io.windows.launcher" add-init-hook [ start-wait-thread ] "io.windows.launcher" add-init-hook

10
extra/io/windows/mmap/mmap.factor
View File

@ -1,7 +1,7 @@
USING: alien alien.c-types alien.syntax arrays continuations USING: alien alien.c-types alien.syntax arrays continuations
destructors generic io.mmap io.nonblocking io.windows destructors generic io.mmap io.nonblocking io.windows
kernel libc math namespaces quotations sequences windows kernel libc math namespaces quotations sequences windows
windows.advapi32 windows.kernel32 io.backend ; windows.advapi32 windows.kernel32 io.backend system ;
IN: io.windows.mmap IN: io.windows.mmap
TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
@ -53,11 +53,11 @@ TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
HOOK: with-privileges io-backend ( seq quot -- ) inline HOOK: with-privileges io-backend ( seq quot -- ) inline
M: windows-nt-io with-privileges M: winnt with-privileges
over [ [ t set-privilege ] each ] curry compose over [ [ t set-privilege ] each ] curry compose
swap [ [ f set-privilege ] each ] curry [ ] cleanup ; swap [ [ f set-privilege ] each ] curry [ ] cleanup ;
M: windows-ce-io with-privileges M: wince with-privileges
nip call ; nip call ;
: mmap-open ( path access-mode create-mode flProtect access -- handle handle address ) : mmap-open ( path access-mode create-mode flProtect access -- handle handle address )
@ -70,7 +70,7 @@ M: windows-ce-io with-privileges
dup close-later dup close-later
] with-privileges ; ] with-privileges ;
M: windows-io <mapped-file> ( path length -- mmap ) M: windows <mapped-file> ( path length -- mmap )
[ [
swap swap
GENERIC_WRITE GENERIC_READ bitor GENERIC_WRITE GENERIC_READ bitor
@ -81,7 +81,7 @@ M: windows-io <mapped-file> ( path length -- mmap )
f \ mapped-file construct-boa f \ mapped-file construct-boa
] with-destructors ; ] with-destructors ;
M: windows-io close-mapped-file ( mapped-file -- ) M: windows close-mapped-file ( mapped-file -- )
[ [
dup mapped-file-handle [ close-always ] each dup mapped-file-handle [ close-always ] each
mapped-file-address UnmapViewOfFile win32-error=0/f mapped-file-address UnmapViewOfFile win32-error=0/f

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

@ -3,7 +3,7 @@ continuations destructors io io.backend io.nonblocking
io.windows libc kernel math namespaces sequences io.windows libc kernel math namespaces sequences
threads classes.tuple.lib windows windows.errors threads classes.tuple.lib windows windows.errors
windows.kernel32 strings splitting io.files qualified ascii windows.kernel32 strings splitting io.files qualified ascii
combinators.lib ; combinators.lib system ;
QUALIFIED: windows.winsock QUALIFIED: windows.winsock
IN: io.windows.nt.backend IN: io.windows.nt.backend
@ -28,7 +28,7 @@ SYMBOL: master-completion-port
: <master-completion-port> ( -- handle ) : <master-completion-port> ( -- handle )
INVALID_HANDLE_VALUE f <completion-port> ; INVALID_HANDLE_VALUE f <completion-port> ;
M: windows-nt-io add-completion ( handle -- ) M: winnt add-completion ( handle -- )
master-completion-port get-global <completion-port> drop ; master-completion-port get-global <completion-port> drop ;
: eof? ( error -- ? ) : eof? ( error -- ? )
@ -89,13 +89,13 @@ M: windows-nt-io add-completion ( handle -- )
: drain-overlapped ( timeout -- ) : drain-overlapped ( timeout -- )
handle-overlapped [ 0 drain-overlapped ] unless ; handle-overlapped [ 0 drain-overlapped ] unless ;
M: windows-nt-io cancel-io M: winnt cancel-io
port-handle win32-file-handle CancelIo drop ; port-handle win32-file-handle CancelIo drop ;
M: windows-nt-io io-multiplex ( ms -- ) M: winnt io-multiplex ( ms -- )
drain-overlapped ; drain-overlapped ;
M: windows-nt-io init-io ( -- ) M: winnt init-io ( -- )
<master-completion-port> master-completion-port set-global <master-completion-port> master-completion-port set-global
H{ } clone io-hash set-global H{ } clone io-hash set-global
windows.winsock:init-winsock ; windows.winsock:init-winsock ;

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

@ -1,22 +1,22 @@
USING: continuations destructors io.buffers io.files io.backend USING: continuations destructors io.buffers io.files io.backend
io.timeouts io.nonblocking io.windows io.windows.nt.backend io.timeouts io.nonblocking io.windows io.windows.nt.backend
kernel libc math threads windows windows.kernel32 kernel libc math threads windows windows.kernel32 system
alien.c-types alien.arrays sequences combinators combinators.lib alien.c-types alien.arrays sequences combinators combinators.lib
sequences.lib ascii splitting alien strings assocs namespaces ; sequences.lib ascii splitting alien strings assocs namespaces ;
IN: io.windows.nt.files IN: io.windows.nt.files
M: windows-nt-io cwd M: winnt cwd
MAX_UNICODE_PATH dup "ushort" <c-array> MAX_UNICODE_PATH dup "ushort" <c-array>
[ GetCurrentDirectory win32-error=0/f ] keep [ GetCurrentDirectory win32-error=0/f ] keep
alien>u16-string ; alien>u16-string ;
M: windows-nt-io cd M: winnt cd
SetCurrentDirectory win32-error=0/f ; SetCurrentDirectory win32-error=0/f ;
: unicode-prefix ( -- seq ) : unicode-prefix ( -- seq )
"\\\\?\\" ; inline "\\\\?\\" ; inline
M: windows-nt-io root-directory? ( path -- ? ) M: winnt root-directory? ( path -- ? )
{ {
{ [ dup empty? ] [ f ] } { [ dup empty? ] [ f ] }
{ [ dup [ path-separator? ] all? ] [ t ] } { [ dup [ path-separator? ] all? ] [ t ] }
@ -40,15 +40,15 @@ ERROR: not-absolute-path ;
unicode-prefix prepend unicode-prefix prepend
] unless ; ] unless ;
M: windows-nt-io normalize-path ( string -- string' ) M: winnt normalize-path ( string -- string' )
(normalize-path) (normalize-path)
{ { CHAR: / CHAR: \\ } } substitute { { CHAR: / CHAR: \\ } } substitute
prepend-prefix ; prepend-prefix ;
M: windows-nt-io CreateFile-flags ( DWORD -- DWORD ) M: winnt CreateFile-flags ( DWORD -- DWORD )
FILE_FLAG_OVERLAPPED bitor ; FILE_FLAG_OVERLAPPED bitor ;
M: windows-nt-io FileArgs-overlapped ( port -- overlapped ) M: winnt FileArgs-overlapped ( port -- overlapped )
make-overlapped ; make-overlapped ;
: update-file-ptr ( n port -- ) : update-file-ptr ( n port -- )

4
extra/io/windows/nt/launcher/launcher.factor
View File

@ -112,13 +112,13 @@ IN: io.windows.nt.launcher
dup pipe-out f set-inherit dup pipe-out f set-inherit
>>stdin-pipe ; >>stdin-pipe ;
M: windows-nt-io fill-redirection ( process args -- ) M: winnt fill-redirection ( process args -- )
[ 2dup redirect-stdout ] keep lpStartupInfo>> set-STARTUPINFO-hStdOutput [ 2dup redirect-stdout ] keep lpStartupInfo>> set-STARTUPINFO-hStdOutput
[ 2dup redirect-stderr ] keep lpStartupInfo>> set-STARTUPINFO-hStdError [ 2dup redirect-stderr ] keep lpStartupInfo>> set-STARTUPINFO-hStdError
[ 2dup redirect-stdin ] keep lpStartupInfo>> set-STARTUPINFO-hStdInput [ 2dup redirect-stdin ] keep lpStartupInfo>> set-STARTUPINFO-hStdInput
2drop ; 2drop ;
M: windows-nt-io (process-stream) M: winnt (process-stream)
[ [
dup make-CreateProcess-args dup make-CreateProcess-args

4
extra/io/windows/nt/monitors/monitors.factor
View File

@ -5,7 +5,7 @@ io.windows.nt.backend kernel math windows windows.kernel32
windows.types libc assocs alien namespaces continuations windows.types libc assocs alien namespaces continuations
io.monitors io.monitors.private io.nonblocking io.buffers io.monitors io.monitors.private io.nonblocking io.buffers
io.files io.timeouts io sequences hashtables sorting arrays io.files io.timeouts io sequences hashtables sorting arrays
combinators math.bitfields strings ; combinators math.bitfields strings system ;
IN: io.windows.nt.monitors IN: io.windows.nt.monitors
: open-directory ( path -- handle ) : open-directory ( path -- handle )
@ -30,7 +30,7 @@ TUPLE: win32-monitor path recursive? ;
set-delegate set-delegate
} win32-monitor construct ; } win32-monitor construct ;
M: windows-nt-io <monitor> ( path recursive? -- monitor ) M: winnt <monitor> ( path recursive? -- monitor )
[ [
over open-directory win32-monitor <buffered-port> over open-directory win32-monitor <buffered-port>
<win32-monitor> <win32-monitor>

3
extra/io/windows/nt/nt.factor
View File

@ -11,5 +11,6 @@ USE: io.windows.nt.sockets
USE: io.windows.mmap USE: io.windows.mmap
USE: io.windows.files USE: io.windows.files
USE: io.backend USE: io.backend
USE: system
T{ windows-nt-io } set-io-backend winnt set-io-backend

16
extra/io/windows/nt/sockets/sockets.factor
View File

@ -2,13 +2,13 @@ USING: alien alien.accessors alien.c-types byte-arrays
continuations destructors io.nonblocking io.timeouts io.sockets continuations destructors io.nonblocking io.timeouts io.sockets
io.sockets.impl io namespaces io.streams.duplex io.windows io.sockets.impl io namespaces io.streams.duplex io.windows
io.windows.nt.backend windows.winsock kernel libc math sequences io.windows.nt.backend windows.winsock kernel libc math sequences
threads classes.tuple.lib ; threads classes.tuple.lib system ;
IN: io.windows.nt.sockets IN: io.windows.nt.sockets
: malloc-int ( object -- object ) : malloc-int ( object -- object )
"int" heap-size malloc tuck 0 set-alien-signed-4 ; inline "int" heap-size malloc tuck 0 set-alien-signed-4 ; inline
M: windows-nt-io WSASocket-flags ( -- DWORD ) M: winnt WSASocket-flags ( -- DWORD )
WSA_FLAG_OVERLAPPED ; WSA_FLAG_OVERLAPPED ;
: get-ConnectEx-ptr ( socket -- void* ) : get-ConnectEx-ptr ( socket -- void* )
@ -50,7 +50,7 @@ TUPLE: ConnectEx-args port
2dup save-callback 2dup save-callback
get-overlapped-result drop ; get-overlapped-result drop ;
M: windows-nt-io (client) ( addrspec -- client-in client-out ) M: winnt (client) ( addrspec -- client-in client-out )
[ [
\ ConnectEx-args construct-empty \ ConnectEx-args construct-empty
over make-sockaddr/size pick init-connect over make-sockaddr/size pick init-connect
@ -119,7 +119,7 @@ TUPLE: AcceptEx-args port
[ AcceptEx-args-sAcceptSocket* add-completion ] keep [ AcceptEx-args-sAcceptSocket* add-completion ] keep
AcceptEx-args-sAcceptSocket* <win32-socket> ; AcceptEx-args-sAcceptSocket* <win32-socket> ;
M: windows-nt-io (accept) ( server -- addrspec handle ) M: winnt (accept) ( server -- addrspec handle )
[ [
[ [
dup check-server-port dup check-server-port
@ -131,14 +131,14 @@ M: windows-nt-io (accept) ( server -- addrspec handle )
] with-timeout ] with-timeout
] with-destructors ; ] with-destructors ;
M: windows-nt-io (server) ( addrspec -- handle ) M: winnt (server) ( addrspec -- handle )
[ [
SOCK_STREAM server-fd dup listen-on-socket SOCK_STREAM server-fd dup listen-on-socket
dup add-completion dup add-completion
<win32-socket> <win32-socket>
] with-destructors ; ] with-destructors ;
M: windows-nt-io <datagram> ( addrspec -- datagram ) M: winnt <datagram> ( addrspec -- datagram )
[ [
[ [
SOCK_DGRAM server-fd SOCK_DGRAM server-fd
@ -190,7 +190,7 @@ TUPLE: WSARecvFrom-args port
[ WSARecvFrom-args-lpFrom* ] keep [ WSARecvFrom-args-lpFrom* ] keep
WSARecvFrom-args-port datagram-port-addr parse-sockaddr ; WSARecvFrom-args-port datagram-port-addr parse-sockaddr ;
M: windows-nt-io receive ( datagram -- packet addrspec ) M: winnt receive ( datagram -- packet addrspec )
[ [
dup check-datagram-port dup check-datagram-port
\ WSARecvFrom-args construct-empty \ WSARecvFrom-args construct-empty
@ -242,7 +242,7 @@ TUPLE: WSASendTo-args port
USE: io.sockets USE: io.sockets
M: windows-nt-io send ( packet addrspec datagram -- ) M: winnt send ( packet addrspec datagram -- )
[ [
3dup check-datagram-send 3dup check-datagram-send
\ WSASendTo-args construct-empty \ WSASendTo-args construct-empty

30
extra/io/windows/windows.factor
View File

@ -5,16 +5,12 @@ io.buffers io.files io.nonblocking io.sockets io.binary
io.sockets.impl windows.errors strings io.streams.duplex io.sockets.impl windows.errors strings io.streams.duplex
kernel math namespaces sequences windows windows.kernel32 kernel math namespaces sequences windows windows.kernel32
windows.shell32 windows.types windows.winsock splitting windows.shell32 windows.types windows.winsock splitting
continuations math.bitfields ; continuations math.bitfields system ;
IN: io.windows IN: io.windows
TUPLE: windows-nt-io ; M: windows destruct-handle CloseHandle drop ;
TUPLE: windows-ce-io ;
UNION: windows-io windows-nt-io windows-ce-io ;
M: windows-io destruct-handle CloseHandle drop ; M: windows destruct-socket closesocket drop ;
M: windows-io destruct-socket closesocket drop ;
TUPLE: win32-file handle ptr ; TUPLE: win32-file handle ptr ;
@ -24,7 +20,7 @@ HOOK: CreateFile-flags io-backend ( DWORD -- DWORD )
HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f ) HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f )
HOOK: add-completion io-backend ( port -- ) HOOK: add-completion io-backend ( port -- )
M: windows-io normalize-directory ( string -- string ) M: windows normalize-directory ( string -- string )
normalize-path "\\" ?tail drop "\\*" append ; normalize-path "\\" ?tail drop "\\*" append ;
: share-mode ( -- fixnum ) : share-mode ( -- fixnum )
@ -125,30 +121,30 @@ C: <FileArgs> FileArgs
[ FileArgs-lpNumberOfBytesRet ] keep [ FileArgs-lpNumberOfBytesRet ] keep
FileArgs-lpOverlapped ; FileArgs-lpOverlapped ;
M: windows-io (file-reader) ( path -- stream ) M: windows (file-reader) ( path -- stream )
open-read <win32-file> <reader> ; open-read <win32-file> <reader> ;
M: windows-io (file-writer) ( path -- stream ) M: windows (file-writer) ( path -- stream )
open-write <win32-file> <writer> ; open-write <win32-file> <writer> ;
M: windows-io (file-appender) ( path -- stream ) M: windows (file-appender) ( path -- stream )
open-append <win32-file> <writer> ; open-append <win32-file> <writer> ;
M: windows-io move-file ( from to -- ) M: windows move-file ( from to -- )
[ normalize-path ] bi@ MoveFile win32-error=0/f ; [ normalize-path ] bi@ MoveFile win32-error=0/f ;
M: windows-io delete-file ( path -- ) M: windows delete-file ( path -- )
normalize-path DeleteFile win32-error=0/f ; normalize-path DeleteFile win32-error=0/f ;
M: windows-io copy-file ( from to -- ) M: windows copy-file ( from to -- )
dup parent-directory make-directories dup parent-directory make-directories
[ normalize-path ] bi@ 0 CopyFile win32-error=0/f ; [ normalize-path ] bi@ 0 CopyFile win32-error=0/f ;
M: windows-io make-directory ( path -- ) M: windows make-directory ( path -- )
normalize-path normalize-path
f CreateDirectory win32-error=0/f ; f CreateDirectory win32-error=0/f ;
M: windows-io delete-directory ( path -- ) M: windows delete-directory ( path -- )
normalize-path normalize-path
RemoveDirectory win32-error=0/f ; RemoveDirectory win32-error=0/f ;
@ -194,7 +190,7 @@ USE: namespaces
M: win32-socket dispose ( stream -- ) M: win32-socket dispose ( stream -- )
win32-file-handle closesocket drop ; win32-file-handle closesocket drop ;
M: windows-io addrinfo-error ( n -- ) M: windows addrinfo-error ( n -- )
winsock-return-check ; winsock-return-check ;
: tcp-socket ( addrspec -- socket ) : tcp-socket ( addrspec -- socket )