From e7cc5ea6d4656c0422309d900f224eb2bde01390 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 21 Nov 2007 01:18:46 -0500 Subject: [PATCH 01/12] Windows IO fixes and work --- extra/io/launcher/launcher.factor | 1 + extra/io/windows/ce/backend/backend.factor | 8 +- extra/io/windows/ce/files/files.factor | 12 +- extra/io/windows/launcher/launcher.factor | 143 ++----------------- extra/io/windows/mmap/mmap.factor | 2 +- extra/io/windows/nt/backend/backend.factor | 83 ++++++----- extra/io/windows/nt/launcher/launcher.factor | 64 +++++++++ extra/io/windows/nt/pipes/pipes.factor | 72 ++++++++++ extra/io/windows/windows.factor | 3 + 9 files changed, 205 insertions(+), 183 deletions(-) mode change 100644 => 100755 extra/io/launcher/launcher.factor create mode 100755 extra/io/windows/nt/launcher/launcher.factor create mode 100755 extra/io/windows/nt/pipes/pipes.factor 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..2d70085165 --- /dev/null +++ b/extra/io/windows/nt/pipes/pipes.factor @@ -0,0 +1,72 @@ +! 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 + +: 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.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 -- ) From 52c3db354b0af2a3e4f8115b1ee07ab1e958c3c9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 21 Nov 2007 01:26:15 -0500 Subject: [PATCH 02/12] Windows code updates --- extra/io/windows/windows-tests.factor | 16 ---------------- extra/windows/errors/errors.factor | 1 + extra/windows/windows.factor | 25 ++++++++----------------- 3 files changed, 9 insertions(+), 33 deletions(-) delete mode 100755 extra/io/windows/windows-tests.factor mode change 100644 => 100755 extra/windows/errors/errors.factor mode change 100644 => 100755 extra/windows/windows.factor 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/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 ; From 48026c7d8dab88b296e32180f8d4d6206fbcc4ed Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 21 Nov 2007 03:13:23 -0500 Subject: [PATCH 03/12] Improve sequence hash algorithm --- core/combinators/combinators.factor | 4 +--- core/sequences/sequences.factor | 7 ++++++- core/strings/strings.factor | 3 +-- 3 files changed, 8 insertions(+), 6 deletions(-) mode change 100644 => 100755 core/combinators/combinators.factor mode change 100644 => 100755 core/strings/strings.factor 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/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> From be9bc3115f785df818383733721e8d0cc62c3229 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 21 Nov 2007 03:17:24 -0500 Subject: [PATCH 04/12] Add init hook for callbacks hash --- core/alien/c-types/c-types.factor | 0 core/alien/compiler/compiler.factor | 5 +++-- 2 files changed, 3 insertions(+), 2 deletions(-) mode change 100644 => 100755 core/alien/c-types/c-types.factor 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 ; From cb198f907eb8e3c823653f23b868d5efd4fc4982 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 21 Nov 2007 03:18:28 -0500 Subject: [PATCH 05/12] Add attribution --- extra/io/windows/nt/pipes/pipes.factor | 3 +++ 1 file changed, 3 insertions(+) diff --git a/extra/io/windows/nt/pipes/pipes.factor b/extra/io/windows/nt/pipes/pipes.factor index 2d70085165..a10a98bd30 100755 --- a/extra/io/windows/nt/pipes/pipes.factor +++ b/extra/io/windows/nt/pipes/pipes.factor @@ -5,6 +5,9 @@ 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 ; From 32da4e364cd6a64a243e5661ab88f5399a51e607 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 21 Nov 2007 03:19:06 -0500 Subject: [PATCH 06/12] Deployment fixes for Windows --- extra/tools/deploy/deploy.factor | 2 +- extra/tools/deploy/shaker/shaker.factor | 16 ++++++++-------- extra/tools/deploy/shaker/strip-debugger.factor | 0 3 files changed, 9 insertions(+), 9 deletions(-) mode change 100644 => 100755 extra/tools/deploy/shaker/shaker.factor mode change 100644 => 100755 extra/tools/deploy/shaker/strip-debugger.factor diff --git a/extra/tools/deploy/deploy.factor b/extra/tools/deploy/deploy.factor index 7c0dabc458..1b05412227 100755 --- a/extra/tools/deploy/deploy.factor +++ b/extra/tools/deploy/deploy.factor @@ -54,7 +54,7 @@ IN: tools.deploy "\"-output-image=" swap "\"" 3append , - "-no-stack-traces" , + ! "-no-stack-traces" , "-no-user-init" , ] { } make ; 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 From 25de6273b391d9b915cf4a0ea080ef1c18120c97 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 21 Nov 2007 03:20:32 -0500 Subject: [PATCH 07/12] Fix editors --- extra/ui/gadgets/editors/editors-tests.factor | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) 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 From 555e2c9964347129b12438eea1c79bbad21c5df7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 21 Nov 2007 03:21:26 -0500 Subject: [PATCH 08/12] Fix activate-control --- extra/ui/gadgets/gadgets.factor | 8 ++++-- .../ui/gadgets/incremental/incremental.factor | 25 +++++++++++-------- 2 files changed, 20 insertions(+), 13 deletions(-) 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/gadgets/incremental/incremental.factor b/extra/ui/gadgets/incremental/incremental.factor index a5c7431d36..3e068ead45 100755 --- a/extra/ui/gadgets/incremental/incremental.factor +++ b/extra/ui/gadgets/incremental/incremental.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io kernel math namespaces math.vectors ui.gadgets ; +USING: io kernel math namespaces math.vectors ui.gadgets +dlists ; IN: ui.gadgets.incremental ! Incremental layout allows adding lines to panes to be O(1). @@ -14,12 +15,14 @@ IN: ui.gadgets.incremental ! New gadgets are added at ! incremental-cursor gadget-orientation v* -TUPLE: incremental cursor ; +TUPLE: incremental cursor queue ; : ( pack -- incremental ) - dup pref-dim - { set-gadget-delegate set-incremental-cursor } - incremental construct ; + dup pref-dim { + set-gadget-delegate + set-incremental-cursor + set-incremental-queue + } incremental construct ; M: incremental pref-dim* dup gadget-layout-state [ @@ -40,17 +43,17 @@ M: incremental pref-dim* swap set-rect-loc ; : prefer-incremental ( gadget -- ) - dup forget-pref-dim dup pref-dim over set-rect-dim - layout ; + dup forget-pref-dim dup pref-dim swap set-rect-dim ; : add-incremental ( gadget incremental -- ) not-in-layout - 2dup (add-gadget) - over prefer-incremental + 2dup incremental-queue push-front + add-gadget ; + +: (add-incremental) ( gadget incremental -- ) 2dup incremental-loc tuck update-cursor - dup prefer-incremental - gadget-parent [ invalidate* ] when* ; + prefer-incremental ; : clear-incremental ( incremental -- ) not-in-layout From 2ace9adafbd4bfe212b34cfb026f4c319c48d835 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 21 Nov 2007 03:21:41 -0500 Subject: [PATCH 09/12] Fix deployment of ui.windows --- extra/ui/windows/windows.factor | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) 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 ( -- ) From 0c57b8e08680a06b49f8cbd2bda4319f89f0e01a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 21 Nov 2007 03:26:13 -0500 Subject: [PATCH 10/12] Remove debug --- extra/tools/deploy/deploy.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/tools/deploy/deploy.factor b/extra/tools/deploy/deploy.factor index 1b05412227..7c0dabc458 100755 --- a/extra/tools/deploy/deploy.factor +++ b/extra/tools/deploy/deploy.factor @@ -54,7 +54,7 @@ IN: tools.deploy "\"-output-image=" swap "\"" 3append , - ! "-no-stack-traces" , + "-no-stack-traces" , "-no-user-init" , ] { } make ; From a552625ee3eddfeef5dccb64440ecc09dbdb715c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 21 Nov 2007 03:39:34 -0500 Subject: [PATCH 11/12] Fix stream-read-partial on a line-reader --- core/io/io.factor | 0 core/io/streams/lines/lines-tests.factor | 8 ++++++++ core/io/streams/lines/lines.factor | 23 +++++++++++++++++------ 3 files changed, 25 insertions(+), 6 deletions(-) mode change 100644 => 100755 core/io/io.factor mode change 100644 => 100755 core/io/streams/lines/lines-tests.factor mode change 100644 => 100755 core/io/streams/lines/lines.factor 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 ; From 0714bb7a86352fd76ecd8a752c962e05fd6dd7f0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 21 Nov 2007 04:19:50 -0500 Subject: [PATCH 12/12] Revert incomplete changes --- .../ui/gadgets/incremental/incremental.factor | 25 ++++++++----------- 1 file changed, 11 insertions(+), 14 deletions(-) diff --git a/extra/ui/gadgets/incremental/incremental.factor b/extra/ui/gadgets/incremental/incremental.factor index 3e068ead45..a5c7431d36 100755 --- a/extra/ui/gadgets/incremental/incremental.factor +++ b/extra/ui/gadgets/incremental/incremental.factor @@ -1,7 +1,6 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io kernel math namespaces math.vectors ui.gadgets -dlists ; +USING: io kernel math namespaces math.vectors ui.gadgets ; IN: ui.gadgets.incremental ! Incremental layout allows adding lines to panes to be O(1). @@ -15,14 +14,12 @@ IN: ui.gadgets.incremental ! New gadgets are added at ! incremental-cursor gadget-orientation v* -TUPLE: incremental cursor queue ; +TUPLE: incremental cursor ; : ( pack -- incremental ) - dup pref-dim { - set-gadget-delegate - set-incremental-cursor - set-incremental-queue - } incremental construct ; + dup pref-dim + { set-gadget-delegate set-incremental-cursor } + incremental construct ; M: incremental pref-dim* dup gadget-layout-state [ @@ -43,17 +40,17 @@ M: incremental pref-dim* swap set-rect-loc ; : prefer-incremental ( gadget -- ) - dup forget-pref-dim dup pref-dim swap set-rect-dim ; + dup forget-pref-dim dup pref-dim over set-rect-dim + layout ; : add-incremental ( gadget incremental -- ) not-in-layout - 2dup incremental-queue push-front - add-gadget ; - -: (add-incremental) ( gadget incremental -- ) + 2dup (add-gadget) + over prefer-incremental 2dup incremental-loc tuck update-cursor - prefer-incremental ; + dup prefer-incremental + gadget-parent [ invalidate* ] when* ; : clear-incremental ( incremental -- ) not-in-layout