Merge git://factorcode.org/git/factor

db4
Eduardo Cavazos 2008-02-10 00:35:41 -06:00
commit 230129e7e9
42 changed files with 313 additions and 197 deletions

View File

@ -77,3 +77,14 @@ nl
[ compiled-usages recompile ] recompile-hook set-global [ compiled-usages recompile ] recompile-hook set-global
" done" print flush " done" print flush
! Load empty test vocabs
USE: compiler.test.curry
USE: compiler.test.float
USE: compiler.test.intrinsics
USE: compiler.test.redefine
USE: compiler.test.simple
USE: compiler.test.stack-trace
USE: compiler.test.templates
USE: compiler.test.templates-early
USE: compiler.test.tuples

View File

@ -20,7 +20,9 @@ PREDICATE: class tuple-class
: classes ( -- seq ) class<map get keys ; : classes ( -- seq ) class<map get keys ;
: type>class ( n -- class ) builtins get nth ; : type>class ( n -- class ) builtins get-global nth ;
: bootstrap-type>class ( n -- class ) builtins get nth ;
: predicate-word ( word -- predicate ) : predicate-word ( word -- predicate )
[ word-name "?" append ] keep word-vocabulary create ; [ word-name "?" append ] keep word-vocabulary create ;

View File

@ -1,7 +0,0 @@
IN: temporary
USING: tools.browser tools.test kernel sequences vocabs ;
"compiler.test" child-vocabs empty? [
"compiler.test" load-children
"compiler.test" test
] when

View File

