Merge branch 'master' of git://factorcode.org/git/factor

release
Eduardo Cavazos 2007-11-21 06:52:49 -06:00
commit 9b2dd5de1a
25 changed files with 281 additions and 245 deletions

0
core/alien/c-types/c-types.factor Normal file → Executable file
View File

View File

@ -5,7 +5,8 @@ hashtables kernel math namespaces sequences words
inference.backend inference.dataflow system inference.backend inference.dataflow system
math.parser classes alien.arrays alien.c-types alien.structs math.parser classes alien.arrays alien.c-types alien.structs
alien.syntax cpu.architecture alien inspector quotations assocs alien.syntax cpu.architecture alien inspector quotations assocs
kernel.private threads continuations.private libc combinators ; kernel.private threads continuations.private libc combinators
init ;
IN: alien.compiler IN: alien.compiler
! Common protocol for alien-invoke/alien-callback/alien-indirect ! Common protocol for alien-invoke/alien-callback/alien-indirect
@ -301,7 +302,7 @@ M: alien-indirect generate-node
! this hashtable, they will all be blown away by code GC, beware ! this hashtable, they will all be blown away by code GC, beware
SYMBOL: callbacks SYMBOL: callbacks
H{ } clone callbacks set-global [ H{ } clone callbacks set-global ] "alien.compiler" add-init-hook
: register-callback ( word -- ) dup callbacks get set-at ; : register-callback ( word -- ) dup callbacks get set-at ;

4
core/combinators/combinators.factor Normal file → Executable file
View File

@ -38,9 +38,7 @@ TUPLE: no-case ;
pick 0 <= [ 3drop 0 ] [ rot 1- -rot call ] if ; inline pick 0 <= [ 3drop 0 ] [ rot 1- -rot call ] if ; inline
M: sequence hashcode* M: sequence hashcode*
[ [ sequence-hashcode ] recursive-hashcode ;
0 -rot [ hashcode* bitxor ] curry* each
] recursive-hashcode ;
: alist>quot ( default assoc -- quot ) : alist>quot ( default assoc -- quot )
[ rot \ if 3array append [ ] like ] assoc-each ; [ rot \ if 3array append [ ] like ] assoc-each ;

0
core/io/io.factor Normal file → Executable file
View File

8
core/io/streams/lines/lines-tests.factor Normal file → Executable file
View File

