From bc5bc22072f8c1833e82f4631c8ef601e972a183 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 23 Jan 2008 06:31:30 -0400 Subject: [PATCH 01/10] Better dlists behavior --- core/dlists/dlists.factor | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/core/dlists/dlists.factor b/core/dlists/dlists.factor index a3c869efaf..84d68b28aa 100755 --- a/core/dlists/dlists.factor +++ b/core/dlists/dlists.factor @@ -78,7 +78,8 @@ PRIVATE> : pop-front ( dlist -- obj ) dup dlist-front [ - dlist-node-next + dup dlist-node-next + f rot set-dlist-node-next f over set-prev-when swap set-dlist-front ] 2keep dlist-node-obj @@ -87,13 +88,13 @@ PRIVATE> : pop-front* ( dlist -- ) pop-front drop ; : pop-back ( dlist -- obj ) - [ - dlist-back dup dlist-node-prev f over set-next-when - ] keep - [ set-dlist-back ] keep - [ normalize-front ] keep - dec-length - dlist-node-obj ; + dup dlist-back [ + dup dlist-node-prev + f rot set-dlist-node-prev + f over set-next-when + swap set-dlist-back + ] 2keep dlist-node-obj + swap [ normalize-front ] keep dec-length ; : pop-back* ( dlist -- ) pop-back drop ; From 83d6e10ac030d98f65284b71b373f04ae0d867ed Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 23 Jan 2008 06:32:51 -0400 Subject: [PATCH 02/10] Fix resolver on FreeBSD --- extra/io/sockets/impl/impl.factor | 33 ++++++++++++++++++++----------- 1 file changed, 22 insertions(+), 11 deletions(-) diff --git a/extra/io/sockets/impl/impl.factor b/extra/io/sockets/impl/impl.factor index e490b9312b..e8ab957482 100755 --- a/extra/io/sockets/impl/impl.factor +++ b/extra/io/sockets/impl/impl.factor @@ -51,10 +51,13 @@ M: inet4 make-sockaddr ( inet -- sockaddr ) "0.0.0.0" or rot inet-pton *uint over set-sockaddr-in-addr ; +SYMBOL: port-override + +: (port) port-override get [ ] [ ] ?if ; + M: inet4 parse-sockaddr >r dup sockaddr-in-addr r> inet-ntop - swap sockaddr-in-port ntohs ; - + swap sockaddr-in-port ntohs (port) ; M: inet6 inet-ntop ( data addrspec -- str ) drop 16 memory>string 2 [ be> >hex ] map ":" join ; @@ -80,7 +83,7 @@ M: inet6 make-sockaddr ( inet -- sockaddr ) M: inet6 parse-sockaddr >r dup sockaddr-in6-addr r> inet-ntop - swap sockaddr-in6-port ntohs ; + swap sockaddr-in6-port ntohs (port) ; : addrspec-of-family ( af -- addrspec ) { @@ -102,15 +105,23 @@ M: f parse-sockaddr nip ; [ dup addrinfo-next swap addrinfo>addrspec ] [ ] unfold nip [ ] subset ; +: prepare-resolve-host ( host serv passive? -- host' serv' flags ) + >r + >r string>char-alien r> + dup integer? [ port-override set f ] [ string>char-alien ] if + r> AI_PASSIVE 0 ? ; + M: object resolve-host ( host serv passive? -- seq ) - >r dup integer? [ number>string ] when - "addrinfo" - r> [ AI_PASSIVE over set-addrinfo-flags ] when - PF_UNSPEC over set-addrinfo-family - IPPROTO_TCP over set-addrinfo-protocol - f [ getaddrinfo addrinfo-error ] keep *void* - [ parse-addrinfo-list ] keep - freeaddrinfo ; + [ + prepare-resolve-host + "addrinfo" + [ set-addrinfo-flags ] keep + PF_UNSPEC over set-addrinfo-family + IPPROTO_TCP over set-addrinfo-protocol + f [ getaddrinfo addrinfo-error ] keep *void* + [ parse-addrinfo-list ] keep + freeaddrinfo + ] with-scope ; M: object host-name ( -- name ) 256 dup dup length gethostname From ecc0170afab550777f005235e24a8d2deeb1f878 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 24 Jan 2008 03:20:05 -0400 Subject: [PATCH 03/10] Forgetting a word clears compiled usage --- core/compiler/compiler.factor | 17 +---------------- core/compiler/test/redefine.factor | 11 ++++++++++- core/words/words.factor | 20 ++++++++++++++++++++ 3 files changed, 31 insertions(+), 17 deletions(-) diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index 784104d57f..8d9f004270 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -7,21 +7,6 @@ optimizer definitions math compiler.errors threads graphs generic ; IN: compiler -SYMBOL: compiled-crossref - -compiled-crossref global [ H{ } assoc-like ] change-at - -: compiled-xref ( word dependencies -- ) - 2dup "compiled-uses" set-word-prop - compiled-crossref get add-vertex* ; - -: compiled-unxref ( word -- ) - dup "compiled-uses" word-prop - compiled-crossref get remove-vertex* ; - -: compiled-usage ( word -- assoc ) - compiled-crossref get at ; - : compiled-usages ( words -- seq ) [ [ dup ] H{ } map>assoc dup ] keep [ compiled-usage [ nip +inlined+ eq? ] assoc-subset update @@ -41,7 +26,7 @@ compiled-crossref global [ H{ } assoc-like ] change-at >r dupd save-effect r> f pick compiler-error over compiled-unxref - compiled-xref ; + over word-vocabulary [ compiled-xref ] [ 2drop ] if ; : compile-succeeded ( word -- effect dependencies ) [ diff --git a/core/compiler/test/redefine.factor b/core/compiler/test/redefine.factor index 718e98c9c2..266b331ffc 100755 --- a/core/compiler/test/redefine.factor +++ b/core/compiler/test/redefine.factor @@ -1,6 +1,6 @@ USING: compiler definitions generic assocs inference math namespaces parser tools.test words kernel sequences arrays io -effects tools.test.inference compiler.units ; +effects tools.test.inference compiler.units inference.state ; IN: temporary DEFER: x-1 @@ -206,12 +206,15 @@ DEFER: generic-then-not-generic-test-2 [ 4 ] [ generic-then-not-generic-test-2 ] unit-test +DEFER: foldable-test-1 DEFER: foldable-test-2 [ ] [ "IN: temporary : foldable-test-1 3 ; foldable" eval ] unit-test [ ] [ "IN: temporary : foldable-test-2 foldable-test-1 ;" eval ] unit-test +[ +inlined+ ] [ \ foldable-test-2 \ foldable-test-1 compiled-usage at ] unit-test + [ 3 ] [ foldable-test-2 ] unit-test [ ] [ "IN: temporary : foldable-test-1 4 ; foldable" eval ] unit-test @@ -229,3 +232,9 @@ DEFER: flushable-test-2 [ ] [ "IN: temporary USING: kernel sequences ; : flushable-test-1 3 over push ;" eval ] unit-test [ V{ 3 } ] [ flushable-test-2 ] unit-test + +: ax ; +: bx ax ; +[ \ bx forget ] with-compilation-unit + +[ t ] [ \ ax compiled-usage [ drop interned? ] assoc-all? ] unit-test diff --git a/core/words/words.factor b/core/words/words.factor index 6d8bad4f9e..5dc89212a8 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -87,6 +87,25 @@ M: wrapper (quot-uses) >r wrapped r> (quot-uses) ; M: word uses ( word -- seq ) word-def quot-uses keys ; +SYMBOL: compiled-crossref + +compiled-crossref global [ H{ } assoc-like ] change-at + +: compiled-xref ( word dependencies -- ) + 2dup "compiled-uses" set-word-prop + compiled-crossref get add-vertex* ; + +: compiled-unxref ( word -- ) + dup "compiled-uses" word-prop + compiled-crossref get remove-vertex* ; + +: delete-compiled-xref ( word -- ) + dup compiled-unxref + compiled-crossref get delete-at ; + +: compiled-usage ( word -- assoc ) + compiled-crossref get at ; + M: word redefined* ( word -- ) { "inferred-effect" "base-case" "no-effect" } reset-props ; @@ -187,6 +206,7 @@ M: word (forget-word) : forget-word ( word -- ) dup delete-xref + dup delete-compiled-xref (forget-word) ; M: word forget* forget-word ; From af915caaa358ba74282f1f42997b206517723864 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 24 Jan 2008 03:27:15 -0400 Subject: [PATCH 04/10] Add wait-for-process word to io.launcher; run-process and run-detached now return process tuples --- extra/io/launcher/launcher-docs.factor | 40 +++++++++--- extra/io/launcher/launcher.factor | 43 ++++++++++--- extra/io/windows/launcher/launcher.factor | 66 +++++++++++++++----- extra/io/windows/nt/launcher/launcher.factor | 2 +- extra/windows/kernel32/kernel32.factor | 4 +- 5 files changed, 118 insertions(+), 37 deletions(-) diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor index 7ad5e064bf..2c30431714 100755 --- a/extra/io/launcher/launcher-docs.factor +++ b/extra/io/launcher/launcher-docs.factor @@ -1,6 +1,6 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax quotations kernel ; +USING: help.markup help.syntax quotations kernel io math ; IN: io.launcher HELP: +command+ @@ -58,7 +58,7 @@ HELP: get-environment { $description "Combines the current environment with the value of " { $link +environment+ } " using " { $link +environment-mode+ } "." } ; HELP: run-process* -{ $values { "desc" "a launch descriptor" } } +{ $values { "desc" "a launch descriptor" } { "handle" "a process handle" } } { $contract "Launches a process using the launch descriptor." } { $notes "User code should call " { $link run-process } " instead." } ; @@ -73,22 +73,41 @@ HELP: >descriptor } ; HELP: run-process -{ $values { "obj" object } } -{ $contract "Launches a process. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link >descriptor } " for details." } ; +{ $values { "obj" object } { "process" process } } +{ $description "Launches a process. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link >descriptor } " for details." } +{ $notes "The output value can be passed to " { $link wait-for-process } " to get an exit code." } ; HELP: run-detached -{ $values { "obj" object } } +{ $values { "obj" object } { "process" process } } { $contract "Launches a process without waiting for it to complete. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link >descriptor } " for details." } { $notes "This word is functionally identical to passing a launch descriptor to " { $link run-process } " having the " { $link +detached+ } " key set." + $nl + "The output value can be passed to " { $link wait-for-process } " to get an exit code." } ; +HELP: process +{ $class-description "A class representing an active or finished process." +$nl +"Processes are output by " { $link run-process } " and " { $link run-detached } ", and are stored in the " { $link process-stream-process } " slot of " { $link process-stream } " instances." +$nl +"Processes can be passed to " { $link wait-for-process } "." } ; + +HELP: process-stream +{ $class-description "A bidirectional stream for interacting with a running process. Instances are created by calling " { $link } ". The " { $link process-stream-process } " slot holds a " { $link process } " instance." } ; + HELP: { $values { "obj" object } { "stream" "a bidirectional stream" } } { $description "Launches a process and redirects its input and output via a pair of pipes which may be read and written as a stream." } { $notes "Closing the stream will block until the process exits." } ; -{ run-process run-detached } related-words +HELP: with-process-stream +{ $values { "obj" object } { "quot" quotation } { "process" process } } +{ $description "Calls " { $snippet "quot" } " in a dynamic scope where " { $link stdio } " is rebound to a " { $link process-stream } ". When the quotation returns, the " { $link process } " instance is output." } ; + +HELP: wait-for-process +{ $values { "process" process } { "status" integer } } +{ $description "If the process is still running, waits for it to exit, otherwise outputs the exit code immediately. Can be called multiple times on the same process." } ; ARTICLE: "io.launcher" "Launching OS processes" "The " { $vocab-link "io.launcher" } " vocabulary implements cross-platform process launching." @@ -108,6 +127,11 @@ $nl "The following words are used to launch processes:" { $subsection run-process } { $subsection run-detached } -{ $subsection } ; +{ $subsection } +{ $subsection with-process-stream } +"A class representing an active or finished process:" +{ $subsection process } +"Waiting for a process to end, or getting the exit code of a finished process:" +{ $subsection wait-for-process } ; ABOUT: "io.launcher" diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index 806b56a092..decf4f3434 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -1,9 +1,17 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io.backend system kernel namespaces strings hashtables +USING: io io.backend system kernel namespaces strings hashtables sequences assocs combinators vocabs.loader ; IN: io.launcher +TUPLE: process handle status ; + +: ( handle -- process ) f process construct-boa ; + +M: process equal? 2drop f ; + +M: process hashcode* process-handle hashcode* ; + SYMBOL: +command+ SYMBOL: +arguments+ SYMBOL: +detached+ @@ -44,15 +52,32 @@ M: string >descriptor +command+ associate ; M: sequence >descriptor +arguments+ associate ; M: assoc >descriptor ; -HOOK: run-process* io-backend ( desc -- ) +HOOK: run-process* io-backend ( desc -- handle ) -: run-process ( obj -- ) - >descriptor run-process* ; +HOOK: wait-for-process* io-backend ( process -- ) -: run-detached ( obj -- ) - >descriptor H{ { +detached+ t } } union run-process* ; +: wait-for-process ( process -- status ) + dup process-handle [ dup wait-for-process* ] when + process-status ; -HOOK: process-stream* io-backend ( desc -- stream ) +: run-process ( obj -- process ) + >descriptor + dup run-process* + +detached+ rot at [ dup wait-for-process drop ] unless ; + +: run-detached ( obj -- process ) + >descriptor H{ { +detached+ t } } union run-process ; + +HOOK: process-stream* io-backend ( desc -- stream process ) + +TUPLE: process-stream process ; : ( obj -- stream ) - >descriptor process-stream* ; + >descriptor process-stream* + { set-delegate set-process-stream-process } + process-stream construct ; + +: with-process-stream ( obj quot -- process ) + swap + [ swap with-stream ] keep + process-stream-process ; inline diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index 136c8197fc..603fa2a638 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -1,11 +1,19 @@ -! Copyright (C) 2007 Doug Coleman, Slava Pestov. +! Copyright (C) 2007, 2008 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 ; +sequences windows.errors assocs splitting system threads init ; IN: io.windows.launcher +SYMBOL: processes + +[ H{ } clone processes set-global ] +"io.windows.launcher" add-init-hook + +: ( handle -- process ) + V{ } clone over processes get set-at ; + TUPLE: CreateProcess-args lpApplicationName lpCommandLine @@ -19,13 +27,6 @@ TUPLE: CreateProcess-args lpProcessInformation 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* ; - : default-CreateProcess-args ( -- obj ) 0 0 @@ -93,21 +94,52 @@ TUPLE: CreateProcess-args over set-CreateProcess-args-lpEnvironment ] when ; -: wait-for-process ( args -- ) - CreateProcess-args-lpProcessInformation - 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 -- ) +M: windows-io run-process* ( desc -- handle ) [ make-CreateProcess-args dup call-CreateProcess - +detached+ get [ dup wait-for-process ] unless - dispose-CreateProcess-args + CreateProcess-args-lpProcessInformation ] with-descriptor ; + +M: windows-io wait-for-process* + [ processes get at push stop ] curry callcc0 ; + +: dispose-process ( process-information -- ) + #! From MSDN: "Handles in PROCESS_INFORMATION must be closed + #! with CloseHandle when they are no longer needed." + dup PROCESS_INFORMATION-hProcess [ CloseHandle drop ] when* + PROCESS_INFORMATION-hThread [ CloseHandle drop ] when* ; + +: exit-code ( process -- n ) + PROCESS_INFORMATION-hProcess + 0 [ GetExitCodeProcess ] keep *ulong + swap win32-error=0/f ; + +: notify-exit ( process -- ) + dup process-handle exit-code over set-process-status + dup process-handle dispose-process + dup processes get delete-at* drop [ schedule-thread ] each + f swap set-process-handle ; + +: wait-for-processes ( processes -- ? ) + keys dup + [ process-handle PROCESS_INFORMATION-hProcess ] map + dup length swap >c-void*-array 0 0 + WaitForMultipleObjects + dup HEX: ffffffff = [ win32-error ] when + dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth notify-exit f ] if ; + +: wait-loop ( -- ) + processes get dup assoc-empty? + [ drop t ] [ wait-for-processes ] if + [ 250 sleep ] when + wait-loop ; + +: start-wait-thread ( -- ) + [ wait-loop ] in-thread ; diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor index 3ee0e05e32..6e788003ea 100755 --- a/extra/io/windows/nt/launcher/launcher.factor +++ b/extra/io/windows/nt/launcher/launcher.factor @@ -59,6 +59,6 @@ M: windows-io process-stream* dup CreateProcess-args-stdout-pipe pipe-in over CreateProcess-args-stdin-pipe pipe-out - swap dispose-CreateProcess-args + swap CreateProcess-args-lpProcessInformation ] with-destructors ] with-descriptor ; diff --git a/extra/windows/kernel32/kernel32.factor b/extra/windows/kernel32/kernel32.factor index 5e0f4ddc65..1c75e33698 100755 --- a/extra/windows/kernel32/kernel32.factor +++ b/extra/windows/kernel32/kernel32.factor @@ -898,7 +898,7 @@ FUNCTION: HANDLE GetCurrentThread ( ) ; ! FUNCTION: GetEnvironmentStringsW ! FUNCTION: GetEnvironmentVariableA ! FUNCTION: GetEnvironmentVariableW -! FUNCTION: GetExitCodeProcess +FUNCTION: BOOL GetExitCodeProcess ( HANDLE hProcess, LPDWORD lpExitCode ) ; ! FUNCTION: GetExitCodeThread ! FUNCTION: GetExpandedNameA ! FUNCTION: GetExpandedNameW @@ -1496,7 +1496,7 @@ FUNCTION: BOOL VirtualQueryEx ( HANDLE hProcess, void* lpAddress, MEMORY_BASIC_I ! FUNCTION: VirtualUnlock ! FUNCTION: WaitCommEvent ! FUNCTION: WaitForDebugEvent -! FUNCTION: WaitForMultipleObjects +FUNCTION: DWORD WaitForMultipleObjects ( DWORD nCount, HANDLE* lpHandles, BOOL bWaitAll, DWORD dwMilliseconds ) ; ! FUNCTION: WaitForMultipleObjectsEx FUNCTION: BOOL WaitForSingleObject ( HANDLE hHandle, DWORD dwMilliseconds ) ; ! FUNCTION: WaitForSingleObjectEx From d621b9852eb6ab3c2127da859f3ef4875c525942 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 24 Jan 2008 03:50:40 -0400 Subject: [PATCH 05/10] Updating extra/ for launcher changes --- extra/editors/editpadpro/editpadpro.factor | 4 +++- extra/editors/editplus/editplus.factor | 4 ++-- extra/editors/emacs/emacs.factor | 7 +++++-- extra/editors/emeditor/emeditor.factor | 5 ++--- extra/editors/notepadpp/notepadpp.factor | 5 +++-- extra/editors/scite/scite.factor | 13 ++++++------- extra/editors/ted-notepad/ted-notepad.factor | 5 ++--- extra/editors/textmate/textmate.factor | 3 ++- extra/editors/ultraedit/ultraedit.factor | 4 ++-- extra/editors/vim/vim.factor | 8 +++++--- extra/editors/wordpad/wordpad.factor | 4 +--- extra/tools/deploy/macosx/macosx.factor | 4 ++-- 12 files changed, 35 insertions(+), 31 deletions(-) mode change 100644 => 100755 extra/editors/editpadpro/editpadpro.factor mode change 100644 => 100755 extra/editors/emacs/emacs.factor mode change 100644 => 100755 extra/editors/notepadpp/notepadpp.factor mode change 100644 => 100755 extra/editors/scite/scite.factor mode change 100644 => 100755 extra/editors/ted-notepad/ted-notepad.factor mode change 100644 => 100755 extra/editors/textmate/textmate.factor mode change 100644 => 100755 extra/editors/ultraedit/ultraedit.factor mode change 100644 => 100755 extra/editors/vim/vim.factor mode change 100644 => 100755 extra/editors/wordpad/wordpad.factor diff --git a/extra/editors/editpadpro/editpadpro.factor b/extra/editors/editpadpro/editpadpro.factor old mode 100644 new mode 100755 index 69a9e2badd..885349e27b --- a/extra/editors/editpadpro/editpadpro.factor +++ b/extra/editors/editpadpro/editpadpro.factor @@ -10,6 +10,8 @@ IN: editors.editpadpro ] unless* ; : editpadpro ( file line -- ) - [ editpadpro-path % " /l" % # " \"" % % "\"" % ] "" make run-detached ; + [ + editpadpro-path , "/l" swap number>string append , , + ] { } make run-detached drop ; [ editpadpro ] edit-hook set-global diff --git a/extra/editors/editplus/editplus.factor b/extra/editors/editplus/editplus.factor index bff523b50d..feaa177954 100755 --- a/extra/editors/editplus/editplus.factor +++ b/extra/editors/editplus/editplus.factor @@ -9,7 +9,7 @@ IN: editors.editplus : editplus ( file line -- ) [ - editplus-path % " -cursor " % # " " % % - ] "" make run-detached ; + editplus-path , "-cursor" , number>string , , + ] { } make run-detached drop ; [ editplus ] edit-hook set-global diff --git a/extra/editors/emacs/emacs.factor b/extra/editors/emacs/emacs.factor old mode 100644 new mode 100755 index e131179755..31e0761043 --- a/extra/editors/emacs/emacs.factor +++ b/extra/editors/emacs/emacs.factor @@ -4,8 +4,11 @@ IN: editors.emacs : emacsclient ( file line -- ) [ - "emacsclient --no-wait +" % # " " % % - ] "" make run-process ; + "emacsclient" , + "--no-wait" , + "+" swap number>string append , + , + ] { } make run-process drop ; : emacs ( word -- ) where first2 emacsclient ; diff --git a/extra/editors/emeditor/emeditor.factor b/extra/editors/emeditor/emeditor.factor index 2caa42b480..bed333694c 100755 --- a/extra/editors/emeditor/emeditor.factor +++ b/extra/editors/emeditor/emeditor.factor @@ -9,8 +9,7 @@ IN: editors.emeditor : emeditor ( file line -- ) [ - emeditor-path % " /l " % # - " " % "\"" % % "\"" % - ] "" make run-detached ; + emeditor-path , "/l" , number>string , , + ] { } make run-detached drop ; [ emeditor ] edit-hook set-global diff --git a/extra/editors/notepadpp/notepadpp.factor b/extra/editors/notepadpp/notepadpp.factor old mode 100644 new mode 100755 index 4f3fde917d..f9fa95f175 --- a/extra/editors/notepadpp/notepadpp.factor +++ b/extra/editors/notepadpp/notepadpp.factor @@ -9,7 +9,8 @@ IN: editors.notepadpp : notepadpp ( file line -- ) [ - notepadpp-path % " -n" % # " " % % - ] "" make run-detached ; + notepadpp-path , + "-n" swap number>string append , , + ] "" make run-detached drop ; [ notepadpp ] edit-hook set-global diff --git a/extra/editors/scite/scite.factor b/extra/editors/scite/scite.factor old mode 100644 new mode 100755 index 529d11b722..bc9a98a051 --- a/extra/editors/scite/scite.factor +++ b/extra/editors/scite/scite.factor @@ -18,14 +18,13 @@ SYMBOL: scite-path : scite-command ( file line -- cmd ) swap - [ scite-path get % - " \"" % - % - "\" -goto:" % - # - ] "" make ; + [ + scite-path get , + , + "-goto:" swap number>string append , + ] { } make ; : scite-location ( file line -- ) - scite-command run-detached ; + scite-command run-detached drop ; [ scite-location ] edit-hook set-global diff --git a/extra/editors/ted-notepad/ted-notepad.factor b/extra/editors/ted-notepad/ted-notepad.factor old mode 100644 new mode 100755 index b56ee0a08b..5d58e182a3 --- a/extra/editors/ted-notepad/ted-notepad.factor +++ b/extra/editors/ted-notepad/ted-notepad.factor @@ -9,8 +9,7 @@ IN: editors.ted-notepad : ted-notepad ( file line -- ) [ - ted-notepad-path % " /l" % # - " " % % - ] "" make run-detached ; + ted-notepad-path , "/l" swap number>string append , , + ] { } make run-detached drop ; [ ted-notepad ] edit-hook set-global diff --git a/extra/editors/textmate/textmate.factor b/extra/editors/textmate/textmate.factor old mode 100644 new mode 100755 index 18c7dbd07e..0145ccae81 --- a/extra/editors/textmate/textmate.factor +++ b/extra/editors/textmate/textmate.factor @@ -4,6 +4,7 @@ namespaces prettyprint editors ; IN: editors.textmate : textmate-location ( file line -- ) - [ "mate -a -l " % # " " % unparse % ] "" make run-process ; + [ "mate" , "-a" , "-l" , number>string , , ] { } make + run-process drop ; [ textmate-location ] edit-hook set-global diff --git a/extra/editors/ultraedit/ultraedit.factor b/extra/editors/ultraedit/ultraedit.factor old mode 100644 new mode 100755 index 50c241daea..7da4b807ce --- a/extra/editors/ultraedit/ultraedit.factor +++ b/extra/editors/ultraedit/ultraedit.factor @@ -10,8 +10,8 @@ IN: editors.ultraedit : ultraedit ( file line -- ) [ - ultraedit-path % " " % swap % "/" % # "/1" % - ] "" make run-detached ; + ultraedit-path , [ % "/" % # "/1" % ] "" make , + ] { } make run-detached drop ; [ ultraedit ] edit-hook set-global diff --git a/extra/editors/vim/vim.factor b/extra/editors/vim/vim.factor old mode 100644 new mode 100755 index 040e3fb4b4..8d60942d67 --- a/extra/editors/vim/vim.factor +++ b/extra/editors/vim/vim.factor @@ -10,13 +10,15 @@ HOOK: vim-command vim-editor TUPLE: vim ; -M: vim vim-command ( file line -- string ) - [ "\"" % vim-path get % "\" \"" % swap % "\" +" % # ] "" make ; +M: vim vim-command ( file line -- array ) + [ + vim-path get , swap , "+" swap number>string append , + ] { } make ; : vim-location ( file line -- ) vim-command vim-detach get-global - [ run-detached ] [ run-process ] if ; + [ run-detached ] [ run-process ] if drop ; "vim" vim-path set-global [ vim-location ] edit-hook set-global diff --git a/extra/editors/wordpad/wordpad.factor b/extra/editors/wordpad/wordpad.factor old mode 100644 new mode 100755 index eb882a9e38..0a86250a92 --- a/extra/editors/wordpad/wordpad.factor +++ b/extra/editors/wordpad/wordpad.factor @@ -8,8 +8,6 @@ IN: editors.wordpad ] unless* ; : wordpad ( file line -- ) - [ - wordpad-path % drop " " % "\"" % % "\"" % - ] "" make run-detached ; + drop wordpad-path swap 2array run-detached drop ; [ wordpad ] edit-hook set-global diff --git a/extra/tools/deploy/macosx/macosx.factor b/extra/tools/deploy/macosx/macosx.factor index 7b44703013..7efb34a6ae 100755 --- a/extra/tools/deploy/macosx/macosx.factor +++ b/extra/tools/deploy/macosx/macosx.factor @@ -8,10 +8,10 @@ QUALIFIED: unix IN: tools.deploy.macosx : touch ( path -- ) - { "touch" } swap add run-process ; + { "touch" } swap add run-process drop ; : rm ( path -- ) - { "rm" "-rf" } swap add run-process ; + { "rm" "-rf" } swap add run-process drop ; : bundle-dir ( -- dir ) vm parent-directory parent-directory ; From 6afa4119c8e3519e182b2163bd0402c79ba5cec4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 24 Jan 2008 04:19:15 -0400 Subject: [PATCH 06/10] Clean up non-blocking wait-for-process support, implement on Unix (untested) --- extra/io/launcher/launcher.factor | 29 +++++++-- extra/io/unix/bsd/bsd.factor | 4 +- extra/io/unix/kqueue/kqueue.factor | 18 ++---- extra/io/unix/launcher/launcher.factor | 63 ++++++++++---------- extra/io/unix/linux/linux.factor | 5 +- extra/io/windows/launcher/launcher.factor | 26 +++----- extra/io/windows/nt/launcher/launcher.factor | 2 +- extra/unix/process/process.factor | 22 +------ 8 files changed, 72 insertions(+), 97 deletions(-) mode change 100644 => 100755 extra/io/unix/kqueue/kqueue.factor mode change 100644 => 100755 extra/unix/process/process.factor diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index decf4f3434..c646358b2e 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -1,12 +1,25 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io io.backend system kernel namespaces strings hashtables -sequences assocs combinators vocabs.loader ; +sequences assocs combinators vocabs.loader init threads +continuations ; IN: io.launcher +! Non-blocking process exit notification facility +SYMBOL: processes + +[ H{ } clone processes set-global ] "io.launcher" add-init-hook + TUPLE: process handle status ; -: ( handle -- process ) f process construct-boa ; +HOOK: register-process io-backend ( process -- ) + +M: object register-process drop ; + +: ( handle -- process ) + f process construct-boa + V{ } clone over processes get set-at + dup register-process ; M: process equal? 2drop f ; @@ -54,11 +67,10 @@ M: assoc >descriptor ; HOOK: run-process* io-backend ( desc -- handle ) -HOOK: wait-for-process* io-backend ( process -- ) - : wait-for-process ( process -- status ) - dup process-handle [ dup wait-for-process* ] when - process-status ; + dup process-handle [ + dup [ processes get at push stop ] curry callcc0 + ] when process-status ; : run-process ( obj -- process ) >descriptor @@ -81,3 +93,8 @@ TUPLE: process-stream process ; swap [ swap with-stream ] keep process-stream-process ; inline + +: notify-exit ( status process -- ) + [ set-process-status ] keep + [ processes get delete-at* drop [ schedule-thread ] each ] keep + f swap set-process-handle ; diff --git a/extra/io/unix/bsd/bsd.factor b/extra/io/unix/bsd/bsd.factor index 39eb8b6fb9..3319324c3d 100755 --- a/extra/io/unix/bsd/bsd.factor +++ b/extra/io/unix/bsd/bsd.factor @@ -23,7 +23,7 @@ M: bsd-io init-io ( -- ) 2dup mx get-global mx-reads set-at mx get-global mx-writes set-at ; -M: bsd-io wait-for-process ( pid -- status ) - [ kqueue-mx get-global add-pid-task stop ] curry callcc1 ; +M: bsd-io register-process ( process -- ) + process-handle kqueue-mx get-global add-pid-task ; T{ bsd-io } set-io-backend diff --git a/extra/io/unix/kqueue/kqueue.factor b/extra/io/unix/kqueue/kqueue.factor old mode 100644 new mode 100755 index 4fbfbcaaf0..3df2d7cd57 --- a/extra/io/unix/kqueue/kqueue.factor +++ b/extra/io/unix/kqueue/kqueue.factor @@ -5,7 +5,7 @@ sequences assocs unix unix.kqueue unix.process math namespaces combinators threads vectors ; IN: io.unix.kqueue -TUPLE: kqueue-mx events processes ; +TUPLE: kqueue-mx events ; : max-events ( -- n ) #! We read up to 256 events at a time. This is an arbitrary @@ -15,7 +15,6 @@ TUPLE: kqueue-mx events processes ; : ( -- mx ) kqueue-mx construct-mx kqueue dup io-error over set-mx-fd - H{ } clone over set-kqueue-mx-processes max-events "kevent" over set-kqueue-mx-events ; GENERIC: io-task-filter ( task -- n ) @@ -52,9 +51,8 @@ M: kqueue-mx unregister-io-task ( task mx -- ) over mx-reads at handle-io-task ; : kevent-proc-task ( mx pid -- ) - dup (wait-for-pid) spin kqueue-mx-processes delete-at* [ - [ schedule-thread-with ] with each - ] [ 2drop ] if ; + dup (wait-for-pid) swap find-process + dup [ notify-exit ] [ 2drop ] if ; : handle-kevent ( mx kevent -- ) dup kevent-ident swap kevent-filter { @@ -76,11 +74,5 @@ M: kqueue-mx wait-for-events ( ms mx -- ) EVFILT_PROC over set-kevent-filter NOTE_EXIT over set-kevent-fflags ; -: add-pid-task ( continuation pid mx -- ) - 2dup kqueue-mx-processes at* [ - 2nip push - ] [ - drop - over make-proc-kevent over register-kevent - >r >r 1vector r> r> kqueue-mx-processes set-at - ] if ; +: add-pid-task ( pid mx -- ) + swap make-proc-kevent swap register-kevent ; diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index adf571a8b7..3cd21e6c51 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -9,10 +9,6 @@ IN: io.unix.launcher ! Search unix first USE: unix -HOOK: wait-for-process io-backend ( pid -- status ) - -M: unix-io wait-for-process ( pid -- status ) wait-for-pid ; - ! Our command line parser. Supported syntax: ! foo bar baz -- simple tokens ! foo\ bar -- escaping the space @@ -46,7 +42,7 @@ MEMO: 'arguments' ( -- parser ) : assoc>env ( assoc -- env ) [ "=" swap 3append ] { } assoc>map ; -: (spawn-process) ( -- ) +: spawn-process ( -- ) [ get-arguments pass-environment? @@ -55,20 +51,9 @@ MEMO: 'arguments' ( -- parser ) io-error ] [ error. :c flush ] recover 1 exit ; -: spawn-process ( -- pid ) - [ (spawn-process) ] [ ] with-fork ; - -: spawn-detached ( -- ) - [ spawn-process 0 exit ] [ ] with-fork - wait-for-process drop ; - -M: unix-io run-process* ( desc -- ) +M: unix-io run-process* ( desc -- pid ) [ - +detached+ get [ - spawn-detached - ] [ - spawn-process wait-for-process drop - ] if + [ spawn-process ] [ ] with-fork ] with-descriptor ; : open-pipe ( -- pair ) @@ -82,21 +67,35 @@ M: unix-io run-process* ( desc -- ) : spawn-process-stream ( -- in out pid ) open-pipe open-pipe [ setup-stdio-pipe - (spawn-process) + spawn-process ] [ -rot 2dup second close first close - ] with-fork first swap second rot ; - -TUPLE: pipe-stream pid status ; - -: ( in out pid -- stream ) - f pipe-stream construct-boa - -rot handle>duplex-stream over set-delegate ; - -M: pipe-stream stream-close - dup delegate stream-close - dup pipe-stream-pid wait-for-process - swap set-pipe-stream-status ; + ] with-fork first swap second rot ; M: unix-io process-stream* - [ spawn-process-stream ] with-descriptor ; + [ + spawn-process-stream >r handle>duplex-stream r> + ] with-descriptor ; + +: find-process ( handle -- process ) + f process construct-boa processes get at ; + +! Inefficient process wait polling, used on Linux and Solaris. +! On BSD and Mac OS X, we use kqueue() which scales better. +: wait-for-processes ( -- ? ) + -1 0 tuck WNOHANG waitpid + dup zero? [ + 2drop t + ] [ + find-process dup [ + >r *uint r> notify-exit f + ] [ + 2drop f + ] if + ] if ; + +: wait-loop ( -- ) + wait-for-processes [ 250 sleep ] when wait-loop ; + +: start-wait-thread ( -- ) + [ wait-loop ] in-thread ; diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor index 06380c7e1e..fcb48dd577 100755 --- a/extra/io/unix/linux/linux.factor +++ b/extra/io/unix/linux/linux.factor @@ -10,9 +10,6 @@ INSTANCE: linux-io unix-io M: linux-io init-io ( -- ) mx set-global - start-wait-loop ; - -M: linux-io wait-for-process ( pid -- status ) - wait-for-pid ; + start-wait-thread ; T{ linux-io } set-io-backend diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index 603fa2a638..79284b265b 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -6,14 +6,6 @@ math windows.kernel32 windows namespaces io.launcher kernel sequences windows.errors assocs splitting system threads init ; IN: io.windows.launcher -SYMBOL: processes - -[ H{ } clone processes set-global ] -"io.windows.launcher" add-init-hook - -: ( handle -- process ) - V{ } clone over processes get set-at ; - TUPLE: CreateProcess-args lpApplicationName lpCommandLine @@ -104,12 +96,9 @@ M: windows-io run-process* ( desc -- handle ) [ make-CreateProcess-args dup call-CreateProcess - CreateProcess-args-lpProcessInformation + CreateProcess-args-lpProcessInformation ] with-descriptor ; -M: windows-io wait-for-process* - [ processes get at push stop ] curry callcc0 ; - : dispose-process ( process-information -- ) #! From MSDN: "Handles in PROCESS_INFORMATION must be closed #! with CloseHandle when they are no longer needed." @@ -121,11 +110,10 @@ M: windows-io wait-for-process* 0 [ GetExitCodeProcess ] keep *ulong swap win32-error=0/f ; -: notify-exit ( process -- ) - dup process-handle exit-code over set-process-status - dup process-handle dispose-process - dup processes get delete-at* drop [ schedule-thread ] each - f swap set-process-handle ; +: process-exited ( process -- ) + dup process-handle exit-code + over process-handle dispose-process + swap notify-exit ; : wait-for-processes ( processes -- ? ) keys dup @@ -133,7 +121,7 @@ M: windows-io wait-for-process* dup length swap >c-void*-array 0 0 WaitForMultipleObjects dup HEX: ffffffff = [ win32-error ] when - dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth notify-exit f ] if ; + dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth process-exited f ] if ; : wait-loop ( -- ) processes get dup assoc-empty? @@ -143,3 +131,5 @@ M: windows-io wait-for-process* : start-wait-thread ( -- ) [ wait-loop ] in-thread ; + +[ start-wait-thread ] "io.windows.launcher" add-init-hook diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor index 6e788003ea..bfce92e17d 100755 --- a/extra/io/windows/nt/launcher/launcher.factor +++ b/extra/io/windows/nt/launcher/launcher.factor @@ -59,6 +59,6 @@ M: windows-io process-stream* dup CreateProcess-args-stdout-pipe pipe-in over CreateProcess-args-stdin-pipe pipe-out - swap CreateProcess-args-lpProcessInformation + swap CreateProcess-args-lpProcessInformation ] with-destructors ] with-descriptor ; diff --git a/extra/unix/process/process.factor b/extra/unix/process/process.factor old mode 100644 new mode 100755 index b2877dc4a1..fb4271ea23 --- a/extra/unix/process/process.factor +++ b/extra/unix/process/process.factor @@ -31,25 +31,5 @@ IN: unix.process : with-fork ( child parent -- ) fork dup zero? -roll swap curry if ; inline -! Lame polling strategy for getting process exit codes. On -! BSD, we use kqueue which is more efficient. - -SYMBOL: pid-wait - -: (wait-for-pid) ( pid -- status ) - 0 [ 0 waitpid drop ] keep *int ; - : wait-for-pid ( pid -- status ) - [ pid-wait get-global [ ?push ] change-at stop ] curry - callcc1 ; - -: wait-loop ( -- ) - -1 0 tuck WNOHANG waitpid ! &status return - [ *int ] [ pid-wait get delete-at* drop ] bi* ! status ? - [ schedule-thread-with ] with each - 250 sleep - wait-loop ; - -: start-wait-loop ( -- ) - H{ } clone pid-wait set-global - [ wait-loop ] in-thread ; \ No newline at end of file + 0 [ 0 waitpid drop ] keep *int ; \ No newline at end of file From 42a710e96531576b94011b77aff9a57111b9f3a3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 24 Jan 2008 19:19:45 -0400 Subject: [PATCH 07/10] Update calendar for Windows --- extra/calendar/windows/windows.factor | 38 +----------------- .../time/time-tests.factor} | 0 extra/windows/time/time.factor | 39 +++++++++++++++++++ 3 files changed, 41 insertions(+), 36 deletions(-) mode change 100644 => 100755 extra/calendar/windows/windows.factor rename extra/{calendar/windows/windows-tests.factor => windows/time/time-tests.factor} (100%) create mode 100755 extra/windows/time/time.factor diff --git a/extra/calendar/windows/windows.factor b/extra/calendar/windows/windows.factor old mode 100644 new mode 100755 index 6c3a7a71e7..320400822c --- a/extra/calendar/windows/windows.factor +++ b/extra/calendar/windows/windows.factor @@ -1,5 +1,5 @@ -USING: alien alien.c-types kernel math -windows windows.kernel32 namespaces ; +USING: calendar.backend namespaces alien.c-types +windows windows.kernel32 kernel math ; IN: calendar.windows TUPLE: windows-calendar ; @@ -11,37 +11,3 @@ M: windows-calendar gmt-offset ( -- float ) [ GetTimeZoneInformation win32-error=0/f ] keep [ TIME_ZONE_INFORMATION-Bias ] keep TIME_ZONE_INFORMATION-DaylightBias + 60 /f neg ; - -: >64bit ( lo hi -- n ) - 32 shift bitor ; - -: windows-1601 ( -- timestamp ) - 1601 1 1 0 0 0 0 ; - -: FILETIME>windows-time ( FILETIME -- n ) - [ FILETIME-dwLowDateTime ] keep - FILETIME-dwHighDateTime >64bit ; - -: windows-time>timestamp ( n -- timestamp ) - 10000000 /i seconds windows-1601 swap +dt ; - -: windows-time ( -- n ) - "FILETIME" [ GetSystemTimeAsFileTime ] keep - FILETIME>windows-time ; - -: timestamp>windows-time ( timestamp -- n ) - #! 64bit number representing # of nanoseconds since Jan 1, 1601 (UTC) - >gmt windows-1601 timestamp- >bignum 10000000 * ; - -: windows-time>FILETIME ( n -- FILETIME ) - "FILETIME" - [ - [ >r HEX: ffffffff bitand r> set-FILETIME-dwLowDateTime ] 2keep - >r -32 shift r> set-FILETIME-dwHighDateTime - ] keep ; - -: timestamp>FILETIME ( timestamp -- FILETIME/f ) - [ >gmt timestamp>windows-time windows-time>FILETIME ] [ f ] if* ; - -: FILETIME>timestamp ( FILETIME -- timestamp/f ) - FILETIME>windows-time windows-time>timestamp ; diff --git a/extra/calendar/windows/windows-tests.factor b/extra/windows/time/time-tests.factor similarity index 100% rename from extra/calendar/windows/windows-tests.factor rename to extra/windows/time/time-tests.factor diff --git a/extra/windows/time/time.factor b/extra/windows/time/time.factor new file mode 100755 index 0000000000..3ccb4cfa67 --- /dev/null +++ b/extra/windows/time/time.factor @@ -0,0 +1,39 @@ +! Copyright (C) 2007 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien alien.c-types kernel math windows windows.kernel32 +namespaces calendar.backend ; +IN: windows.time + +: >64bit ( lo hi -- n ) + 32 shift bitor ; + +: windows-1601 ( -- timestamp ) + 1601 1 1 0 0 0 0 ; + +: FILETIME>windows-time ( FILETIME -- n ) + [ FILETIME-dwLowDateTime ] keep + FILETIME-dwHighDateTime >64bit ; + +: windows-time>timestamp ( n -- timestamp ) + 10000000 /i seconds windows-1601 swap +dt ; + +: windows-time ( -- n ) + "FILETIME" [ GetSystemTimeAsFileTime ] keep + FILETIME>windows-time ; + +: timestamp>windows-time ( timestamp -- n ) + #! 64bit number representing # of nanoseconds since Jan 1, 1601 (UTC) + >gmt windows-1601 timestamp- >bignum 10000000 * ; + +: windows-time>FILETIME ( n -- FILETIME ) + "FILETIME" + [ + [ >r HEX: ffffffff bitand r> set-FILETIME-dwLowDateTime ] 2keep + >r -32 shift r> set-FILETIME-dwHighDateTime + ] keep ; + +: timestamp>FILETIME ( timestamp -- FILETIME/f ) + [ >gmt timestamp>windows-time windows-time>FILETIME ] [ f ] if* ; + +: FILETIME>timestamp ( FILETIME -- timestamp/f ) + FILETIME>windows-time windows-time>timestamp ; From 1249e3a720bd526fb2e61f746a5df50fb480737b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 24 Jan 2008 19:20:07 -0400 Subject: [PATCH 08/10] Move prettyprint:-> to prettyprint.private --- core/prettyprint/prettyprint-docs.factor | 4 ++-- core/prettyprint/prettyprint.factor | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) mode change 100644 => 100755 core/prettyprint/prettyprint-docs.factor diff --git a/core/prettyprint/prettyprint-docs.factor b/core/prettyprint/prettyprint-docs.factor old mode 100644 new mode 100755 index 2b01df8faa..69400d2527 --- a/core/prettyprint/prettyprint-docs.factor +++ b/core/prettyprint/prettyprint-docs.factor @@ -1,6 +1,6 @@ USING: prettyprint.backend prettyprint.config -prettyprint.sections help.markup help.syntax io kernel words -definitions quotations strings ; +prettyprint.sections prettyprint.private help.markup help.syntax +io kernel words definitions quotations strings ; IN: prettyprint ARTICLE: "prettyprint-numbers" "Prettyprinting numbers" diff --git a/core/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor index 45ff0c0572..ed52f0238c 100755 --- a/core/prettyprint/prettyprint.factor +++ b/core/prettyprint/prettyprint.factor @@ -86,14 +86,14 @@ combinators quotations ; : .s ( -- ) datastack stack. ; : .r ( -- ) retainstack stack. ; + \ -> { { foreground { 1 1 1 1 } } { background { 0 0 0 1 } } } "word-style" set-word-prop - Date: Thu, 24 Jan 2008 19:20:27 -0400 Subject: [PATCH 09/10] Fix erronous stack effect comment --- extra/cocoa/messages/messages.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/cocoa/messages/messages.factor b/extra/cocoa/messages/messages.factor index 33d635c8b7..e2072f441c 100755 --- a/extra/cocoa/messages/messages.factor +++ b/extra/cocoa/messages/messages.factor @@ -79,11 +79,11 @@ MACRO: (send) ( selector super? -- quot ) super-message-senders message-senders ? get at [ slip execute ] 2curry ; -: send ( args... receiver selector -- return... ) f (send) ; inline +: send ( receiver args... selector -- return... ) f (send) ; inline \ send soft "break-after" set-word-prop -: super-send ( args... receiver selector -- return... ) t (send) ; inline +: super-send ( receiver args... selector -- return... ) t (send) ; inline \ super-send soft "break-after" set-word-prop From 783e63781f1ebdd7c3b3ebc592606c1049d00d78 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 24 Jan 2008 19:21:10 -0400 Subject: [PATCH 10/10] I/O fixes --- extra/io/sockets/impl/impl.factor | 9 +++++++-- extra/io/sockets/sockets.factor | 0 extra/io/windows/nt/backend/backend.factor | 18 ++++++++++-------- 3 files changed, 17 insertions(+), 10 deletions(-) mode change 100644 => 100755 extra/io/sockets/sockets.factor diff --git a/extra/io/sockets/impl/impl.factor b/extra/io/sockets/impl/impl.factor index e8ab957482..ce4d5ad566 100755 --- a/extra/io/sockets/impl/impl.factor +++ b/extra/io/sockets/impl/impl.factor @@ -106,9 +106,14 @@ M: f parse-sockaddr nip ; [ ] unfold nip [ ] subset ; : prepare-resolve-host ( host serv passive? -- host' serv' flags ) + #! If the port is a number, we resolve for 'http' then + #! change it later. This is a workaround for a FreeBSD + #! getaddrinfo() limitation -- on Windows, Linux and Mac, + #! we can convert a number to a string and pass that as the + #! service name, but on FreeBSD this gives us an unknown + #! service error. >r - >r string>char-alien r> - dup integer? [ port-override set f ] [ string>char-alien ] if + dup integer? [ port-override set "http" ] when r> AI_PASSIVE 0 ? ; M: object resolve-host ( host serv passive? -- seq ) diff --git a/extra/io/sockets/sockets.factor b/extra/io/sockets/sockets.factor old mode 100644 new mode 100755 diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor index 0d1f2cec0b..82d609c371 100755 --- a/extra/io/windows/nt/backend/backend.factor +++ b/extra/io/windows/nt/backend/backend.factor @@ -116,25 +116,27 @@ M: windows-nt-io add-completion ( handle -- ) : lookup-callback ( GetQueuedCompletion-args -- callback ) io-hash get-global delete-at* drop ; -: wait-for-io ( timeout -- continuation/f ) +: handle-overlapped ( timeout -- ? ) wait-for-overlapped [ GetLastError dup expected-io-error? [ - 2drop f + 2drop t ] [ 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 - io-callback-continuation - ] if + ] if io-callback-continuation schedule-thread f ] if ] [ - lookup-callback io-callback-continuation + lookup-callback + io-callback-continuation schedule-thread f ] if ; +: drain-overlapped ( timeout -- ) + handle-overlapped [ 0 drain-overlapped ] unless ; + : maybe-expire ( io-callbck -- ) io-callback-port dup timeout? [ @@ -144,10 +146,10 @@ M: windows-nt-io add-completion ( handle -- ) ] if ; : cancel-timeout ( -- ) - io-hash get-global values [ maybe-expire ] each ; + io-hash get-global [ nip maybe-expire ] assoc-each ; M: windows-nt-io io-multiplex ( ms -- ) - cancel-timeout wait-for-io [ schedule-thread ] when* ; + cancel-timeout drain-overlapped ; M: windows-nt-io init-io ( -- ) master-completion-port set-global