@ -1,6 +1,6 @@
USING: compiler tools.test kernel kernel.private USING: compiler tools.test kernel kernel.private
combinators.private math.private math combinators strings combinators.private math.private math combinators strings
alien arrays ; alien arrays memory ;
IN: temporary IN: temporary
! Test empty word ! Test empty word
@ -48,6 +48,8 @@ IN: temporary
[ 4 1 3 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test [ 4 1 3 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test
[ 3 1 3 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test [ 3 1 3 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test
[ 2 3 ] [ 1 [ { [ code-gc 1 ] [ code-gc 2 ] } dispatch 3 ] compile-call ] unit-test
! Labels ! Labels
: recursive ( ? -- ) [ f recursive ] when ; inline : recursive ( ? -- ) [ f recursive ] when ; inline

View File

@ -60,9 +60,7 @@ HOOK: %jump-label compiler-backend ( label -- )
! Test if vreg is 'f' or not ! Test if vreg is 'f' or not
HOOK: %jump-t compiler-backend ( label -- ) HOOK: %jump-t compiler-backend ( label -- )
HOOK: %call-dispatch compiler-backend ( -- label ) HOOK: %dispatch compiler-backend ( -- )
HOOK: %jump-dispatch compiler-backend ( -- )
HOOK: %dispatch-label compiler-backend ( word -- ) HOOK: %dispatch-label compiler-backend ( word -- )

View File

@ -111,20 +111,15 @@ M: ppc-backend %jump-label ( label -- ) B ;
M: ppc-backend %jump-t ( label -- ) M: ppc-backend %jump-t ( label -- )
0 "flag" operand f v>operand CMPI BNE ; 0 "flag" operand f v>operand CMPI BNE ;
: (%dispatch) ( len -- ) M: ppc-backend %dispatch ( -- )
0 11 LOAD32 rc-absolute-ppc-2/2 rel-here [
"offset" operand "n" operand 1 SRAWI %epilogue-later
11 11 "offset" operand ADD 0 11 LOAD32 rc-absolute-ppc-2/2 rel-here
11 dup rot cells LWZ ; "offset" operand "n" operand 1 SRAWI
11 11 "offset" operand ADD
M: ppc-backend %call-dispatch ( word-table# -- ) 11 dup 6 cells LWZ
[ 7 (%dispatch) (%call) <label> dup B ] H{ (%jump)
{ +input+ { { f "n" } } } ] H{
{ +scratch+ { { f "offset" } } }
} with-template ;
M: ppc-backend %jump-dispatch ( -- )
[ %epilogue-later 6 (%dispatch) (%jump) ] H{
{ +input+ { { f "n" } } } { +input+ { { f "n" } } }
{ +scratch+ { { f "offset" } } } { +scratch+ { { f "offset" } } }
} with-template ; } with-template ;

View File

@ -77,26 +77,29 @@ M: x86-backend %jump-label ( label -- ) JMP ;
M: x86-backend %jump-t ( label -- ) M: x86-backend %jump-t ( label -- )
"flag" operand f v>operand CMP JNE ; "flag" operand f v>operand CMP JNE ;
: (%dispatch) ( n -- operand ) : code-alignment ( -- n )
! Load jump table base. We use a temporary register building get length dup cell align swap - ;
! since on AMD64 we have to load a 64-bit immediate. On
! x86, this is redundant.
! Untag and multiply to get a jump table offset
"n" operand fixnum>slot@
! Add jump table base
"offset" operand HEX: ffffffff MOV rc-absolute-cell rel-here
"n" operand "offset" operand ADD
"n" operand swap bootstrap-cell 8 = 14 9 ? + [+] ;
M: x86-backend %call-dispatch ( word-table# -- ) : align-code ( n -- )
[ 5 (%dispatch) CALL <label> dup JMP ] H{ 0 <repetition> % ;
{ +input+ { { f "n" } } }
{ +scratch+ { { f "offset" } } }
{ +clobber+ { "n" } }
} with-template ;
M: x86-backend %jump-dispatch ( -- ) M: x86-backend %dispatch ( -- )
[ %epilogue-later 0 (%dispatch) JMP ] H{ [
%epilogue-later
! Load jump table base. We use a temporary register
! since on AMD64 we have to load a 64-bit immediate. On
! x86, this is redundant.
! Untag and multiply to get a jump table offset
"n" operand fixnum>slot@
! Add jump table base
"offset" operand HEX: ffffffff MOV rc-absolute-cell rel-here
"n" operand "offset" operand ADD
"n" operand HEX: 7f [+] JMP
! Fix up the displacement above
code-alignment dup bootstrap-cell 8 = 14 9 ? +
building get dup pop* push
align-code
] H{
{ +input+ { { f "n" } } } { +input+ { { f "n" } } }
{ +scratch+ { { f "offset" } } } { +scratch+ { { f "offset" } } }
{ +clobber+ { "n" } } { +clobber+ { "n" } }

View File

@ -56,13 +56,16 @@ GENERIC: generate-node ( node -- next )
: generate-nodes ( node -- ) : generate-nodes ( node -- )
[ node@ generate-node ] iterate-nodes end-basic-block ; [ node@ generate-node ] iterate-nodes end-basic-block ;
: init-generate-nodes ( -- )
init-templates
%save-word-xt
%prologue-later
current-label-start define-label
current-label-start resolve-label ;
: generate ( word label node -- ) : generate ( word label node -- )
[ [
init-templates init-generate-nodes
%save-word-xt
%prologue-later
current-label-start define-label
current-label-start resolve-label
[ generate-nodes ] with-node-iterator [ generate-nodes ] with-node-iterator
] generate-1 ; ] generate-1 ;
@ -168,17 +171,23 @@ M: #if generate-node
] if %dispatch-label ] if %dispatch-label
] each ; ] each ;
: generate-dispatch ( node -- )
%dispatch dispatch-branches init-templates ;
M: #dispatch generate-node M: #dispatch generate-node
#! The order here is important, dispatch-branches must #! The order here is important, dispatch-branches must
#! run after %dispatch, so that each branch gets the #! run after %dispatch, so that each branch gets the
#! correct register state #! correct register state
tail-call? [ tail-call? [
%jump-dispatch dispatch-branches generate-dispatch iterate-next
] [ ] [
0 frame-required compiling-word get gensym [
%call-dispatch >r dispatch-branches r> resolve-label rot [
] if init-generate-nodes
init-templates iterate-next ; generate-dispatch
] generate-1
] keep generate-call
] if ;
! #call ! #call
: define-intrinsics ( word intrinsics -- ) : define-intrinsics ( word intrinsics -- )

View File

@ -61,7 +61,7 @@ TUPLE: no-math-method left right generic ;
: math-vtable* ( picker max quot -- quot ) : math-vtable* ( picker max quot -- quot )
[ [
rot , \ tag , rot , \ tag ,
[ >r [ type>class ] map r> map % ] { } make , [ >r [ bootstrap-type>class ] map r> map % ] { } make ,
\ dispatch , \ dispatch ,
] [ ] make ; inline ] [ ] make ; inline

View File

@ -97,7 +97,7 @@ TUPLE: no-method object generic ;
[ small-generic ] picker class-hash-dispatch-quot ; [ small-generic ] picker class-hash-dispatch-quot ;
: vtable-class ( n -- class ) : vtable-class ( n -- class )
type>class [ hi-tag bootstrap-word ] unless* ; bootstrap-type>class [ hi-tag bootstrap-word ] unless* ;
: group-methods ( assoc -- vtable ) : group-methods ( assoc -- vtable )
#! Input is a predicate -> method association. #! Input is a predicate -> method association.

View File

@ -4,7 +4,8 @@ math.parser math.private namespaces namespaces.private parser
sequences strings vectors words quotations effects tools.test sequences strings vectors words quotations effects tools.test
continuations generic.standard sorting assocs definitions continuations generic.standard sorting assocs definitions
prettyprint io inspector tuples classes.union classes.predicate prettyprint io inspector tuples classes.union classes.predicate
debugger threads.private io.streams.string combinators.private ; debugger threads.private io.streams.string io.timeouts
combinators.private ;
IN: temporary IN: temporary
{ 0 2 } [ 2 "Hello" ] must-infer-as { 0 2 } [ 2 "Hello" ] must-infer-as

View File

@ -22,8 +22,7 @@ $nl
{ $subsection make-block-stream } { $subsection make-block-stream }
{ $subsection make-cell-stream } { $subsection make-cell-stream }
{ $subsection stream-write-table } { $subsection stream-write-table }
"Optional word for network streams:" { $see-also "io.timeouts" } ;
{ $subsection set-timeout } ;
ARTICLE: "stdio" "The default stream" ARTICLE: "stdio" "The default stream"
"Various words take an implicit stream parameter from a variable to reduce stack shuffling." "Various words take an implicit stream parameter from a variable to reduce stack shuffling."
@ -73,11 +72,6 @@ ARTICLE: "streams" "Streams"
ABOUT: "streams" ABOUT: "streams"
HELP: set-timeout
{ $values { "n" "an integer" } { "stream" "a stream" } }
{ $contract "Sets a timeout, in milliseconds, for input and output operations on the stream. If a read or a write is initiated and no activity is seen before the timeout expires, an error will be thrown to the caller of the operation being performed." }
{ $notes "Whether or not the stream is closed when the error is thrown is implementation-specific, and user code should take care to close the stream on all error conditions in any case." } ;
HELP: stream-readln HELP: stream-readln
{ $values { "stream" "an input stream" } { "str" string } } { $values { "stream" "an input stream" } { "str" string } }
{ $contract "Reads a line of input from the stream. Outputs " { $link f } " on stream exhaustion." } { $contract "Reads a line of input from the stream. Outputs " { $link f } " on stream exhaustion." }

View File

@ -4,7 +4,6 @@ USING: hashtables generic kernel math namespaces sequences strings
continuations assocs io.styles sbufs ; continuations assocs io.styles sbufs ;
IN: io IN: io
GENERIC: set-timeout ( n stream -- )
GENERIC: stream-readln ( stream -- str ) GENERIC: stream-readln ( stream -- str )
GENERIC: stream-read1 ( stream -- ch/f ) GENERIC: stream-read1 ( stream -- ch/f )
GENERIC: stream-read ( n stream -- str/f ) GENERIC: stream-read ( n stream -- str/f )

View File

@ -74,8 +74,3 @@ M: duplex-stream dispose
[ dup duplex-stream-out dispose ] [ dup duplex-stream-out dispose ]
[ dup duplex-stream-in dispose ] [ ] cleanup [ dup duplex-stream-in dispose ] [ ] cleanup
] unless drop ; ] unless drop ;
M: duplex-stream set-timeout
2dup
duplex-stream-in set-timeout
duplex-stream-out set-timeout ;

View File

@ -58,6 +58,7 @@ SYMBOL: super-sent-messages
"NSPasteboard" "NSPasteboard"
"NSResponder" "NSResponder"
"NSSavePanel" "NSSavePanel"
"NSScreen"
"NSView" "NSView"
"NSWindow" "NSWindow"
"NSWorkspace" "NSWorkspace"

View File

@ -133,4 +133,9 @@ SYMBOL: value
[ 3 3 ] [ [ 3 3 ] [
[ 3 ] future [ 3 ] future
dup ?future swap ?future dup ?future swap ?future
] unit-test
! Another race
[ 3 ] [
[ 3 yield ] future ?future
] unit-test ] unit-test

View File

@ -273,14 +273,14 @@ TUPLE: future value processes ;
: future ( quot -- future ) : future ( quot -- future )
#! Spawn a process to call the quotation and immediately return. #! Spawn a process to call the quotation and immediately return.
\ future construct-empty [ f V{ } clone \ future construct-boa [
[ [
>r [ t 2array ] compose [ f 2array ] recover r> >r [ t 2array ] compose [ f 2array ] recover r>
notify-future notify-future
] 2curry spawn drop ] 2curry spawn drop
] keep ; ] keep ;
: ?future ( future -- result ) : ?future ( future -- result )
#! Block the process until the future has completed and then #! Block the process until the future has completed and then
#! place the result on the stack. Return the result #! place the result on the stack. Return the result
#! immediately if the future has completed. #! immediately if the future has completed.

View File

@ -18,7 +18,7 @@ PROTOCOL: stream-protocol
stream-read1 stream-read stream-read-until stream-read1 stream-read stream-read-until
stream-flush stream-write1 stream-write stream-format stream-flush stream-write1 stream-write stream-format
stream-nl make-span-stream make-block-stream stream-readln stream-nl make-span-stream make-block-stream stream-readln
make-cell-stream stream-write-table set-timeout ; make-cell-stream stream-write-table ;
PROTOCOL: definition-protocol PROTOCOL: definition-protocol
where set-where forget uses redefined* where set-where forget uses redefined*

View File

@ -157,7 +157,8 @@ ARTICLE: "io" "Input and output"
"Advanced features:" "Advanced features:"
{ $subsection "io.launcher" } { $subsection "io.launcher" }
{ $subsection "io.mmap" } { $subsection "io.mmap" }
{ $subsection "io.monitors" } ; { $subsection "io.monitors" }
{ $subsection "io.timeouts" } ;
ARTICLE: "tools" "Developer tools" ARTICLE: "tools" "Developer tools"
{ $subsection "tools.annotations" } { $subsection "tools.annotations" }

View File

@ -1,8 +1,8 @@
! Copyright (C) 2005, 2007 Slava Pestov. ! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: assocs http kernel math math.parser namespaces sequences USING: assocs http kernel math math.parser namespaces sequences
io io.sockets io.streams.string io.files strings splitting io io.sockets io.streams.string io.files io.timeouts strings
continuations assocs.lib ; splitting continuations assocs.lib ;
IN: http.client IN: http.client
: parse-host ( url -- host port ) : parse-host ( url -- host port )

View File

@ -1,6 +1,6 @@
! Copyright (C) 2003, 2008 Slava Pestov. ! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel namespaces io strings splitting USING: assocs kernel namespaces io io.timeouts strings splitting
threads http http.server.responders sequences prettyprint threads http http.server.responders sequences prettyprint
io.server logging ; io.server logging ;

View File

@ -76,6 +76,9 @@ HELP: +append-environment+
$nl $nl
"This is used in situations where you want a spawn child process with some overridden environment variables." } ; "This is used in situations where you want a spawn child process with some overridden environment variables." } ;
HELP: +timeout+
{ $description "Launch descriptor key. If set, specifies a maximum running time for the process. If the process runs longer than this time, it will be killed." } ;
HELP: default-descriptor HELP: default-descriptor
{ $description "Association storing default values for launch descriptor keys." } ; { $description "Association storing default values for launch descriptor keys." } ;
@ -94,22 +97,16 @@ HELP: run-process*
HELP: >descriptor HELP: >descriptor
{ $values { "desc" "a launch descriptor" } { "desc" "a launch descriptor" } } { $values { "desc" "a launch descriptor" } { "desc" "a launch descriptor" } }
{ $description "Creates a launch descriptor from an object, which must be one of the following:" { $description "Creates a launch descriptor from an object. See " { $link "io.launcher.descriptors" } " for details." } ;
{ $list
{ "a string -- this is wrapped in a launch descriptor with a single " { $link +command+ } " key" }
{ "a sequence of strings -- this is wrapped in a launch descriptor with a single " { $link +arguments+ } " key" }
{ "an association, used to set launch parameters for additional control" }
}
} ;
HELP: run-process HELP: run-process
{ $values { "desc" "a launch descriptor" } { "process" process } } { $values { "desc" "a launch descriptor" } { "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." } { $description "Launches a process. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link "io.launcher.descriptors" } " for details." }
{ $notes "The output value can be passed to " { $link wait-for-process } " to get an exit code." } ; { $notes "The output value can be passed to " { $link wait-for-process } " to get an exit code." } ;
HELP: run-detached HELP: run-detached
{ $values { "desc" "a launch descriptor" } { "process" process } } { $values { "desc" "a launch descriptor" } { "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." } { $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 "io.launcher.descriptors" } " for details." }
{ $notes { $notes
"This word is functionally identical to passing a launch descriptor to " { $link run-process } " having the " { $link +detached+ } " key set." "This word is functionally identical to passing a launch descriptor to " { $link run-process } " having the " { $link +detached+ } " key set."
$nl $nl
@ -162,25 +159,27 @@ HELP: wait-for-process
{ $values { "process" process } { "status" integer } } { $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." } ; { $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" ARTICLE: "io.launcher.descriptors" "Launch descriptors"
"The " { $vocab-link "io.launcher" } " vocabulary implements cross-platform process launching." "Words which launch processes can take either a command line string, a sequence of command line arguments, or an assoc:"
$nl
"Words which launch processes can take either a command line string, a sequence of command line arguments, or a launch descriptor:"
{ $list { $list
{ "strings are wrapped in a launch descriptor with a single " { $link +command+ } " key" } { "strings are wrapped in an assoc with a single " { $link +command+ } " key" }
{ "sequences of strings are wrapped in a launch descriptor with a single " { $link +arguments+ } " key" } { "sequences of strings are wrapped in an assoc with a single " { $link +arguments+ } " key" }
{ "launch descriptors are associations, which can set extra launch parameters for finer control" } { "associations can be passed in, which allows finer control over launch parameters" }
} }
"A launch descriptor is an association containing keys from the below set:" "The associations can contain the following keys:"
{ $subsection +command+ } { $subsection +command+ }
{ $subsection +arguments+ } { $subsection +arguments+ }
{ $subsection +detached+ } { $subsection +detached+ }
{ $subsection +environment+ } { $subsection +environment+ }
{ $subsection +environment-mode+ } { $subsection +environment-mode+ }
"Redirecting standard input and output to files:" { $subsection +timeout+ }
{ $subsection +stdin+ } { $subsection +stdin+ }
{ $subsection +stdout+ } { $subsection +stdout+ }
{ $subsection +stderr+ } { $subsection +stderr+ } ;
ARTICLE: "io.launcher" "Launching OS processes"
"The " { $vocab-link "io.launcher" } " vocabulary implements cross-platform process launching."
{ $subsection "io.launcher.descriptors" }
"The following words are used to launch processes:" "The following words are used to launch processes:"
{ $subsection run-process } { $subsection run-process }
{ $subsection run-detached } { $subsection run-detached }
@ -193,6 +192,7 @@ $nl
"A class representing an active or finished process:" "A class representing an active or finished process:"
{ $subsection process } { $subsection process }
"Waiting for a process to end, or getting the exit code of a finished process:" "Waiting for a process to end, or getting the exit code of a finished process:"
{ $subsection wait-for-process } ; { $subsection wait-for-process }
"Processes support the " { $link "io.timeouts" } "; the timeout specifies an upper bound on the running time of the process." ;
ABOUT: "io.launcher" ABOUT: "io.launcher"

View File

@ -1,8 +1,8 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: io io.backend system kernel namespaces strings hashtables USING: io io.backend io.timeouts system kernel namespaces
sequences assocs combinators vocabs.loader init threads strings hashtables sequences assocs combinators vocabs.loader
continuations math ; init threads continuations math ;
IN: io.launcher IN: io.launcher
! Non-blocking process exit notification facility ! Non-blocking process exit notification facility
@ -10,14 +10,14 @@ SYMBOL: processes
[ H{ } clone processes set-global ] "io.launcher" add-init-hook [ H{ } clone processes set-global ] "io.launcher" add-init-hook
TUPLE: process handle status ; TUPLE: process handle status killed? lapse ;
HOOK: register-process io-backend ( process -- ) HOOK: register-process io-backend ( process -- )
M: object register-process drop ; M: object register-process drop ;
: <process> ( handle -- process ) : <process> ( handle -- process )
f process construct-boa f f <lapse> process construct-boa
V{ } clone over processes get set-at V{ } clone over processes get set-at
dup register-process ; dup register-process ;
@ -25,6 +25,8 @@ M: process equal? 2drop f ;
M: process hashcode* process-handle hashcode* ; M: process hashcode* process-handle hashcode* ;
: process-running? ( process -- ? ) process-status not ;
SYMBOL: +command+ SYMBOL: +command+
SYMBOL: +arguments+ SYMBOL: +arguments+
SYMBOL: +detached+ SYMBOL: +detached+
@ -34,6 +36,7 @@ SYMBOL: +stdin+
SYMBOL: +stdout+ SYMBOL: +stdout+
SYMBOL: +stderr+ SYMBOL: +stderr+
SYMBOL: +closed+ SYMBOL: +closed+
SYMBOL: +timeout+
SYMBOL: +prepend-environment+ SYMBOL: +prepend-environment+
SYMBOL: +replace-environment+ SYMBOL: +replace-environment+
@ -63,22 +66,30 @@ SYMBOL: +append-environment+
{ +replace-environment+ [ ] } { +replace-environment+ [ ] }
} case ; } case ;
GENERIC: >descriptor ( desc -- desc ) : string-array? ( obj -- ? )
dup sequence? [ [ string? ] all? ] [ drop f ] if ;
M: string >descriptor +command+ associate ; : >descriptor ( desc -- desc )
M: sequence >descriptor +arguments+ associate ; {
M: assoc >descriptor >hashtable ; { [ dup string? ] [ +command+ associate ] }
{ [ dup string-array? ] [ +arguments+ associate ] }
{ [ dup assoc? ] [ >hashtable ] }
} cond ;
HOOK: run-process* io-backend ( desc -- handle ) HOOK: run-process* io-backend ( desc -- handle )
: wait-for-process ( process -- status ) : wait-for-process ( process -- status )
dup process-handle [ [
dup [ processes get at push stop ] curry callcc0 dup process-handle
] when process-status ; [ dup [ processes get at push stop ] curry callcc0 ] when
dup process-killed?
[ "Process was killed" throw ] [ process-status ] if
] with-timeout ;
: run-process ( desc -- process ) : run-process ( desc -- process )
>descriptor >descriptor
dup run-process* dup run-process*
+timeout+ pick at [ over set-timeout ] when*
+detached+ rot at [ dup wait-for-process drop ] unless ; +detached+ rot at [ dup wait-for-process drop ] unless ;
: run-detached ( desc -- process ) : run-detached ( desc -- process )
@ -96,8 +107,13 @@ TUPLE: process-failed code ;
HOOK: kill-process* io-backend ( handle -- ) HOOK: kill-process* io-backend ( handle -- )
: kill-process ( process -- ) : kill-process ( process -- )
t over set-process-killed?
process-handle [ kill-process* ] when* ; process-handle [ kill-process* ] when* ;
M: process get-lapse process-lapse ;
M: process timed-out kill-process ;
HOOK: process-stream* io-backend ( desc -- stream process ) HOOK: process-stream* io-backend ( desc -- stream process )
TUPLE: process-stream process ; TUPLE: process-stream process ;

View File

@ -38,8 +38,6 @@ $nl
{ $list { $list
{ { $link port-handle } " - a native handle identifying the underlying native resource used by the port" } { { $link port-handle } " - a native handle identifying the underlying native resource used by the port" }
{ { $link port-error } " - the most recent I/O error, if any. This error is thrown to the waiting thread when " { $link pending-error } " is called by stream operations" } { { $link port-error } " - the most recent I/O error, if any. This error is thrown to the waiting thread when " { $link pending-error } " is called by stream operations" }
{ { $link port-timeout } " - a timeout, specifying the maximum length of time, in milliseconds, for which input operations can block before throwing an error. A value of 0 denotes no timeout is desired." }
{ { $link port-cutoff } " - the time when the current timeout expires; if no input data arrives before this time, an error is thrown" }
{ { $link port-type } " - a symbol identifying the port's intended purpose" } { { $link port-type } " - a symbol identifying the port's intended purpose" }
{ { $link port-eof? } " - a flag indicating if the port has reached the end of file while reading" } { { $link port-eof? } " - a flag indicating if the port has reached the end of file while reading" }
} } ; } } ;

View File

@ -1,10 +1,10 @@
! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman ! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
IN: io.nonblocking IN: io.nonblocking
USING: math kernel io sequences io.buffers generic sbufs system USING: math kernel io sequences io.buffers io.timeouts generic
io.streams.lines io.streams.plain io.streams.duplex io.backend sbufs system io.streams.lines io.streams.plain io.streams.duplex
continuations debugger classes byte-arrays namespaces splitting io.backend continuations debugger classes byte-arrays namespaces
dlists assocs ; splitting dlists assocs ;
SYMBOL: default-buffer-size SYMBOL: default-buffer-size
64 1024 * default-buffer-size set-global 64 1024 * default-buffer-size set-global
@ -13,9 +13,12 @@ SYMBOL: default-buffer-size
TUPLE: port TUPLE: port
handle handle
error error
timeout-entry timeout cutoff lapse
type eof? ; type eof? ;
! Ports support the lapse protocol
M: port get-lapse port-lapse ;
SYMBOL: closed SYMBOL: closed
PREDICATE: port input-port port-type input-port eq? ; PREDICATE: port input-port port-type input-port eq? ;
@ -26,12 +29,11 @@ GENERIC: close-handle ( handle -- )
: <port> ( handle buffer type -- port ) : <port> ( handle buffer type -- port )
pick init-handle pick init-handle
0 0 { <lapse> {
set-port-handle set-port-handle
set-delegate set-delegate
set-port-type set-port-type
set-port-timeout set-port-lapse
set-port-cutoff
} port construct ; } port construct ;
: <buffered-port> ( handle type -- port ) : <buffered-port> ( handle type -- port )
@ -48,50 +50,14 @@ GENERIC: close-handle ( handle -- )
[ >r <reader> r> <duplex-stream> ] [ ] [ dispose ] [ >r <reader> r> <duplex-stream> ] [ ] [ dispose ]
cleanup ; cleanup ;
: timeout? ( port -- ? )
port-cutoff dup zero? not swap millis < and ;
: pending-error ( port -- ) : pending-error ( port -- )
dup port-error f rot set-port-error [ throw ] when* ; dup port-error f rot set-port-error [ throw ] when* ;
SYMBOL: timeout-queue
timeout-queue global [ [ <dlist> ] unless* ] change-at
: unqueue-timeout ( port -- )
port-timeout-entry [
timeout-queue get-global swap delete-node
] when* ;
: queue-timeout ( port -- )
dup timeout-queue get-global push-front*
swap set-port-timeout-entry ;
HOOK: cancel-io io-backend ( port -- ) HOOK: cancel-io io-backend ( port -- )
M: object cancel-io drop ; M: object cancel-io drop ;
: expire-timeouts ( -- ) M: port timed-out cancel-io ;
timeout-queue get-global dup dlist-empty? [ drop ] [
dup peek-back timeout?
[ pop-back cancel-io expire-timeouts ] [ drop ] if
] if ;
: begin-timeout ( port -- )
dup port-timeout dup zero? [
2drop
] [
millis + over set-port-cutoff
dup unqueue-timeout queue-timeout
] if ;
: end-timeout ( port -- )
unqueue-timeout ;
: with-port-timeout ( port quot -- )
over begin-timeout keep end-timeout ; inline
M: port set-timeout set-port-timeout ;
GENERIC: (wait-to-read) ( port -- ) GENERIC: (wait-to-read) ( port -- )

View File

@ -1,12 +1,12 @@
! Copyright (C) 2007 Slava Pestov. ! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
IN: io.streams.null IN: io.streams.null
USING: kernel io continuations ; USING: kernel io io.timeouts continuations ;
TUPLE: null-stream ; TUPLE: null-stream ;
M: null-stream dispose drop ; M: null-stream dispose drop ;
M: null-stream set-timeout 2drop ; M: null-stream set-timeout drop ;
M: null-stream stream-readln drop f ; M: null-stream stream-readln drop f ;
M: null-stream stream-read1 drop f ; M: null-stream stream-read1 drop f ;
M: null-stream stream-read-until 2drop f f ; M: null-stream stream-read-until 2drop f f ;

View File

@ -0,0 +1,32 @@
IN: io.timeouts
USING: help.markup help.syntax math kernel ;
HELP: get-lapse
{ $values { "obj" object } { "lapse" lapse } }
{ $contract "Outputs an object's timeout lapse descriptor." } ;
HELP: set-timeout
{ $values { "ms" integer } { "obj" object } }
{ $contract "Sets an object's timeout, in milliseconds." }
{ $notes "The default implementation delegates the call to the object's timeout lapse descriptor." } ;
HELP: timed-out
{ $values { "obj" object } }
{ $contract "Handles a timeout, usually by waking up all threads waiting on the object." } ;
HELP: with-timeout
{ $values { "obj" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- )" } } }
{ $description "Applies the quotation to the object. If the object's timeout expires before the quotation returns, " { $link timed-out } " is called on the object." } ;
ARTICLE: "io.timeouts" "I/O timeout protocol"
"Streams and processes support optional timeouts, which impose an upper bound on the length of time for which an operation on these objects can block. Timeouts are used in network servers to prevent malicious clients from holding onto connections forever, and to ensure that runaway processes get killed."
{ $subsection set-timeout }
"The I/O timeout protocol can be implemented by any class wishing to support timeouts on blocking operations."
{ $subsection get-lapse }
{ $subsection timed-out }
"A combinator to be used in operations which can time out:"
{ $subsection with-timeout }
{ $see-also "stream-protocol" "io.launcher" }
;
ABOUT: "io.timeouts"

View File

@ -0,0 +1,67 @@
! Copyright (C) 2008 Slava Pestov, Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math system dlists namespaces assocs init threads
io.streams.duplex ;
IN: io.timeouts
TUPLE: lapse entry timeout cutoff ;
: <lapse> f 0 0 \ lapse construct-boa ;
GENERIC: get-lapse ( obj -- lapse )
GENERIC: set-timeout ( ms obj -- )
M: object set-timeout get-lapse set-lapse-timeout ;
M: duplex-stream set-timeout
2dup
duplex-stream-in set-timeout
duplex-stream-out set-timeout ;
: timeout ( obj -- ms ) get-lapse lapse-timeout ;
: entry ( obj -- dlist-node ) get-lapse lapse-entry ;
: set-entry ( obj dlist-node -- ) get-lapse set-lapse-entry ;
: cutoff ( obj -- ms ) get-lapse lapse-cutoff ;
: set-cutoff ( ms obj -- ) get-lapse set-lapse-cutoff ;
SYMBOL: timeout-queue
: timeout? ( lapse -- ? )
cutoff dup zero? not swap millis < and ;
timeout-queue global [ [ <dlist> ] unless* ] change-at
: unqueue-timeout ( obj -- )
entry [
timeout-queue get-global swap delete-node
] when* ;
: queue-timeout ( obj -- )
dup timeout-queue get-global push-front*
swap set-entry ;
GENERIC: timed-out ( obj -- )
M: object timed-out drop ;
: expire-timeouts ( -- )
timeout-queue get-global dup dlist-empty? [ drop ] [
dup peek-back timeout?
[ pop-back timed-out expire-timeouts ] [ drop ] if
] if ;
: begin-timeout ( obj -- )
dup timeout dup zero? [
2drop
] [
millis + over set-cutoff
dup unqueue-timeout queue-timeout
] if ;
: with-timeout ( obj quot -- )
over begin-timeout keep unqueue-timeout ; inline
: expiry-thread ( -- )
expire-timeouts 5000 sleep expiry-thread ;
[ [ expiry-thread ] in-thread ] "io.timeouts" add-init-hook

View File

@ -3,7 +3,7 @@
USING: alien generic assocs kernel kernel.private math USING: alien generic assocs kernel kernel.private math
io.nonblocking sequences strings structs sbufs threads unix io.nonblocking sequences strings structs sbufs threads unix
vectors io.buffers io.backend io.streams.duplex math.parser vectors io.buffers io.backend io.streams.duplex math.parser
continuations system libc qualified namespaces ; continuations system libc qualified namespaces io.timeouts ;
QUALIFIED: io QUALIFIED: io
IN: io.unix.backend IN: io.unix.backend
@ -61,7 +61,7 @@ M: mx register-io-task ( task mx -- )
mx get-global register-io-task stop ; mx get-global register-io-task stop ;
: with-port-continuation ( port quot -- port ) : with-port-continuation ( port quot -- port )
[ callcc0 ] curry with-port-timeout ; inline [ callcc0 ] curry with-timeout ; inline
M: mx unregister-io-task ( task mx -- ) M: mx unregister-io-task ( task mx -- )
fd/container delete-at drop ; fd/container delete-at drop ;
@ -178,7 +178,7 @@ M: port port-flush ( port -- )
dup buffer-empty? [ drop ] [ (wait-to-write) ] if ; dup buffer-empty? [ drop ] [ (wait-to-write) ] if ;
M: unix-io io-multiplex ( ms -- ) M: unix-io io-multiplex ( ms -- )
expire-timeouts mx get-global wait-for-events ; mx get-global wait-for-events ;
M: unix-io init-stdio ( -- ) M: unix-io init-stdio ( -- )
0 1 handle>duplex-stream io:stdio set-global 0 1 handle>duplex-stream io:stdio set-global

View File

@ -1,9 +1,10 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel io.backend io.monitors io.monitors.private io.files USING: kernel io.backend io.monitors io.monitors.private
io.buffers io.nonblocking io.unix.backend io.unix.select io.files io.buffers io.nonblocking io.timeouts io.unix.backend
io.unix.launcher unix.linux.inotify assocs namespaces threads io.unix.select io.unix.launcher unix.linux.inotify assocs
continuations init math alien.c-types alien vocabs.loader ; namespaces threads continuations init math alien.c-types alien
vocabs.loader ;
IN: io.unix.linux IN: io.unix.linux
TUPLE: linux-io ; TUPLE: linux-io ;

View File

@ -1,4 +1,4 @@
USING: io.unix.backend io.unix.files io.unix.sockets USING: io.unix.backend io.unix.files io.unix.sockets io.timeouts
io.unix.launcher io.unix.mmap io.backend combinators namespaces io.unix.launcher io.unix.mmap io.backend combinators namespaces
system vocabs.loader ; system vocabs.loader ;

View File

@ -55,7 +55,7 @@ M: windows-ce-io accept ( server -- client )
] keep ] keep
] keep server-port-addr parse-sockaddr swap ] keep server-port-addr parse-sockaddr swap
<win32-socket> dup handle>duplex-stream <client-stream> <win32-socket> dup handle>duplex-stream <client-stream>
] with-port-timeout ; ] with-timeout ;
M: windows-ce-io <datagram> ( addrspec -- datagram ) M: windows-ce-io <datagram> ( addrspec -- datagram )
[ [

View File

@ -91,7 +91,7 @@ M: windows-nt-io cancel-io
port-handle win32-file-handle CancelIo drop ; port-handle win32-file-handle CancelIo drop ;
M: windows-nt-io io-multiplex ( ms -- ) M: windows-nt-io io-multiplex ( ms -- )
expire-timeouts drain-overlapped ; drain-overlapped ;
M: windows-nt-io init-io ( -- ) M: windows-nt-io init-io ( -- )
<master-completion-port> master-completion-port set-global <master-completion-port> master-completion-port set-global

View File

@ -1,8 +1,8 @@
USING: continuations destructors io.buffers io.files io.backend USING: continuations destructors io.buffers io.files io.backend
io.nonblocking io.windows io.windows.nt.backend kernel libc math io.timeouts io.nonblocking io.windows io.windows.nt.backend
threads windows windows.kernel32 alien.c-types alien.arrays kernel libc math threads windows windows.kernel32 alien.c-types
sequences combinators combinators.lib sequences.lib ascii alien.arrays sequences combinators combinators.lib sequences.lib
splitting alien strings ; ascii splitting alien strings ;
IN: io.windows.nt.files IN: io.windows.nt.files
M: windows-nt-io cwd M: windows-nt-io cwd
@ -98,7 +98,7 @@ M: windows-nt-io FileArgs-overlapped ( port -- overlapped )
] if ; ] if ;
: flush-output ( port -- ) : flush-output ( port -- )
[ [ (flush-output) ] with-port-timeout ] with-destructors ; [ [ (flush-output) ] with-timeout ] with-destructors ;
M: port port-flush M: port port-flush
dup buffer-empty? [ dup flush-output ] unless drop ; dup buffer-empty? [ dup flush-output ] unless drop ;
@ -122,4 +122,4 @@ M: port port-flush
] [ 2drop ] if ; ] [ 2drop ] if ;
M: input-port (wait-to-read) ( port -- ) M: input-port (wait-to-read) ( port -- )
[ [ ((wait-to-read)) ] with-port-timeout ] with-destructors ; [ [ ((wait-to-read)) ] with-timeout ] with-destructors ;