@ -41,6 +41,14 @@ unit-test
4 swap stream-read 4 swap stream-read
] unit-test ] unit-test
[
"1234"
] [
"Hello world\r\n1234" <string-reader>
dup stream-readln drop
4 swap stream-read-partial
] unit-test
[ [
CHAR: 1 CHAR: 1
] [ ] [

23
core/io/streams/lines/lines.factor Normal file → Executable file
View File

@ -32,15 +32,26 @@ M: line-reader stream-readln ( stream -- str )
"\r\n" over delegate stream-read-until handle-readln ; "\r\n" over delegate stream-read-until handle-readln ;
: fix-read ( stream string -- string ) : fix-read ( stream string -- string )
"\n" ?head [ swap stream-read1 [ add ] when* ] [ nip ] if ; over line-reader-cr [
over cr-
"\n" ?head [
swap stream-read1 [ add ] when*
] [ nip ] if
] [ nip ] if ;
M: line-reader stream-read M: line-reader stream-read
tuck delegate stream-read tuck delegate stream-read fix-read ;
over line-reader-cr [ over cr- fix-read ] [ nip ] if ;
M: line-reader stream-read-partial
tuck delegate stream-read-partial fix-read ;
: fix-read1 ( stream char -- char ) : fix-read1 ( stream char -- char )
dup CHAR: \n = [ drop stream-read1 ] [ nip ] if ; over line-reader-cr [
over cr-
dup CHAR: \n = [
drop stream-read1
] [ nip ] if
] [ nip ] if ;
M: line-reader stream-read1 ( stream -- char ) M: line-reader stream-read1 ( stream -- char )
dup delegate stream-read1 dup delegate stream-read1 fix-read1 ;
over line-reader-cr [ over cr- fix-read1 ] [ nip ] if ;

View File

@ -44,7 +44,7 @@ M: sequence lengthen 2dup length > [ set-length ] [ 2drop ] if ;
TUPLE: bounds-error index seq ; TUPLE: bounds-error index seq ;
: bounds-error ( n seq -- * ) : bounds-error ( n seq -- * )
\ bounds-error construct-boa throw ; die \ bounds-error construct-boa throw ;
: bounds-check ( n seq -- n seq ) : bounds-check ( n seq -- n seq )
2dup bounds-check? [ bounds-error ] unless ; inline 2dup bounds-check? [ bounds-error ] unless ; inline
@ -666,3 +666,8 @@ PRIVATE>
: infimum ( seq -- n ) dup first [ min ] reduce ; : infimum ( seq -- n ) dup first [ min ] reduce ;
: supremum ( seq -- n ) dup first [ max ] reduce ; : supremum ( seq -- n ) dup first [ max ] reduce ;
: sequence-hashcode ( n seq -- x )
0 -rot [
hashcode* >fixnum swap 31 fixnum*fast fixnum+fast
] curry* each ; inline

3
core/strings/strings.factor Normal file → Executable file
View File

@ -13,8 +13,7 @@ IN: strings
: reset-string-hashcode f swap set-string-hashcode ; inline : reset-string-hashcode f swap set-string-hashcode ; inline
: rehash-string ( str -- ) : rehash-string ( str -- )
dup 0 [ swap 31 fixnum*fast fixnum+fast ] reduce 1 over sequence-hashcode swap set-string-hashcode ; inline
swap set-string-hashcode ; inline
PRIVATE> PRIVATE>

1
extra/io/launcher/launcher.factor Normal file → Executable file
View File

@ -59,3 +59,4 @@ HOOK: process-stream* io-backend ( desc -- stream )
USE-IF: unix? io.unix.launcher USE-IF: unix? io.unix.launcher
USE-IF: windows? io.windows.launcher USE-IF: windows? io.windows.launcher
USE-IF: winnt? io.windows.nt.launcher

View File

@ -13,7 +13,7 @@ M: windows-ce-io add-completion ( port -- ) drop ;
GENERIC: wince-read ( port port-handle -- ) GENERIC: wince-read ( port port-handle -- )
M: input-port (wait-to-read) ( port -- ) M: input-port (wait-to-read) ( port -- )
dup port-handle wince-read ; dup dup port-handle wince-read pending-error ;
GENERIC: wince-write ( port port-handle -- ) GENERIC: wince-write ( port port-handle -- )
@ -41,7 +41,5 @@ M: windows-ce-io init-stdio ( -- )
] [ ] [
0 _getstdfilex _fileno 0 _getstdfilex _fileno
1 _getstdfilex _fileno 1 _getstdfilex _fileno
] if ] if <win32-duplex-stream>
>r f <win32-file> <reader> ] with-variable stdio set ;
r> f <win32-file> <writer>
] with-variable <duplex-stream> stdio set ;

View File

@ -10,12 +10,16 @@ IN: windows.ce.files
M: windows-ce-io CreateFile-flags ( -- DWORD ) FILE_ATTRIBUTE_NORMAL ; M: windows-ce-io CreateFile-flags ( -- DWORD ) FILE_ATTRIBUTE_NORMAL ;
M: windows-ce-io FileArgs-overlapped ( port -- f ) drop f ; M: windows-ce-io FileArgs-overlapped ( port -- f ) drop f ;
: finish-read ( port status bytes-ret -- )
swap [ drop port-errored ] [ swap n>buffer ] if ;
M: win32-file wince-read M: win32-file wince-read
drop dup make-FileArgs dup setup-read ReadFile zero? [ drop
drop port-errored dup make-FileArgs dup setup-read ReadFile zero?
swap FileArgs-lpNumberOfBytesRet *uint dup zero? [
2drop t swap set-port-eof?
] [ ] [
FileArgs-lpNumberOfBytesRet *uint dup zero? finish-read
[ drop t swap set-port-eof? ] [ swap n>buffer ] if
] if ; ] if ;
M: win32-file wince-write ( port port-handle -- ) M: win32-file wince-write ( port port-handle -- )

View File

