diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor old mode 100644 new mode 100755 diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor index 992c7763f2..7495be42ca 100755 --- a/core/alien/compiler/compiler.factor +++ b/core/alien/compiler/compiler.factor @@ -5,7 +5,8 @@ hashtables kernel math namespaces sequences words inference.backend inference.dataflow system math.parser classes alien.arrays alien.c-types alien.structs 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 ! 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 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 ; diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor old mode 100644 new mode 100755 index cda1d41960..0e214c412a --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -38,9 +38,7 @@ TUPLE: no-case ; pick 0 <= [ 3drop 0 ] [ rot 1- -rot call ] if ; inline M: sequence hashcode* - [ - 0 -rot [ hashcode* bitxor ] curry* each - ] recursive-hashcode ; + [ sequence-hashcode ] recursive-hashcode ; : alist>quot ( default assoc -- quot ) [ rot \ if 3array append [ ] like ] assoc-each ; diff --git a/core/io/io.factor b/core/io/io.factor old mode 100644 new mode 100755 diff --git a/core/io/streams/lines/lines-tests.factor b/core/io/streams/lines/lines-tests.factor old mode 100644 new mode 100755 index b09711bf60..64dc7bff3b --- a/core/io/streams/lines/lines-tests.factor +++ b/core/io/streams/lines/lines-tests.factor @@ -41,6 +41,14 @@ unit-test 4 swap stream-read ] unit-test +[ + "1234" +] [ + "Hello world\r\n1234" + dup stream-readln drop + 4 swap stream-read-partial +] unit-test + [ CHAR: 1 ] [ diff --git a/core/io/streams/lines/lines.factor b/core/io/streams/lines/lines.factor old mode 100644 new mode 100755 index 3de8bdc7b7..391c602cc3 --- a/core/io/streams/lines/lines.factor +++ b/core/io/streams/lines/lines.factor @@ -32,15 +32,26 @@ M: line-reader stream-readln ( stream -- str ) "\r\n" over delegate stream-read-until handle-readln ; : 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 - tuck delegate stream-read - over line-reader-cr [ over cr- fix-read ] [ nip ] if ; + tuck delegate stream-read fix-read ; + +M: line-reader stream-read-partial + tuck delegate stream-read-partial fix-read ; : 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 ) - dup delegate stream-read1 - over line-reader-cr [ over cr- fix-read1 ] [ nip ] if ; + dup delegate stream-read1 fix-read1 ; diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 2f6bb7ad57..f179bf069c 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -44,7 +44,7 @@ M: sequence lengthen 2dup length > [ set-length ] [ 2drop ] if ; TUPLE: bounds-error index seq ; : bounds-error ( n seq -- * ) - \ bounds-error construct-boa throw ; + die \ bounds-error construct-boa throw ; : bounds-check ( n seq -- n seq ) 2dup bounds-check? [ bounds-error ] unless ; inline @@ -666,3 +666,8 @@ PRIVATE> : infimum ( seq -- n ) dup first [ min ] 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 diff --git a/core/strings/strings.factor b/core/strings/strings.factor old mode 100644 new mode 100755 index e177a2b9d2..10f38f8298 --- a/core/strings/strings.factor +++ b/core/strings/strings.factor @@ -13,8 +13,7 @@ IN: strings : reset-string-hashcode f swap set-string-hashcode ; inline : rehash-string ( str -- ) - dup 0 [ swap 31 fixnum*fast fixnum+fast ] reduce - swap set-string-hashcode ; inline + 1 over sequence-hashcode swap set-string-hashcode ; inline PRIVATE> diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor old mode 100644 new mode 100755 index 92a15bb460..114a50597c --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -59,3 +59,4 @@ HOOK: process-stream* io-backend ( desc -- stream ) USE-IF: unix? io.unix.launcher USE-IF: windows? io.windows.launcher +USE-IF: winnt? io.windows.nt.launcher diff --git a/extra/io/windows/ce/backend/backend.factor b/extra/io/windows/ce/backend/backend.factor index 2cd1f6fe99..b9ad30d910 100755 --- a/extra/io/windows/ce/backend/backend.factor +++ b/extra/io/windows/ce/backend/backend.factor @@ -13,7 +13,7 @@ M: windows-ce-io add-completion ( port -- ) drop ; GENERIC: wince-read ( port port-handle -- ) 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 -- ) @@ -41,7 +41,5 @@ M: windows-ce-io init-stdio ( -- ) ] [ 0 _getstdfilex _fileno 1 _getstdfilex _fileno - ] if - >r f - r> f - ] with-variable stdio set ; + ] if + ] with-variable stdio set ; diff --git a/extra/io/windows/ce/files/files.factor b/extra/io/windows/ce/files/files.factor index 0cffcb85f0..df5dc65094 100755 --- a/extra/io/windows/ce/files/files.factor +++ b/extra/io/windows/ce/files/files.factor @@ -10,12 +10,16 @@ IN: windows.ce.files M: windows-ce-io CreateFile-flags ( -- DWORD ) FILE_ATTRIBUTE_NORMAL ; 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 - drop dup make-FileArgs dup setup-read ReadFile zero? [ - drop port-errored + drop + 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? - [ drop t swap set-port-eof? ] [ swap n>buffer ] if + finish-read ] if ; M: win32-file wince-write ( port port-handle -- ) diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index f586976bb6..3caa2c7113 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -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 io.windows libc io.nonblocking io.streams.duplex windows.types math windows.kernel32 windows namespaces io.launcher kernel sequences windows.errors assocs splitting system ; IN: io.windows.launcher -! From MSDN: "Handles in PROCESS_INFORMATION must be closed with CloseHandle when they are no longer needed." - TUPLE: CreateProcess-args lpApplicationName lpCommandLine @@ -20,6 +20,8 @@ TUPLE: CreateProcess-args stdout-pipe stdin-pipe ; : 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 PROCESS_INFORMATION-hProcess [ CloseHandle drop ] when* PROCESS_INFORMATION-hThread [ CloseHandle drop ] when* ; @@ -75,7 +77,7 @@ TUPLE: CreateProcess-args : fill-dwCreateFlags 0 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 ; : fill-lpEnvironment @@ -93,137 +95,16 @@ TUPLE: CreateProcess-args PROCESS_INFORMATION-hProcess INFINITE 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 -- ) [ - default-CreateProcess-args - wince? [ - fill-lpApplicationName - ] [ - fill-lpCommandLine - ] if - fill-dwCreateFlags - fill-lpEnvironment + make-CreateProcess-args dup call-CreateProcess +detached+ get [ dup wait-for-process ] unless dispose-CreateProcess-args ] with-descriptor ; - -! : default-security-attributes ( -- obj ) -! "SECURITY_ATTRIBUTES" -! "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 -! -! : 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" contents -! M: windows-nt-io ( 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 dup handle>duplex-stream ] keep -! drop ! TODO: close handles instead of drop -! ] with-destructors -! ] with-descriptor ; -! -! : create-pipe ( -- pipe ) -! "HANDLE" -! "HANDLE" -! [ -! security-attributes-inherit -! 0 -! CreatePipe win32-error=0/f -! ] 2keep -! [ *void* dup close-later ] 2apply ; -! -! 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 ] keep -! [ CreateProcess-args-stdout-pipe pipe-hWrite f ] keep -! drop ! TODO: close handles instead of drop -! ] with-destructors ; -! diff --git a/extra/io/windows/mmap/mmap.factor b/extra/io/windows/mmap/mmap.factor index 20c6a6fc22..ca5d2bbd9a 100755 --- a/extra/io/windows/mmap/mmap.factor +++ b/extra/io/windows/mmap/mmap.factor @@ -78,7 +78,7 @@ M: windows-io ( path length -- mmap ) PAGE_READWRITE SEC_COMMIT bitor FILE_MAP_ALL_ACCESS mmap-open -rot 2array - \ mapped-file construct-boa + f \ mapped-file construct-boa ] with-destructors ; M: windows-io (close-mapped-file) ( mapped-file -- ) diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor index 2c6d152e3d..c475771b5c 100755 --- a/extra/io/windows/nt/backend/backend.factor +++ b/extra/io/windows/nt/backend/backend.factor @@ -42,7 +42,8 @@ M: windows-nt-io normalize-pathname ( string -- string ) SYMBOL: io-hash -TUPLE: io-callback port continuation ; +TUPLE: io-callback continuation port ; + C: io-callback : (make-overlapped) ( -- overlapped-ext ) @@ -74,53 +75,55 @@ SYMBOL: master-completion-port M: windows-nt-io add-completion ( handle -- ) master-completion-port get-global drop ; -TUPLE: GetOverlappedResult-args hFile* lpOverlapped* lpNumberOfBytesTransferred* bWait* port ; +: eof? ( error -- ? ) + dup ERROR_HANDLE_EOF = swap ERROR_BROKEN_PIPE = or ; -C: 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 ) - [ - port-handle dup win32-file-handle - swap win32-file-overlapped 0 0 - ] keep [ - \ GetOverlappedResult-args >tuple< - >r GetOverlappedResult r> swap overlapped-error? drop - ] keep GetOverlappedResult-args-lpNumberOfBytesTransferred* *int ; - -: (save-callback) ( io-callback -- ) - dup io-callback-port port-handle win32-file-overlapped - io-hash get-global set-at ; +: get-overlapped-result ( port -- bytes-transferred ) + dup + port-handle + dup win32-file-handle + swap win32-file-overlapped + 0 [ + 0 + GetOverlappedResult overlapped-error? drop + ] keep *uint ; : save-callback ( port -- ) [ - (save-callback) stop - ] callcc0 drop ; + [ ] keep port-handle win32-file-overlapped + io-hash get-global set-at stop + ] curry callcc0 ; -TUPLE: GetQueuedCompletionStatusParams hCompletionPort* lpNumberOfBytes* lpCompletionKey* lpOverlapped* dwMilliseconds* ; - -C: GetQueuedCompletionStatusParams - -: wait-for-overlapped ( ms -- GetQueuedCompletionStatus-Params ret ) - >r master-completion-port get-global 0 0 0 - r> [ - GetQueuedCompletionStatusParams >tuple*< - GetQueuedCompletionStatus - ] keep swap ; +: wait-for-overlapped ( ms -- overlapped ? ) + >r master-completion-port get-global r> ! port ms + 0 ! bytes + f ! key + f ! overlapped + [ roll GetQueuedCompletionStatus ] keep *void* swap zero? ; : lookup-callback ( GetQueuedCompletion-args -- callback ) - GetQueuedCompletionStatusParams-lpOverlapped* *void* io-hash get-global delete-at* drop ; : wait-for-io ( timeout -- continuation/f ) - wait-for-overlapped - zero? [ - GetLastError dup (expected-io-error?) [ + wait-for-overlapped [ + GetLastError dup expected-io-error? [ 2drop f ] [ - dup ERROR_HANDLE_EOF = [ - drop lookup-callback [ - io-callback-port t swap set-port-eof? - ] keep io-callback-continuation + dup eof? [ + drop lookup-callback + dup io-callback-port t swap set-port-eof? + io-callback-continuation ] [ (win32-error-string) swap lookup-callback [ 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* ; M: windows-nt-io init-io ( -- ) - #! Should only be called on startup. Calling this at any - #! other time can have unintended consequences. - global [ - master-completion-port set - H{ } clone io-hash set - windows.winsock:init-winsock - ] bind ; + master-completion-port set-global + H{ } clone io-hash set-global + windows.winsock:init-winsock ; diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor new file mode 100755 index 0000000000..3ee0e05e32 --- /dev/null +++ b/extra/io/windows/nt/launcher/launcher.factor @@ -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 + + dup add-pipe-dtors + dup pipe-in f set-inherit + over set-CreateProcess-args-stdout-pipe ; + +: fill-stdin-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 + + swap dispose-CreateProcess-args + ] with-destructors + ] with-descriptor ; diff --git a/extra/io/windows/nt/pipes/pipes.factor b/extra/io/windows/nt/pipes/pipes.factor new file mode 100755 index 0000000000..a10a98bd30 --- /dev/null +++ b/extra/io/windows/nt/pipes/pipes.factor @@ -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" + "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 ; + +: ( 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 ; + +: ( name -- pipe ) + PIPE_ACCESS_INBOUND GENERIC_WRITE ; + +: ( name -- pipe ) + PIPE_ACCESS_DUPLEX GENERIC_READ ; + +: unique-pipe-name ( -- string ) + [ + "\\\\.\\pipe\\factor-" % + pipe counter # + "-" % + (random) # + "-" % + millis # + ] "" make ; + +: ( -- pipe ) + unique-pipe-name ; + +: ( -- pipe ) + unique-pipe-name ; diff --git a/extra/io/windows/windows-tests.factor b/extra/io/windows/windows-tests.factor deleted file mode 100755 index 4c090590df..0000000000 --- a/extra/io/windows/windows-tests.factor +++ /dev/null @@ -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 diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor index d9a9026d43..ac0ede0e06 100755 --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -20,6 +20,9 @@ TUPLE: win32-file handle ptr overlapped ; : ( handle ptr -- obj ) f win32-file construct-boa ; +: ( in out -- stream ) + >r f r> f handle>duplex-stream ; + HOOK: CreateFile-flags io-backend ( -- DWORD ) HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f ) HOOK: add-completion io-backend ( port -- ) diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor old mode 100644 new mode 100755 index 0322ed372f..3e1aa3ab53 --- a/extra/tools/deploy/shaker/shaker.factor +++ b/extra/tools/deploy/shaker/shaker.factor @@ -24,7 +24,6 @@ IN: tools.deploy.shaker "Stripping debugger" show "resource:extra/tools/deploy/shaker/strip-debugger.factor" run-file - do-parse-hook ] when ; : strip-libc ( -- ) @@ -32,7 +31,6 @@ IN: tools.deploy.shaker "Stripping manual memory management debug code" show "resource:extra/tools/deploy/shaker/strip-libc.factor" run-file - do-parse-hook ] when ; : strip-cocoa ( -- ) @@ -40,7 +38,6 @@ IN: tools.deploy.shaker "Stripping unused Cocoa methods" show "resource:extra/tools/deploy/shaker/strip-cocoa.factor" run-file - do-parse-hook ] when ; : strip-assoc ( retained-keys assoc -- newassoc ) @@ -116,7 +113,6 @@ SYMBOL: deploy-vocab strip-dictionary? [ { - builtins dictionary inspector-hook lexer-factory @@ -142,6 +138,10 @@ SYMBOL: deploy-vocab "c-types" "alien.c-types" lookup , ] when + native-io? [ + "default-buffer-size" "io.nonblocking" lookup , + ] when + deploy-ui? get [ "ui" child-vocabs "cocoa" child-vocabs @@ -152,10 +152,11 @@ SYMBOL: deploy-vocab ] when ] { } make dup . ; -: strip ( -- ) - strip-libc +: strip ( hook -- ) + >r strip-libc strip-cocoa strip-debugger + r> [ call ] when* strip-init-hooks deploy-vocab get vocab-main set-boot-quot* retained-props >r @@ -168,10 +169,9 @@ SYMBOL: deploy-vocab [ [ deploy-vocab set - parse-hook get >r + parse-hook get parse-hook off deploy-vocab get require - r> [ call ] when* strip finish-deploy ] [ diff --git a/extra/tools/deploy/shaker/strip-debugger.factor b/extra/tools/deploy/shaker/strip-debugger.factor old mode 100644 new mode 100755 diff --git a/extra/ui/gadgets/editors/editors-tests.factor b/extra/ui/gadgets/editors/editors-tests.factor index a38ca6044e..6be0423e95 100755 --- a/extra/ui/gadgets/editors/editors-tests.factor +++ b/extra/ui/gadgets/editors/editors-tests.factor @@ -1,7 +1,7 @@ USING: ui.gadgets.editors tools.test kernel io io.streams.plain definitions namespaces ui.gadgets ui.gadgets.grids prettyprint documents ui.gestures -tools.test.inference tools.test.ui ; +tools.test.inference tools.test.ui models ; [ "foo bar" ] [ "editor" set @@ -31,3 +31,9 @@ tools.test.inference tools.test.ui ; ] unit-test { 0 1 } [ ] unit-test-effect + +"hello" "field" set + +"field" get [ + [ "hello" ] [ "field" get field-model model-value ] unit-test +] with-grafted-gadget diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index 9929cece29..7dd12cb610 100755 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -70,8 +70,12 @@ M: gadget model-changed 2drop ; >r r> construct-delegate ; inline : activate-control ( gadget -- ) - dup gadget-model dup [ 2dup add-connection ] when drop - dup gadget-model swap model-changed ; + dup gadget-model dup [ + 2dup add-connection + swap model-changed + ] [ + 2drop + ] if ; : deactivate-control ( gadget -- ) dup gadget-model dup [ 2dup remove-connection ] when 2drop ; diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor index cd77dc0a98..d4e3770f7b 100755 --- a/extra/ui/windows/windows.factor +++ b/extra/ui/windows/windows.factor @@ -280,10 +280,13 @@ SYMBOL: hWnd mouse-captured? [ release-capture ] when prepare-mouse send-button-up ; +: make-TRACKMOUSEEVENT ( hWnd -- alien ) + "TRACKMOUSEEVENT" [ set-TRACKMOUSEEVENT-hwndTrack ] keep + "TRACKMOUSEEVENT" heap-size over set-TRACKMOUSEEVENT-cbSize ; + : handle-wm-mousemove ( hWnd uMsg wParam lParam -- ) 2nip - over "TRACKMOUSEEVENT" [ set-TRACKMOUSEEVENT-hwndTrack ] keep - "TRACKMOUSEEVENT" heap-size over set-TRACKMOUSEEVENT-cbSize + over make-TRACKMOUSEEVENT TME_LEAVE over set-TRACKMOUSEEVENT-dwFlags 0 over set-TRACKMOUSEEVENT-dwHoverTime TrackMouseEvent drop @@ -387,10 +390,10 @@ SYMBOL: hWnd dup SetForegroundWindow drop SetFocus drop ; -: init-win32-ui +: init-win32-ui ( -- ) "MSG" msg-obj set "Factor-window" malloc-u16-string class-name-ptr set-global - register-wndclassex + register-wndclassex drop GetDoubleClickTime double-click-timeout set-global ; : cleanup-win32-ui ( -- ) diff --git a/extra/windows/errors/errors.factor b/extra/windows/errors/errors.factor old mode 100644 new mode 100755 index b0a59726fc..2e4e709d43 --- a/extra/windows/errors/errors.factor +++ b/extra/windows/errors/errors.factor @@ -3,6 +3,7 @@ IN: windows.errors : ERROR_SUCCESS 0 ; inline : ERROR_HANDLE_EOF 38 ; inline +: ERROR_BROKEN_PIPE 109 ; inline : ERROR_IO_INCOMPLETE 996 ; inline : ERROR_IO_PENDING 997 ; inline diff --git a/extra/windows/windows.factor b/extra/windows/windows.factor old mode 100644 new mode 100755 index ade102517c..657a8e8a7c --- a/extra/windows/windows.factor +++ b/extra/windows/windows.factor @@ -39,30 +39,21 @@ FUNCTION: void* error_message ( DWORD id ) ; win32-error-string throw ] when ; -: (expected-io-error?) ( error-code -- ? ) +: expected-io-errors ERROR_SUCCESS ERROR_IO_INCOMPLETE ERROR_IO_PENDING - WAIT_TIMEOUT 4array member? ; + WAIT_TIMEOUT 4array ; foldable -: expected-io-error? ( error-code -- ) - dup (expected-io-error?) [ +: expected-io-error? ( error-code -- ? ) + expected-io-errors member? ; + +: expected-io-error ( error-code -- ) + dup expected-io-error? [ drop ] [ (win32-error-string) throw ] if ; : io-error ( return-value -- ) - { 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 ; + { 0 f } member? [ GetLastError expected-io-error ] when ;