View File

@ -3,8 +3,9 @@
USING: alien.c-types destructors io.windows USING: alien.c-types destructors io.windows
io.windows.nt.backend kernel math windows windows.kernel32 io.windows.nt.backend kernel math windows windows.kernel32
windows.types libc assocs alien namespaces continuations windows.types libc assocs alien namespaces continuations
io.monitors io.monitors.private io.nonblocking io.buffers io.files io.monitors io.monitors.private io.nonblocking io.buffers
io sequences hashtables sorting arrays combinators ; io.files io.timeouts io sequences hashtables sorting arrays
combinators ;
IN: io.windows.nt.monitors IN: io.windows.nt.monitors
: open-directory ( path -- handle ) : open-directory ( path -- handle )
@ -52,7 +53,7 @@ M: windows-nt-io <monitor> ( path recursive? -- monitor )
swap [ save-callback ] 2keep swap [ save-callback ] 2keep
dup check-monitor ! we may have closed it... dup check-monitor ! we may have closed it...
get-overlapped-result get-overlapped-result
] with-port-timeout ] with-timeout
] with-destructors ; ] with-destructors ;
: parse-action ( action -- changed ) : parse-action ( action -- changed )

View File

@ -1,6 +1,6 @@
USING: alien alien.accessors alien.c-types byte-arrays USING: alien alien.accessors alien.c-types byte-arrays
continuations destructors io.nonblocking io io.sockets continuations destructors io.nonblocking io.timeouts io.sockets
io.sockets.impl namespaces io.streams.duplex io.windows io.sockets.impl io namespaces io.streams.duplex io.windows
io.windows.nt.backend windows.winsock kernel libc math sequences io.windows.nt.backend windows.winsock kernel libc math sequences
threads tuples.lib ; threads tuples.lib ;
IN: io.windows.nt.sockets IN: io.windows.nt.sockets
@ -139,7 +139,7 @@ M: windows-nt-io accept ( server -- client )
AcceptEx-args-port pending-error AcceptEx-args-port pending-error
dup duplex-stream-in pending-error dup duplex-stream-in pending-error
dup duplex-stream-out pending-error dup duplex-stream-out pending-error
] with-port-timeout ] with-timeout
] with-destructors ; ] with-destructors ;
M: windows-nt-io <server> ( addrspec -- server ) M: windows-nt-io <server> ( addrspec -- server )