@ -1,11 +1,11 @@
! Copyright (C) 2007 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays continuations destructors io USING: alien alien.c-types arrays continuations destructors io
io.windows libc io.nonblocking io.streams.duplex windows.types io.windows libc io.nonblocking io.streams.duplex windows.types
math windows.kernel32 windows namespaces io.launcher kernel math windows.kernel32 windows namespaces io.launcher kernel
sequences windows.errors assocs splitting system ; sequences windows.errors assocs splitting system ;
IN: io.windows.launcher IN: io.windows.launcher
! From MSDN: "Handles in PROCESS_INFORMATION must be closed with CloseHandle when they are no longer needed."
TUPLE: CreateProcess-args TUPLE: CreateProcess-args
lpApplicationName lpApplicationName
lpCommandLine lpCommandLine
@ -20,6 +20,8 @@ TUPLE: CreateProcess-args
stdout-pipe stdin-pipe ; stdout-pipe stdin-pipe ;
: dispose-CreateProcess-args ( args -- ) : dispose-CreateProcess-args ( args -- )
#! From MSDN: "Handles in PROCESS_INFORMATION must be closed
#! with CloseHandle when they are no longer needed."
CreateProcess-args-lpProcessInformation dup CreateProcess-args-lpProcessInformation dup
PROCESS_INFORMATION-hProcess [ CloseHandle drop ] when* PROCESS_INFORMATION-hProcess [ CloseHandle drop ] when*
PROCESS_INFORMATION-hThread [ CloseHandle drop ] when* ; PROCESS_INFORMATION-hThread [ CloseHandle drop ] when* ;
@ -75,7 +77,7 @@ TUPLE: CreateProcess-args
: fill-dwCreateFlags : fill-dwCreateFlags
0 0
pass-environment? [ CREATE_UNICODE_ENVIRONMENT bitor ] when pass-environment? [ CREATE_UNICODE_ENVIRONMENT bitor ] when
+detached+ get [ DETACHED_PROCESS bitor ] when +detached+ get winnt? and [ DETACHED_PROCESS bitor ] when
over set-CreateProcess-args-dwCreateFlags ; over set-CreateProcess-args-dwCreateFlags ;
: fill-lpEnvironment : fill-lpEnvironment
@ -93,137 +95,16 @@ TUPLE: CreateProcess-args
PROCESS_INFORMATION-hProcess INFINITE PROCESS_INFORMATION-hProcess INFINITE
WaitForSingleObject drop ; WaitForSingleObject drop ;
: make-CreateProcess-args ( -- args )
default-CreateProcess-args
wince? [ fill-lpApplicationName ] [ fill-lpCommandLine ] if
fill-dwCreateFlags
fill-lpEnvironment ;
M: windows-io run-process* ( desc -- ) M: windows-io run-process* ( desc -- )
[ [
default-CreateProcess-args make-CreateProcess-args
wince? [
fill-lpApplicationName
] [
fill-lpCommandLine
] if
fill-dwCreateFlags
fill-lpEnvironment
dup call-CreateProcess dup call-CreateProcess
+detached+ get [ dup wait-for-process ] unless +detached+ get [ dup wait-for-process ] unless
dispose-CreateProcess-args dispose-CreateProcess-args
] with-descriptor ; ] with-descriptor ;
! : default-security-attributes ( -- obj )
! "SECURITY_ATTRIBUTES" <c-object>
! "SECURITY_ATTRIBUTES" heap-size over set-SECURITY_ATTRIBUTES-nLength ;
!
! : security-attributes-inherit ( -- obj )
! default-security-attributes
! TRUE over set-SECURITY_ATTRIBUTES-bInheritHandle ;
!
! : set-inherit ( handle ? -- )
! >r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ;
!
! ! http://msdn2.microsoft.com/en-us/library/ms682499.aspx
!
! TUPLE: pipe hRead hWrite ;
!
! C: <pipe> pipe
!
! : factor-pipe-name
! "\\\\.\\pipe\\Factor" ;
!
! : create-named-pipe ( str -- handle )
! PIPE_ACCESS_DUPLEX FILE_FLAG_OVERLAPPED bitor
! PIPE_TYPE_BYTE PIPE_READMODE_BYTE PIPE_NOWAIT bitor bitor
! PIPE_UNLIMITED_INSTANCES
! default-buffer-size get
! default-buffer-size get
! 0
! security-attributes-inherit
! CreateNamedPipe dup invalid-handle? ;
!
! : ERROR_PIPE_CONNECT 535 ; inline
!
! : pipe-connect-error? ( n -- ? )
! ERROR_SUCCESS ERROR_PIPE_CONNECT 2array member? not ;
!
! clear "ls" <process-stream> contents
! M: windows-nt-io <process-stream> ( command -- stream )
! [
! [
! default-CreateProcess-args
! fill-lpCommandLine
! TRUE over set-CreateProcess-args-bInheritHandles
!
! dup CreateProcess-args-lpStartupInfo
! STARTF_USESTDHANDLES over set-STARTUPINFO-dwFlags
!
! factor-pipe-name create-named-pipe
! global [ "Named pipe: " write dup . ] bind
! dup t set-inherit
! [ add-completion ] keep
!
! ! CreateFile
! ! factor-pipe-name open-pipe-r/w
! factor-pipe-name GENERIC_READ GENERIC_WRITE bitor
! 0 f OPEN_EXISTING FILE_FLAG_OVERLAPPED f
! CreateFile
! global [ "Created File: " write dup . ] bind
! dup invalid-handle? dup close-later
! dup add-completion
!
! swap (make-overlapped) ConnectNamedPipe zero? [
! GetLastError pipe-connect-error? [
! win32-error-string throw
! ] when
! ] when
! dup t set-inherit
!
! ! ERROR_PIPE_CONNECTED
! [ pick set-CreateProcess-args-stdin-pipe ] keep
! global [ "Setting the stdios to: " write dup . ] bind
! [ over set-STARTUPINFO-hStdOutput ] keep
! [ over set-STARTUPINFO-hStdInput ] keep
! swap set-STARTUPINFO-hStdError
! !
! [ call-CreateProcess ] keep
! [ CreateProcess-args-stdin-pipe f <win32-file> dup handle>duplex-stream ] keep
! drop ! TODO: close handles instead of drop
! ] with-destructors
! ] with-descriptor ;
!
! : create-pipe ( -- pipe )
! "HANDLE" <c-object>
! "HANDLE" <c-object>
! [
! security-attributes-inherit
! 0
! CreatePipe win32-error=0/f
! ] 2keep
! [ *void* dup close-later ] 2apply <pipe> ;
!
! M: windows-ce-io process-stream*
! [
! default-CreateProcess-args
! TRUE over set-CreateProcess-args-bInheritHandles
!
! create-pipe ! for child's STDOUT
! dup pipe-hRead f set-inherit
! over set-CreateProcess-args-stdout-pipe
!
! create-pipe ! for child's STDIN
! dup pipe-hWrite f set-inherit
! over set-CreateProcess-args-stdin-pipe
!
! dup CreateProcess-args-lpStartupInfo
! STARTF_USESTDHANDLES over set-STARTUPINFO-dwFlags
!
! over CreateProcess-args-stdout-pipe
! pipe-hWrite over set-STARTUPINFO-hStdOutput
! over CreateProcess-args-stdout-pipe
! pipe-hWrite over set-STARTUPINFO-hStdError
! over CreateProcess-args-stdin-pipe
! pipe-hRead swap set-STARTUPINFO-hStdInput
!
! [ call-CreateProcess ] keep
! [ CreateProcess-args-stdin-pipe pipe-hRead f <win32-file> <reader> ] keep
! [ CreateProcess-args-stdout-pipe pipe-hWrite f <win32-file> <writer> <duplex-stream> ] keep
! drop ! TODO: close handles instead of drop
! ] with-destructors ;
!