4
extra/smtp/server/server.factor Normal file → Executable file
View File

@ -27,8 +27,8 @@
! bye ! bye
! Connection closed by foreign host. ! Connection closed by foreign host.
USING: combinators kernel prettyprint io io.server sequences USING: combinators kernel prettyprint io io.timeouts io.server
namespaces io.sockets continuations ; sequences namespaces io.sockets continuations ;
SYMBOL: data-mode SYMBOL: data-mode

View File

@ -1,8 +1,9 @@
! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels, Slava Pestov. ! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels,
! Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: namespaces io kernel logging io.sockets sequences USING: namespaces io io.timeouts kernel logging io.sockets
combinators sequences.lib splitting assocs strings math.parser sequences combinators sequences.lib splitting assocs strings
random system calendar ; math.parser random system calendar ;
IN: smtp IN: smtp

View File

@ -7,6 +7,10 @@ SYMBOL: ui-backend
HOOK: set-title ui-backend ( string world -- ) HOOK: set-title ui-backend ( string world -- )
HOOK: set-fullscreen? ui-backend ( ? world -- )
HOOK: fullscreen? ui-backend ( world -- ? )
HOOK: (open-window) ui-backend ( world -- ) HOOK: (open-window) ui-backend ( world -- )
HOOK: (close-window) ui-backend ( handle -- ) HOOK: (close-window) ui-backend ( handle -- )

View File

@ -1,6 +1,6 @@
! Copyright (C) 2006, 2007 Slava Pestov. ! Copyright (C) 2006, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays cocoa cocoa.application command-line USING: math arrays cocoa cocoa.application command-line
kernel memory namespaces cocoa.messages cocoa.runtime kernel memory namespaces cocoa.messages cocoa.runtime
cocoa.subclassing cocoa.pasteboard cocoa.types cocoa.windows cocoa.subclassing cocoa.pasteboard cocoa.types cocoa.windows
cocoa.classes cocoa.application sequences system ui ui.backend cocoa.classes cocoa.application sequences system ui ui.backend
@ -53,6 +53,18 @@ M: pasteboard set-clipboard-contents
M: cocoa-ui-backend set-title ( string world -- ) M: cocoa-ui-backend set-title ( string world -- )
world-handle second swap <NSString> -> setTitle: ; world-handle second swap <NSString> -> setTitle: ;
: enter-fullscreen ( world -- )
world-handle first NSScreen -> mainScreen f -> enterFullScreenMode:withOptions: drop ;
: exit-fullscreen ( world -- )
world-handle first f -> exitFullScreenModeWithOptions: ;
M: cocoa-ui-backend set-fullscreen? ( ? world -- )
swap [ enter-fullscreen ] [ exit-fullscreen ] if ;
M: cocoa-ui-backend fullscreen? ( world -- ? )
world-handle first -> isInFullScreenMode zero? not ;
: auto-position ( world -- ) : auto-position ( world -- )
dup world-loc { 0 0 } = [ dup world-loc { 0 0 } = [
world-handle second -> center world-handle second -> center

View File

@ -13,6 +13,15 @@ HELP: set-title
{ $description "Sets the title bar of the native window containing the world." } { $description "Sets the title bar of the native window containing the world." }
{ $notes "This word should not be called directly by user code. Instead, change the " { $link world-title } " model; see " { $link "models" } "." } ; { $notes "This word should not be called directly by user code. Instead, change the " { $link world-title } " model; see " { $link "models" } "." } ;
HELP: set-fullscreen?
{ $values { "?" "a boolean" } { "world" world } }
{ $description "Sets and unsets fullscreen mode for the world." }
{ $notes "Find a world using " { $link find-world } "." } ;
HELP: fullscreen?
{ $values { "world" world } { "?" "a boolean" } }
{ $description "Queries the world to see if it is running in fullscreen mode." } ;
HELP: raise-window HELP: raise-window
{ $values { "world" world } } { $values { "world" world } }
{ $description "Makes the native window containing the given world the front-most window." } { $description "Makes the native window containing the given world the front-most window." }

View File

@ -21,21 +21,21 @@ TUPLE: walker model interpreter history ;
: walker-active? ( walker -- ? ) : walker-active? ( walker -- ? )
walker-interpreter interpreter-continuation >boolean ; walker-interpreter interpreter-continuation >boolean ;
: walker-command ( gadget quot -- )
over walker-active? [ with-walker ] [ 2drop ] if ; inline
: save-interpreter ( walker -- ) : save-interpreter ( walker -- )
dup walker-interpreter interpreter-continuation clone dup walker-interpreter interpreter-continuation clone
swap walker-history push ; swap walker-history push ;
: com-step ( walker -- ) : walker-command ( gadget quot -- )
dup save-interpreter [ step ] walker-command ; over walker-active? [
over save-interpreter
with-walker
] [ 2drop ] if ; inline
: com-into ( walker -- ) : com-step ( walker -- ) [ step ] walker-command ;
dup save-interpreter [ step-into ] walker-command ;
: com-out ( walker -- ) : com-into ( walker -- ) [ step-into ] walker-command ;
dup save-interpreter [ step-out ] walker-command ;
: com-out ( walker -- ) [ step-out ] walker-command ;
: com-back ( walker -- ) : com-back ( walker -- )
dup walker-history dup walker-history