View File

@ -78,7 +78,7 @@ M: windows-io <mapped-file> ( path length -- mmap )
PAGE_READWRITE SEC_COMMIT bitor PAGE_READWRITE SEC_COMMIT bitor
FILE_MAP_ALL_ACCESS mmap-open FILE_MAP_ALL_ACCESS mmap-open
-rot 2array -rot 2array
\ mapped-file construct-boa f \ mapped-file construct-boa
] with-destructors ; ] with-destructors ;
M: windows-io (close-mapped-file) ( mapped-file -- ) M: windows-io (close-mapped-file) ( mapped-file -- )

View File

@ -42,7 +42,8 @@ M: windows-nt-io normalize-pathname ( string -- string )
SYMBOL: io-hash SYMBOL: io-hash
TUPLE: io-callback port continuation ; TUPLE: io-callback continuation port ;
C: <io-callback> io-callback C: <io-callback> io-callback
: (make-overlapped) ( -- overlapped-ext ) : (make-overlapped) ( -- overlapped-ext )
@ -74,53 +75,55 @@ SYMBOL: master-completion-port
M: windows-nt-io add-completion ( handle -- ) M: windows-nt-io add-completion ( handle -- )
master-completion-port get-global <completion-port> drop ; master-completion-port get-global <completion-port> drop ;
TUPLE: GetOverlappedResult-args hFile* lpOverlapped* lpNumberOfBytesTransferred* bWait* port ; : eof? ( error -- ? )
dup ERROR_HANDLE_EOF = swap ERROR_BROKEN_PIPE = or ;
C: <GetOverlappedResult-args> GetOverlappedResult-args : overlapped-error? ( port n -- ? )
zero? [
GetLastError {
{ [ dup expected-io-error? ] [ 2drop t ] }
{ [ dup eof? ] [ drop t swap set-port-eof? f ] }
{ [ t ] [ (win32-error-string) throw ] }
} cond
] [
drop t
] if ;
: get-overlapped-result ( port -- n ) : get-overlapped-result ( port -- bytes-transferred )
[ dup
port-handle dup win32-file-handle port-handle
swap win32-file-overlapped 0 <int> 0 dup win32-file-handle
] keep <GetOverlappedResult-args> [ swap win32-file-overlapped
\ GetOverlappedResult-args >tuple< 0 <uint> [
>r GetOverlappedResult r> swap overlapped-error? drop 0
] keep GetOverlappedResult-args-lpNumberOfBytesTransferred* *int ; GetOverlappedResult overlapped-error? drop
] keep *uint ;
: (save-callback) ( io-callback -- )
dup io-callback-port port-handle win32-file-overlapped
io-hash get-global set-at ;
: save-callback ( port -- ) : save-callback ( port -- )
[ [
<io-callback> (save-callback) stop [ <io-callback> ] keep port-handle win32-file-overlapped
] callcc0 drop ; io-hash get-global set-at stop
] curry callcc0 ;
TUPLE: GetQueuedCompletionStatusParams hCompletionPort* lpNumberOfBytes* lpCompletionKey* lpOverlapped* dwMilliseconds* ; : wait-for-overlapped ( ms -- overlapped ? )
>r master-completion-port get-global r> ! port ms
C: <GetQueuedCompletionStatusParams> GetQueuedCompletionStatusParams 0 <int> ! bytes
f <void*> ! key
: wait-for-overlapped ( ms -- GetQueuedCompletionStatus-Params ret ) f <void*> ! overlapped
>r master-completion-port get-global 0 <int> 0 <int> 0 <int> [ roll GetQueuedCompletionStatus ] keep *void* swap zero? ;
r> <GetQueuedCompletionStatusParams> [
GetQueuedCompletionStatusParams >tuple*<
GetQueuedCompletionStatus
] keep swap ;
: lookup-callback ( GetQueuedCompletion-args -- callback ) : lookup-callback ( GetQueuedCompletion-args -- callback )
GetQueuedCompletionStatusParams-lpOverlapped* *void*
io-hash get-global delete-at* drop ; io-hash get-global delete-at* drop ;
: wait-for-io ( timeout -- continuation/f ) : wait-for-io ( timeout -- continuation/f )
wait-for-overlapped wait-for-overlapped [
zero? [ GetLastError dup expected-io-error? [
GetLastError dup (expected-io-error?) [
2drop f 2drop f
] [ ] [
dup ERROR_HANDLE_EOF = [ dup eof? [
drop lookup-callback [ drop lookup-callback
io-callback-port t swap set-port-eof? dup io-callback-port t swap set-port-eof?
] keep io-callback-continuation io-callback-continuation
] [ ] [
(win32-error-string) swap lookup-callback (win32-error-string) swap lookup-callback
[ io-callback-port set-port-error ] keep [ io-callback-port set-port-error ] keep
@ -146,10 +149,6 @@ M: windows-nt-io io-multiplex ( ms -- )
cancel-timeout wait-for-io [ schedule-thread ] when* ; cancel-timeout wait-for-io [ schedule-thread ] when* ;
M: windows-nt-io init-io ( -- ) M: windows-nt-io init-io ( -- )
#! Should only be called on startup. Calling this at any <master-completion-port> master-completion-port set-global
#! other time can have unintended consequences. H{ } clone io-hash set-global
global [ windows.winsock:init-winsock ;
<master-completion-port> master-completion-port set
H{ } clone io-hash set
windows.winsock:init-winsock
] bind ;

View File

@ -0,0 +1,64 @@
! Copyright (C) 2007 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays continuations destructors io
io.windows libc io.nonblocking io.streams.duplex windows.types
math windows.kernel32 windows namespaces io.launcher kernel
sequences windows.errors assocs splitting system
io.windows.launcher io.windows.nt.pipes ;
IN: io.windows.nt.launcher
! The below code is based on the example given in
! http://msdn2.microsoft.com/en-us/library/ms682499.aspx
: set-inherit ( handle ? -- )
>r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ;
: add-pipe-dtors ( pipe -- )
dup
pipe-in close-later
pipe-out close-later ;
: fill-stdout-pipe
<unique-incoming-pipe>
dup add-pipe-dtors
dup pipe-in f set-inherit
over set-CreateProcess-args-stdout-pipe ;
: fill-stdin-pipe
<unique-outgoing-pipe>
dup add-pipe-dtors
dup pipe-out f set-inherit
over set-CreateProcess-args-stdin-pipe ;
: fill-startup-info
dup CreateProcess-args-lpStartupInfo
STARTF_USESTDHANDLES over set-STARTUPINFO-dwFlags
over CreateProcess-args-stdout-pipe
pipe-out over set-STARTUPINFO-hStdOutput
over CreateProcess-args-stdout-pipe
pipe-out over set-STARTUPINFO-hStdError
over CreateProcess-args-stdin-pipe
pipe-in swap set-STARTUPINFO-hStdInput ;
M: windows-io process-stream*
[
[
make-CreateProcess-args
TRUE over set-CreateProcess-args-bInheritHandles
fill-stdout-pipe
fill-stdin-pipe
fill-startup-info
dup call-CreateProcess
dup CreateProcess-args-stdin-pipe pipe-in CloseHandle drop
dup CreateProcess-args-stdout-pipe pipe-out CloseHandle drop
dup CreateProcess-args-stdout-pipe pipe-in
over CreateProcess-args-stdin-pipe pipe-out <win32-duplex-stream>
swap dispose-CreateProcess-args
] with-destructors
] with-descriptor ;

View File

@ -0,0 +1,75 @@
! Copyright (C) 2007 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays destructors io io.windows libc
windows.types math windows.kernel32 windows namespaces kernel
sequences windows.errors assocs math.parser system random ;
IN: io.windows.nt.pipes
! This code is based on
! http://twistedmatrix.com/trac/browser/trunk/twisted/internet/iocpreactor/process.py
: default-security-attributes ( -- obj )
"SECURITY_ATTRIBUTES" <c-object>
"SECURITY_ATTRIBUTES" heap-size over set-SECURITY_ATTRIBUTES-nLength ;
: security-attributes-inherit ( -- obj )
default-security-attributes
TRUE over set-SECURITY_ATTRIBUTES-bInheritHandle ; foldable
: create-named-pipe ( name mode -- handle )
FILE_FLAG_OVERLAPPED bitor
PIPE_TYPE_BYTE
1
4096
4096
0
security-attributes-inherit
CreateNamedPipe
dup win32-error=0/f
dup add-completion ;
: open-other-end ( name mode -- handle )
FILE_SHARE_READ FILE_SHARE_WRITE bitor
security-attributes-inherit
OPEN_EXISTING
FILE_FLAG_OVERLAPPED
f
CreateFile
dup win32-error=0/f
dup add-completion ;
TUPLE: pipe in out ;
: <pipe> ( name in-mode out-mode -- pipe )
[
>r over >r create-named-pipe dup close-later
r> r> open-other-end dup close-later
pipe construct-boa
] with-destructors ;
: close-pipe ( pipe -- )
dup
pipe-in CloseHandle drop
pipe-out CloseHandle drop ;
: <incoming-pipe> ( name -- pipe )
PIPE_ACCESS_INBOUND GENERIC_WRITE <pipe> ;
: <outgoing-pipe> ( name -- pipe )
PIPE_ACCESS_DUPLEX GENERIC_READ <pipe> ;
: unique-pipe-name ( -- string )
[
"\\\\.\\pipe\\factor-" %
pipe counter #
"-" %
(random) #
"-" %
millis #
] "" make ;
: <unique-incoming-pipe> ( -- pipe )
unique-pipe-name <incoming-pipe> ;
: <unique-outgoing-pipe> ( -- pipe )
unique-pipe-name <outgoing-pipe> ;

View File

@ -1,16 +0,0 @@
USING: io.files kernel tools.test ;
IN: temporary
[ "c:\\foo\\" ] [ "c:\\foo\\bar" parent-directory ] unit-test
[ "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
[ "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 ] [ "Z:\\" root-directory? ] unit-test
[ f ] [ "c:\\foo" root-directory? ] unit-test
[ f ] [ "." root-directory? ] unit-test
[ f ] [ ".." root-directory? ] unit-test

View File

@ -20,6 +20,9 @@ TUPLE: win32-file handle ptr overlapped ;
: <win32-file> ( handle ptr -- obj ) : <win32-file> ( handle ptr -- obj )
f win32-file construct-boa ; f win32-file construct-boa ;
: <win32-duplex-stream> ( in out -- stream )
>r f <win32-file> r> f <win32-file> handle>duplex-stream ;
HOOK: CreateFile-flags io-backend ( -- DWORD ) HOOK: CreateFile-flags io-backend ( -- 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 -- )

16
extra/tools/deploy/shaker/shaker.factor Normal file → Executable file
View File

@ -24,7 +24,6 @@ IN: tools.deploy.shaker
"Stripping debugger" show "Stripping debugger" show
"resource:extra/tools/deploy/shaker/strip-debugger.factor" "resource:extra/tools/deploy/shaker/strip-debugger.factor"
run-file run-file
do-parse-hook
] when ; ] when ;
: strip-libc ( -- ) : strip-libc ( -- )
@ -32,7 +31,6 @@ IN: tools.deploy.shaker
"Stripping manual memory management debug code" show "Stripping manual memory management debug code" show
"resource:extra/tools/deploy/shaker/strip-libc.factor" "resource:extra/tools/deploy/shaker/strip-libc.factor"
run-file run-file
do-parse-hook
] when ; ] when ;
: strip-cocoa ( -- ) : strip-cocoa ( -- )
@ -40,7 +38,6 @@ IN: tools.deploy.shaker
"Stripping unused Cocoa methods" show "Stripping unused Cocoa methods" show
"resource:extra/tools/deploy/shaker/strip-cocoa.factor" "resource:extra/tools/deploy/shaker/strip-cocoa.factor"
run-file run-file
do-parse-hook
] when ; ] when ;
: strip-assoc ( retained-keys assoc -- newassoc ) : strip-assoc ( retained-keys assoc -- newassoc )
@ -116,7 +113,6 @@ SYMBOL: deploy-vocab
strip-dictionary? [ strip-dictionary? [
{ {
builtins
dictionary dictionary
inspector-hook inspector-hook
lexer-factory lexer-factory
@ -142,6 +138,10 @@ SYMBOL: deploy-vocab
"c-types" "alien.c-types" lookup , "c-types" "alien.c-types" lookup ,
] when ] when
native-io? [
"default-buffer-size" "io.nonblocking" lookup ,
] when
deploy-ui? get [ deploy-ui? get [
"ui" child-vocabs "ui" child-vocabs
"cocoa" child-vocabs "cocoa" child-vocabs
@ -152,10 +152,11 @@ SYMBOL: deploy-vocab
] when ] when
] { } make dup . ; ] { } make dup . ;
: strip ( -- ) : strip ( hook -- )
strip-libc >r strip-libc
strip-cocoa strip-cocoa
strip-debugger strip-debugger
r> [ call ] when*
strip-init-hooks strip-init-hooks
deploy-vocab get vocab-main set-boot-quot* deploy-vocab get vocab-main set-boot-quot*
retained-props >r retained-props >r
@ -168,10 +169,9 @@ SYMBOL: deploy-vocab
[ [
[ [
deploy-vocab set deploy-vocab set
parse-hook get >r parse-hook get
parse-hook off parse-hook off
deploy-vocab get require deploy-vocab get require
r> [ call ] when*
strip strip
finish-deploy finish-deploy
] [ ] [

0
extra/tools/deploy/shaker/strip-debugger.factor Normal file → Executable file
View File

View File

@ -1,7 +1,7 @@
USING: ui.gadgets.editors tools.test kernel io io.streams.plain USING: ui.gadgets.editors tools.test kernel io io.streams.plain
definitions namespaces ui.gadgets definitions namespaces ui.gadgets
ui.gadgets.grids prettyprint documents ui.gestures ui.gadgets.grids prettyprint documents ui.gestures
tools.test.inference tools.test.ui ; tools.test.inference tools.test.ui models ;
[ "foo bar" ] [ [ "foo bar" ] [
<editor> "editor" set <editor> "editor" set
@ -31,3 +31,9 @@ tools.test.inference tools.test.ui ;
] unit-test ] unit-test
{ 0 1 } [ <editor> ] unit-test-effect { 0 1 } [ <editor> ] unit-test-effect
"hello" <model> <field> "field" set
"field" get [
[ "hello" ] [ "field" get field-model model-value ] unit-test
] with-grafted-gadget

View File

@ -70,8 +70,12 @@ M: gadget model-changed 2drop ;
>r <gadget> r> construct-delegate ; inline >r <gadget> r> construct-delegate ; inline
: activate-control ( gadget -- ) : activate-control ( gadget -- )
dup gadget-model dup [ 2dup add-connection ] when drop dup gadget-model dup [
dup gadget-model swap model-changed ; 2dup add-connection
swap model-changed
] [
2drop
] if ;
: deactivate-control ( gadget -- ) : deactivate-control ( gadget -- )
dup gadget-model dup [ 2dup remove-connection ] when 2drop ; dup gadget-model dup [ 2dup remove-connection ] when 2drop ;

View File

@ -280,10 +280,13 @@ SYMBOL: hWnd
mouse-captured? [ release-capture ] when mouse-captured? [ release-capture ] when
prepare-mouse send-button-up ; prepare-mouse send-button-up ;
: make-TRACKMOUSEEVENT ( hWnd -- alien )
"TRACKMOUSEEVENT" <c-object> [ set-TRACKMOUSEEVENT-hwndTrack ] keep
"TRACKMOUSEEVENT" heap-size over set-TRACKMOUSEEVENT-cbSize ;
: handle-wm-mousemove ( hWnd uMsg wParam lParam -- ) : handle-wm-mousemove ( hWnd uMsg wParam lParam -- )
2nip 2nip
over "TRACKMOUSEEVENT" <c-object> [ set-TRACKMOUSEEVENT-hwndTrack ] keep over make-TRACKMOUSEEVENT
"TRACKMOUSEEVENT" heap-size over set-TRACKMOUSEEVENT-cbSize
TME_LEAVE over set-TRACKMOUSEEVENT-dwFlags TME_LEAVE over set-TRACKMOUSEEVENT-dwFlags
0 over set-TRACKMOUSEEVENT-dwHoverTime 0 over set-TRACKMOUSEEVENT-dwHoverTime
TrackMouseEvent drop TrackMouseEvent drop
@ -387,10 +390,10 @@ SYMBOL: hWnd
dup SetForegroundWindow drop dup SetForegroundWindow drop
SetFocus drop ; SetFocus drop ;
: init-win32-ui : init-win32-ui ( -- )
"MSG" <c-object> msg-obj set "MSG" <c-object> msg-obj set
"Factor-window" malloc-u16-string class-name-ptr set-global "Factor-window" malloc-u16-string class-name-ptr set-global
register-wndclassex register-wndclassex drop
GetDoubleClickTime double-click-timeout set-global ; GetDoubleClickTime double-click-timeout set-global ;
: cleanup-win32-ui ( -- ) : cleanup-win32-ui ( -- )

1
extra/windows/errors/errors.factor Normal file → Executable file
View File

@ -3,6 +3,7 @@ IN: windows.errors
: ERROR_SUCCESS 0 ; inline : ERROR_SUCCESS 0 ; inline
: ERROR_HANDLE_EOF 38 ; inline : ERROR_HANDLE_EOF 38 ; inline
: ERROR_BROKEN_PIPE 109 ; inline
: ERROR_IO_INCOMPLETE 996 ; inline : ERROR_IO_INCOMPLETE 996 ; inline
: ERROR_IO_PENDING 997 ; inline : ERROR_IO_PENDING 997 ; inline

25
extra/windows/windows.factor Normal file → Executable file
View File

@ -39,30 +39,21 @@ FUNCTION: void* error_message ( DWORD id ) ;
win32-error-string throw win32-error-string throw
] when ; ] when ;
: (expected-io-error?) ( error-code -- ? ) : expected-io-errors
ERROR_SUCCESS ERROR_SUCCESS
ERROR_IO_INCOMPLETE ERROR_IO_INCOMPLETE
ERROR_IO_PENDING ERROR_IO_PENDING
WAIT_TIMEOUT 4array member? ; WAIT_TIMEOUT 4array ; foldable
: expected-io-error? ( error-code -- ) : expected-io-error? ( error-code -- ? )
dup (expected-io-error?) [ expected-io-errors member? ;
: expected-io-error ( error-code -- )
dup expected-io-error? [
drop drop
] [ ] [
(win32-error-string) throw (win32-error-string) throw
] if ; ] if ;
: io-error ( return-value -- ) : io-error ( return-value -- )
{ 0 f } member? [ GetLastError expected-io-error? ] when ; { 0 f } member? [ GetLastError expected-io-error ] when ;
: overlapped-error? ( port n -- ? )
zero? [
GetLastError
{
{ [ dup (expected-io-error?) ] [ 2drop t ] }
{ [ dup ERROR_HANDLE_EOF = ] [ drop t swap set-port-eof? f ] }
{ [ t ] [ (win32-error-string) throw ] }
} cond
] [
drop t
] if ;