Merge branch 'master' of git://factorcode.org/git/factor
Eduardo Cavazos
commit
f8ce84115c
|
|
@ -78,7 +78,7 @@ $nl
|
|||
"<< \"freetype\" {"
|
||||
" { [ os macosx? ] [ \"libfreetype.6.dylib\" \"cdecl\" add-library ] }"
|
||||
" { [ os windows? ] [ \"freetype6.dll\" \"cdecl\" add-library ] }"
|
||||
" { [ t ] [ drop ] }"
|
||||
" [ drop ]"
|
||||
"} cond >>"
|
||||
}
|
||||
"Note the parse time evaluation with " { $link POSTPONE: << } "." } ;
|
||||
|
|
|
|||
|
|
@ -375,7 +375,7 @@ TUPLE: callback-context ;
|
|||
return>> {
|
||||
{ [ dup "void" = ] [ drop [ ] ] }
|
||||
{ [ dup large-struct? ] [ heap-size [ memcpy ] curry ] }
|
||||
{ [ t ] [ c-type c-type-prep ] }
|
||||
[ c-type c-type-prep ]
|
||||
} cond ;
|
||||
|
||||
: wrap-callback-quot ( node -- quot )
|
||||
|
|
@ -390,7 +390,7 @@ TUPLE: callback-context ;
|
|||
{
|
||||
{ [ dup abi>> "stdcall" = ] [ alien-stack-frame ] }
|
||||
{ [ dup return>> large-struct? ] [ drop 4 ] }
|
||||
{ [ t ] [ drop 0 ] }
|
||||
[ drop 0 ]
|
||||
} cond ;
|
||||
|
||||
: %callback-return ( node -- )
|
||||
|
|
|
|||
|
|
@ -68,7 +68,7 @@ M: alien pprint*
|
|||
{
|
||||
{ [ dup expired? ] [ drop "( alien expired )" text ] }
|
||||
{ [ dup pinned-c-ptr? not ] [ drop "( displaced alien )" text ] }
|
||||
{ [ t ] [ \ ALIEN: [ alien-address pprint* ] pprint-prefix ] }
|
||||
[ \ ALIEN: [ alien-address pprint* ] pprint-prefix ]
|
||||
} cond ;
|
||||
|
||||
M: dll pprint* dll-path dup "DLL\" " "\"" pprint-string ;
|
||||
|
|
|
|||
|
|
@ -84,7 +84,7 @@ C: <anonymous-complement> anonymous-complement
|
|||
{ [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }
|
||||
{ [ dup members ] [ right-union-class< ] }
|
||||
{ [ over superclass ] [ superclass< ] }
|
||||
{ [ t ] [ 2drop f ] }
|
||||
[ 2drop f ]
|
||||
} cond ;
|
||||
|
||||
: anonymous-union-intersect? ( first second -- ? )
|
||||
|
|
@ -104,14 +104,14 @@ C: <anonymous-complement> anonymous-complement
|
|||
{ [ over tuple eq? ] [ 2drop t ] }
|
||||
{ [ over builtin-class? ] [ 2drop f ] }
|
||||
{ [ over tuple-class? ] [ [ class< ] [ swap class< ] 2bi or ] }
|
||||
{ [ t ] [ swap classes-intersect? ] }
|
||||
[ swap classes-intersect? ]
|
||||
} cond ;
|
||||
|
||||
: builtin-class-intersect? ( first second -- ? )
|
||||
{
|
||||
{ [ 2dup eq? ] [ 2drop t ] }
|
||||
{ [ over builtin-class? ] [ 2drop f ] }
|
||||
{ [ t ] [ swap classes-intersect? ] }
|
||||
[ swap classes-intersect? ]
|
||||
} cond ;
|
||||
|
||||
: (classes-intersect?) ( first second -- ? )
|
||||
|
|
@ -154,7 +154,7 @@ C: <anonymous-complement> anonymous-complement
|
|||
{ [ over members ] [ left-union-and ] }
|
||||
{ [ over anonymous-union? ] [ left-anonymous-union-and ] }
|
||||
{ [ over anonymous-intersection? ] [ left-anonymous-intersection-and ] }
|
||||
{ [ t ] [ 2array <anonymous-intersection> ] }
|
||||
[ 2array <anonymous-intersection> ]
|
||||
} cond ;
|
||||
|
||||
: left-anonymous-union-or ( first second -- class )
|
||||
|
|
@ -169,7 +169,7 @@ C: <anonymous-complement> anonymous-complement
|
|||
{ [ 2dup swap class< ] [ drop ] }
|
||||
{ [ dup anonymous-union? ] [ right-anonymous-union-or ] }
|
||||
{ [ over anonymous-union? ] [ left-anonymous-union-or ] }
|
||||
{ [ t ] [ 2array <anonymous-union> ] }
|
||||
[ 2array <anonymous-union> ]
|
||||
} cond ;
|
||||
|
||||
: (class-not) ( class -- complement )
|
||||
|
|
@ -177,7 +177,7 @@ C: <anonymous-complement> anonymous-complement
|
|||
{ [ dup anonymous-complement? ] [ class>> ] }
|
||||
{ [ dup object eq? ] [ drop null ] }
|
||||
{ [ dup null eq? ] [ drop object ] }
|
||||
{ [ t ] [ <anonymous-complement> ] }
|
||||
[ <anonymous-complement> ]
|
||||
} cond ;
|
||||
|
||||
: largest-class ( seq -- n elt )
|
||||
|
|
@ -205,7 +205,7 @@ C: <anonymous-complement> anonymous-complement
|
|||
{ [ dup builtin-class? ] [ dup set ] }
|
||||
{ [ dup members ] [ members [ (flatten-class) ] each ] }
|
||||
{ [ dup superclass ] [ superclass (flatten-class) ] }
|
||||
{ [ t ] [ drop ] }
|
||||
[ drop ]
|
||||
} cond ;
|
||||
|
||||
: flatten-class ( class -- assoc )
|
||||
|
|
|
|||
|
|
@ -49,7 +49,7 @@ M: mixin-instance equal?
|
|||
{ [ over mixin-instance? not ] [ f ] }
|
||||
{ [ 2dup [ mixin-instance-class ] bi@ = not ] [ f ] }
|
||||
{ [ 2dup [ mixin-instance-mixin ] bi@ = not ] [ f ] }
|
||||
{ [ t ] [ t ] }
|
||||
[ t ]
|
||||
} cond 2nip ;
|
||||
|
||||
M: mixin-instance hashcode*
|
||||
|
|
|
|||
|
|
@ -64,9 +64,9 @@ HELP: alist>quot
|
|||
{ $notes "This word is used to implement compile-time behavior for " { $link cond } ", and it is also used by the generic word system. Note that unlike " { $link cond } ", the constructed quotation performs the tests starting from the end and not the beginning." } ;
|
||||
|
||||
HELP: cond
|
||||
{ $values { "assoc" "a sequence of quotation pairs" } }
|
||||
{ $values { "assoc" "a sequence of quotation pairs and an optional quotation" } }
|
||||
{ $description
|
||||
"Calls the second quotation in the first pair whose first quotation yields a true value."
|
||||
"Calls the second quotation in the first pair whose first quotation yields a true value. A single quotation will always yield a true value."
|
||||
$nl
|
||||
"The following two phrases are equivalent:"
|
||||
{ $code "{ { [ X ] [ Y ] } { [ Z ] [ T ] } } cond" }
|
||||
|
|
@ -78,7 +78,7 @@ HELP: cond
|
|||
"{"
|
||||
" { [ dup 0 > ] [ \"positive\" ] }"
|
||||
" { [ dup 0 < ] [ \"negative\" ] }"
|
||||
" { [ dup zero? ] [ \"zero\" ] }"
|
||||
" [ \"zero\" ]"
|
||||
"} cond"
|
||||
}
|
||||
} ;
|
||||
|
|
@ -88,9 +88,9 @@ HELP: no-cond
|
|||
{ $error-description "Thrown by " { $link cond } " if none of the test quotations yield a true value. Some uses of " { $link cond } " include a default case where the test quotation is " { $snippet "[ t ]" } "; such a " { $link cond } " form will never throw this error." } ;
|
||||
|
||||
HELP: case
|
||||
{ $values { "obj" object } { "assoc" "a sequence of object/quotation pairs, with an optional quotation at the end" } }
|
||||
{ $values { "obj" object } { "assoc" "a sequence of object/word,quotation pairs, with an optional quotation at the end" } }
|
||||
{ $description
|
||||
"Compares " { $snippet "obj" } " against the first element of every pair. If some pair matches, removes " { $snippet "obj" } " from the stack and calls the second element of that pair, which must be a quotation."
|
||||
"Compares " { $snippet "obj" } " against the first element of every pair, first evaluating the first element if it is a word. If some pair matches, removes " { $snippet "obj" } " from the stack and calls the second element of that pair, which must be a quotation."
|
||||
$nl
|
||||
"If there is no case matching " { $snippet "obj" } ", the default case is taken. If the last element of " { $snippet "cases" } " is a quotation, the quotation is called with " { $snippet "obj" } " on the stack. Otherwise, a " { $link no-cond } " error is rasied."
|
||||
$nl
|
||||
|
|
|
|||
|
|
@ -1,7 +1,54 @@
|
|||
IN: combinators.tests
|
||||
USING: alien strings kernel math tools.test io prettyprint
|
||||
namespaces combinators words ;
|
||||
namespaces combinators words classes sequences ;
|
||||
IN: combinators.tests
|
||||
|
||||
! Compiled
|
||||
: cond-test-1 ( obj -- str )
|
||||
{
|
||||
{ [ dup 2 mod 0 = ] [ drop "even" ] }
|
||||
{ [ dup 2 mod 1 = ] [ drop "odd" ] }
|
||||
} cond ;
|
||||
|
||||
\ cond-test-1 must-infer
|
||||
|
||||
[ "even" ] [ 2 cond-test-1 ] unit-test
|
||||
[ "odd" ] [ 3 cond-test-1 ] unit-test
|
||||
|
||||
: cond-test-2 ( obj -- str )
|
||||
{
|
||||
{ [ dup t = ] [ drop "true" ] }
|
||||
{ [ dup f = ] [ drop "false" ] }
|
||||
[ drop "something else" ]
|
||||
} cond ;
|
||||
|
||||
\ cond-test-2 must-infer
|
||||
|
||||
[ "true" ] [ t cond-test-2 ] unit-test
|
||||
[ "false" ] [ f cond-test-2 ] unit-test
|
||||
[ "something else" ] [ "ohio" cond-test-2 ] unit-test
|
||||
|
||||
: cond-test-3 ( obj -- str )
|
||||
{
|
||||
[ drop "something else" ]
|
||||
{ [ dup t = ] [ drop "true" ] }
|
||||
{ [ dup f = ] [ drop "false" ] }
|
||||
} cond ;
|
||||
|
||||
\ cond-test-3 must-infer
|
||||
|
||||
[ "something else" ] [ t cond-test-3 ] unit-test
|
||||
[ "something else" ] [ f cond-test-3 ] unit-test
|
||||
[ "something else" ] [ "ohio" cond-test-3 ] unit-test
|
||||
|
||||
: cond-test-4 ( -- )
|
||||
{
|
||||
} cond ;
|
||||
|
||||
\ cond-test-4 must-infer
|
||||
|
||||
[ cond-test-4 ] [ class \ no-cond = ] must-fail-with
|
||||
|
||||
! Interpreted
|
||||
[ "even" ] [
|
||||
2 {
|
||||
{ [ dup 2 mod 0 = ] [ drop "even" ] }
|
||||
|
|
@ -21,11 +68,66 @@ namespaces combinators words ;
|
|||
{ [ dup string? ] [ drop "string" ] }
|
||||
{ [ dup float? ] [ drop "float" ] }
|
||||
{ [ dup alien? ] [ drop "alien" ] }
|
||||
{ [ t ] [ drop "neither" ] }
|
||||
[ drop "neither" ]
|
||||
} cond
|
||||
] unit-test
|
||||
|
||||
: case-test-1
|
||||
[ "neither" ] [
|
||||
3 {
|
||||
{ [ dup string? ] [ drop "string" ] }
|
||||
{ [ dup float? ] [ drop "float" ] }
|
||||
{ [ dup alien? ] [ drop "alien" ] }
|
||||
[ drop "neither" ]
|
||||
} cond
|
||||
] unit-test
|
||||
|
||||
[ "neither" ] [
|
||||
3 {
|
||||
{ [ dup string? ] [ drop "string" ] }
|
||||
{ [ dup float? ] [ drop "float" ] }
|
||||
{ [ dup alien? ] [ drop "alien" ] }
|
||||
[ drop "neither" ]
|
||||
} cond
|
||||
] unit-test
|
||||
|
||||
[ "early" ] [
|
||||
2 {
|
||||
{ [ dup 2 mod 1 = ] [ drop "odd" ] }
|
||||
[ drop "early" ]
|
||||
{ [ dup 2 mod 0 = ] [ drop "even" ] }
|
||||
} cond
|
||||
] unit-test
|
||||
|
||||
[ "really early" ] [
|
||||
2 {
|
||||
[ drop "really early" ]
|
||||
{ [ dup 2 mod 1 = ] [ drop "odd" ] }
|
||||
{ [ dup 2 mod 0 = ] [ drop "even" ] }
|
||||
} cond
|
||||
] unit-test
|
||||
|
||||
[ { } cond ] [ class \ no-cond = ] must-fail-with
|
||||
|
||||
[ "early" ] [
|
||||
2 {
|
||||
{ [ dup 2 mod 1 = ] [ drop "odd" ] }
|
||||
[ drop "early" ]
|
||||
{ [ dup 2 mod 0 = ] [ drop "even" ] }
|
||||
} cond
|
||||
] unit-test
|
||||
|
||||
[ "really early" ] [
|
||||
2 {
|
||||
[ drop "really early" ]
|
||||
{ [ dup 2 mod 1 = ] [ drop "odd" ] }
|
||||
{ [ dup 2 mod 0 = ] [ drop "even" ] }
|
||||
} cond
|
||||
] unit-test
|
||||
|
||||
[ { } cond ] [ class \ no-cond = ] must-fail-with
|
||||
|
||||
! Compiled
|
||||
: case-test-1 ( obj -- obj' )
|
||||
{
|
||||
{ 1 [ "one" ] }
|
||||
{ 2 [ "two" ] }
|
||||
|
|
@ -33,6 +135,8 @@ namespaces combinators words ;
|
|||
{ 4 [ "four" ] }
|
||||
} case ;
|
||||
|
||||
\ case-test-1 must-infer
|
||||
|
||||
[ "two" ] [ 2 case-test-1 ] unit-test
|
||||
|
||||
! Interpreted
|
||||
|
|
@ -40,7 +144,7 @@ namespaces combinators words ;
|
|||
|
||||
[ "x" case-test-1 ] must-fail
|
||||
|
||||
: case-test-2
|
||||
: case-test-2 ( obj -- obj' )
|
||||
{
|
||||
{ 1 [ "one" ] }
|
||||
{ 2 [ "two" ] }
|
||||
|
|
@ -49,12 +153,14 @@ namespaces combinators words ;
|
|||
[ sq ]
|
||||
} case ;
|
||||
|
||||
\ case-test-2 must-infer
|
||||
|
||||
[ 25 ] [ 5 case-test-2 ] unit-test
|
||||
|
||||
! Interpreted
|
||||
[ 25 ] [ 5 \ case-test-2 word-def call ] unit-test
|
||||
|
||||
: case-test-3
|
||||
: case-test-3 ( obj -- obj' )
|
||||
{
|
||||
{ 1 [ "one" ] }
|
||||
{ 2 [ "two" ] }
|
||||
|
|
@ -65,8 +171,122 @@ namespaces combinators words ;
|
|||
[ sq ]
|
||||
} case ;
|
||||
|
||||
\ case-test-3 must-infer
|
||||
|
||||
[ "an array" ] [ { 1 2 3 } case-test-3 ] unit-test
|
||||
|
||||
: case-const-1 1 ;
|
||||
: case-const-2 2 ; inline
|
||||
|
||||
! Compiled
|
||||
: case-test-4 ( obj -- str )
|
||||
{
|
||||
{ case-const-1 [ "uno" ] }
|
||||
{ case-const-2 [ "dos" ] }
|
||||
{ 3 [ "tres" ] }
|
||||
{ 4 [ "cuatro" ] }
|
||||
{ 5 [ "cinco" ] }
|
||||
[ drop "demasiado" ]
|
||||
} case ;
|
||||
|
||||
\ case-test-4 must-infer
|
||||
|
||||
[ "uno" ] [ 1 case-test-4 ] unit-test
|
||||
[ "dos" ] [ 2 case-test-4 ] unit-test
|
||||
[ "tres" ] [ 3 case-test-4 ] unit-test
|
||||
[ "demasiado" ] [ 100 case-test-4 ] unit-test
|
||||
|
||||
: case-test-5 ( obj -- )
|
||||
{
|
||||
{ case-const-1 [ "uno" print ] }
|
||||
{ case-const-2 [ "dos" print ] }
|
||||
{ 3 [ "tres" print ] }
|
||||
{ 4 [ "cuatro" print ] }
|
||||
{ 5 [ "cinco" print ] }
|
||||
[ drop "demasiado" print ]
|
||||
} case ;
|
||||
|
||||
\ case-test-5 must-infer
|
||||
|
||||
[ ] [ 1 case-test-5 ] unit-test
|
||||
|
||||
! Interpreted
|
||||
[ "uno" ] [
|
||||
1 {
|
||||
{ case-const-1 [ "uno" ] }
|
||||
{ case-const-2 [ "dos" ] }
|
||||
{ 3 [ "tres" ] }
|
||||
{ 4 [ "cuatro" ] }
|
||||
{ 5 [ "cinco" ] }
|
||||
[ drop "demasiado" ]
|
||||
} case
|
||||
] unit-test
|
||||
|
||||
[ "dos" ] [
|
||||
2 {
|
||||
{ case-const-1 [ "uno" ] }
|
||||
{ case-const-2 [ "dos" ] }
|
||||
{ 3 [ "tres" ] }
|
||||
{ 4 [ "cuatro" ] }
|
||||
{ 5 [ "cinco" ] }
|
||||
[ drop "demasiado" ]
|
||||
} case
|
||||
] unit-test
|
||||
|
||||
[ "tres" ] [
|
||||
3 {
|
||||
{ case-const-1 [ "uno" ] }
|
||||
{ case-const-2 [ "dos" ] }
|
||||
{ 3 [ "tres" ] }
|
||||
{ 4 [ "cuatro" ] }
|
||||
{ 5 [ "cinco" ] }
|
||||
[ drop "demasiado" ]
|
||||
} case
|
||||
] unit-test
|
||||
|
||||
[ "demasiado" ] [
|
||||
100 {
|
||||
{ case-const-1 [ "uno" ] }
|
||||
{ case-const-2 [ "dos" ] }
|
||||
{ 3 [ "tres" ] }
|
||||
{ 4 [ "cuatro" ] }
|
||||
{ 5 [ "cinco" ] }
|
||||
[ drop "demasiado" ]
|
||||
} case
|
||||
] unit-test
|
||||
|
||||
: do-not-call "do not call" throw ;
|
||||
|
||||
: test-case-6
|
||||
{
|
||||
{ \ do-not-call [ "do-not-call" ] }
|
||||
{ 3 [ "three" ] }
|
||||
} case ;
|
||||
|
||||
[ "three" ] [ 3 test-case-6 ] unit-test
|
||||
[ "do-not-call" ] [ \ do-not-call test-case-6 ] unit-test
|
||||
|
||||
[ "three" ] [
|
||||
3 {
|
||||
{ \ do-not-call [ "do-not-call" ] }
|
||||
{ 3 [ "three" ] }
|
||||
} case
|
||||
] unit-test
|
||||
|
||||
[ "do-not-call" ] [
|
||||
[ do-not-call ] first {
|
||||
{ \ do-not-call [ "do-not-call" ] }
|
||||
{ 3 [ "three" ] }
|
||||
} case
|
||||
] unit-test
|
||||
|
||||
[ "do-not-call" ] [
|
||||
\ do-not-call {
|
||||
{ \ do-not-call [ "do-not-call" ] }
|
||||
{ 3 [ "three" ] }
|
||||
} case
|
||||
] unit-test
|
||||
|
||||
! Interpreted
|
||||
[ "a hashtable" ] [ H{ } \ case-test-3 word-def call ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
IN: combinators
|
||||
USING: arrays sequences sequences.private math.private
|
||||
kernel kernel.private math assocs quotations vectors
|
||||
hashtables sorting ;
|
||||
hashtables sorting words ;
|
||||
|
||||
: cleave ( x seq -- )
|
||||
[ call ] with each ;
|
||||
|
|
@ -34,13 +34,24 @@ hashtables sorting ;
|
|||
ERROR: no-cond ;
|
||||
|
||||
: cond ( assoc -- )
|
||||
[ first call ] find nip dup [ second call ] [ no-cond ] if ;
|
||||
[ dup callable? [ drop t ] [ first call ] if ] find nip
|
||||
[ dup callable? [ call ] [ second call ] if ]
|
||||
[ no-cond ] if* ;
|
||||
|
||||
ERROR: no-case ;
|
||||
: case-find ( obj assoc -- obj' )
|
||||
[
|
||||
dup array? [
|
||||
dupd first dup word? [
|
||||
execute
|
||||
] [
|
||||
dup wrapper? [ wrapped ] when
|
||||
] if =
|
||||
] [ quotation? ] if
|
||||
] find nip ;
|
||||
|
||||
: case ( obj assoc -- )
|
||||
[ dup array? [ dupd first = ] [ quotation? ] if ] find nip
|
||||
{
|
||||
case-find {
|
||||
{ [ dup array? ] [ nip second call ] }
|
||||
{ [ dup quotation? ] [ call ] }
|
||||
{ [ dup not ] [ no-case ] }
|
||||
|
|
@ -73,11 +84,14 @@ M: hashtable hashcode*
|
|||
[ rot \ if 3array append [ ] like ] assoc-each ;
|
||||
|
||||
: cond>quot ( assoc -- quot )
|
||||
[ dup callable? [ [ t ] swap 2array ] when ] map
|
||||
reverse [ no-cond ] swap alist>quot ;
|
||||
|
||||
: linear-case-quot ( default assoc -- quot )
|
||||
[ >r [ dupd = ] curry r> \ drop prefix ] assoc-map
|
||||
alist>quot ;
|
||||
[
|
||||
[ 1quotation \ dup prefix \ = suffix ]
|
||||
[ \ drop prefix ] bi*
|
||||
] assoc-map alist>quot ;
|
||||
|
||||
: (distribute-buckets) ( buckets pair keys -- )
|
||||
dup t eq? [
|
||||
|
|
@ -135,7 +149,9 @@ M: hashtable hashcode*
|
|||
dup empty? [
|
||||
drop
|
||||
] [
|
||||
dup length 4 <= [
|
||||
dup length 4 <=
|
||||
over keys [ word? ] contains? or
|
||||
[
|
||||
linear-case-quot
|
||||
] [
|
||||
dup keys contiguous-range? [
|
||||
|
|
|
|||
|
|
@ -187,7 +187,7 @@ DEFER: countdown-b
|
|||
{ [ dup string? ] [ drop "string" ] }
|
||||
{ [ dup float? ] [ drop "float" ] }
|
||||
{ [ dup alien? ] [ drop "alien" ] }
|
||||
{ [ t ] [ drop "neither" ] }
|
||||
[ drop "neither" ]
|
||||
} cond
|
||||
] compile-call
|
||||
] unit-test
|
||||
|
|
@ -196,7 +196,7 @@ DEFER: countdown-b
|
|||
[
|
||||
3 {
|
||||
{ [ dup fixnum? ] [ ] }
|
||||
{ [ t ] [ drop t ] }
|
||||
[ drop t ]
|
||||
} cond
|
||||
] compile-call
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -90,7 +90,11 @@ ABOUT: "continuations"
|
|||
|
||||
HELP: dispose
|
||||
{ $values { "object" "a disposable object" } }
|
||||
{ $contract "Releases operating system resources associated with a disposable object. No further operations can be performed on a disposable object after this call. Disposable objects include streams, memory mapped files, and so on." }
|
||||
{ $contract "Releases operating system resources associated with a disposable object. Disposable objects include streams, memory mapped files, and so on."
|
||||
$nl
|
||||
"No further operations can be performed on a disposable object after this call."
|
||||
$nl
|
||||
"Disposing an object which has already been disposed should have no effect, and in particular it should not fail with an error." }
|
||||
{ $notes "You must close disposable objects after you are finished working with them, to avoid leaking operating system resources. A convenient way to automate this is by using the " { $link with-disposal } " word." } ;
|
||||
|
||||
HELP: with-disposal
|
||||
|
|
|
|||
|
|
@ -246,9 +246,8 @@ M: x86.32 %cleanup ( alien-node -- )
|
|||
} {
|
||||
[ dup return>> large-struct? ]
|
||||
[ drop EAX PUSH ]
|
||||
} {
|
||||
[ t ] [ drop ]
|
||||
}
|
||||
[ drop ]
|
||||
} cond ;
|
||||
|
||||
M: x86.32 %unwind ( n -- ) %epilogue-later RET ;
|
||||
|
|
|
|||
|
|
@ -189,7 +189,7 @@ UNION: operand register indirect ;
|
|||
{
|
||||
{ [ dup register-128? ] [ drop operand-64? ] }
|
||||
{ [ dup not ] [ drop operand-64? ] }
|
||||
{ [ t ] [ nip operand-64? ] }
|
||||
[ nip operand-64? ]
|
||||
} cond and ;
|
||||
|
||||
: rex.r
|
||||
|
|
|
|||
|
|
@ -160,7 +160,7 @@ PREDICATE: kernel-error < array
|
|||
{
|
||||
{ [ dup empty? ] [ drop f ] }
|
||||
{ [ dup first "kernel-error" = not ] [ drop f ] }
|
||||
{ [ t ] [ second 0 15 between? ] }
|
||||
[ second 0 15 between? ]
|
||||
} cond ;
|
||||
|
||||
: kernel-errors
|
||||
|
|
|
|||
|
|
@ -126,7 +126,7 @@ PRIVATE>
|
|||
{
|
||||
{ [ over front>> over eq? ] [ drop pop-front* ] }
|
||||
{ [ over back>> over eq? ] [ drop pop-back* ] }
|
||||
{ [ t ] [ unlink-node dec-length ] }
|
||||
[ unlink-node dec-length ]
|
||||
} cond ;
|
||||
|
||||
: delete-node-if* ( dlist quot -- obj/f ? )
|
||||
|
|
|
|||
|
|
@ -20,7 +20,7 @@ TUPLE: effect in out terminated? ;
|
|||
{ [ dup effect-terminated? ] [ f ] }
|
||||
{ [ 2dup [ effect-in length ] bi@ > ] [ f ] }
|
||||
{ [ 2dup [ effect-height ] bi@ = not ] [ f ] }
|
||||
{ [ t ] [ t ] }
|
||||
[ t ]
|
||||
} cond 2nip ;
|
||||
|
||||
GENERIC: (stack-picture) ( obj -- str )
|
||||
|
|
|
|||
|
|
@ -40,8 +40,8 @@ M: label fixup*
|
|||
|
||||
M: word fixup*
|
||||
{
|
||||
{ %prologue-later [ dup [ %prologue ] if-stack-frame ] }
|
||||
{ %epilogue-later [ dup [ %epilogue ] if-stack-frame ] }
|
||||
{ \ %prologue-later [ dup [ %prologue ] if-stack-frame ] }
|
||||
{ \ %epilogue-later [ dup [ %epilogue ] if-stack-frame ] }
|
||||
} case ;
|
||||
|
||||
SYMBOL: relocation-table
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ SYMBOL: compiled
|
|||
{ [ dup compiled get key? ] [ drop ] }
|
||||
{ [ dup inlined-block? ] [ drop ] }
|
||||
{ [ dup primitive? ] [ drop ] }
|
||||
{ [ t ] [ dup compile-queue get set-at ] }
|
||||
[ dup compile-queue get set-at ]
|
||||
} cond ;
|
||||
|
||||
: maybe-compile ( word -- )
|
||||
|
|
|
|||
|
|
@ -195,7 +195,7 @@ INSTANCE: constant value
|
|||
{ [ dup byte-array class< ] [ drop %unbox-byte-array ] }
|
||||
{ [ dup bit-array class< ] [ drop %unbox-byte-array ] }
|
||||
{ [ dup float-array class< ] [ drop %unbox-byte-array ] }
|
||||
{ [ t ] [ drop %unbox-any-c-ptr ] }
|
||||
[ drop %unbox-any-c-ptr ]
|
||||
} cond ; inline
|
||||
|
||||
: %move-via-temp ( dst src -- )
|
||||
|
|
@ -357,14 +357,14 @@ SYMBOL: fresh-objects
|
|||
{ [ dup unboxed-c-ptr eq? ] [
|
||||
over { unboxed-byte-array unboxed-alien } member?
|
||||
] }
|
||||
{ [ t ] [ f ] }
|
||||
[ f ]
|
||||
} cond 2nip ;
|
||||
|
||||
: allocation ( value spec -- reg-class )
|
||||
{
|
||||
{ [ dup quotation? ] [ 2drop f ] }
|
||||
{ [ 2dup compatible? ] [ 2drop f ] }
|
||||
{ [ t ] [ nip reg-spec>class ] }
|
||||
[ nip reg-spec>class ]
|
||||
} cond ;
|
||||
|
||||
: alloc-vreg-for ( value spec -- vreg )
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@ PREDICATE: math-class < class
|
|||
{
|
||||
{ [ dup null class< ] [ drop { -1 -1 } ] }
|
||||
{ [ dup math-class? ] [ class-types last/first ] }
|
||||
{ [ t ] [ drop { 100 100 } ] }
|
||||
[ drop { 100 100 } ]
|
||||
} cond ;
|
||||
|
||||
: math-class-max ( class class -- class )
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@ C: <predicate-dispatch-engine> predicate-dispatch-engine
|
|||
{ [ dup empty? ] [ drop [ "Unreachable" throw ] { } ] }
|
||||
{ [ dup length 1 = ] [ first second { } ] }
|
||||
{ [ dup keep-going? ] [ 1 tail-slice prune-redundant-predicates ] }
|
||||
{ [ t ] [ [ first second ] [ 1 tail-slice ] bi ] }
|
||||
[ [ first second ] [ 1 tail-slice ] bi ]
|
||||
} cond ;
|
||||
|
||||
: sort-methods ( assoc -- assoc' )
|
||||
|
|
|
|||
|
|
@ -110,6 +110,9 @@ ERROR: no-next-method class generic ;
|
|||
\ if ,
|
||||
] [ ] make ;
|
||||
|
||||
: single-effective-method ( obj word -- method )
|
||||
[ order [ instance? ] with find-last nip ] keep method ;
|
||||
|
||||
TUPLE: standard-combination # ;
|
||||
|
||||
C: <standard-combination> standard-combination
|
||||
|
|
@ -142,8 +145,7 @@ M: standard-combination next-method-quot*
|
|||
] with-standard ;
|
||||
|
||||
M: standard-generic effective-method
|
||||
[ dispatch# (picker) call ] keep
|
||||
[ order [ instance? ] with find-last nip ] keep method ;
|
||||
[ dispatch# (picker) call ] keep single-effective-method ;
|
||||
|
||||
TUPLE: hook-combination var ;
|
||||
|
||||
|
|
@ -161,6 +163,10 @@ M: hook-combination dispatch# drop 0 ;
|
|||
|
||||
M: hook-generic extra-values drop 1 ;
|
||||
|
||||
M: hook-generic effective-method
|
||||
[ "combination" word-prop var>> get ] keep
|
||||
single-effective-method ;
|
||||
|
||||
M: hook-combination make-default-method
|
||||
[ error-method ] with-hook ;
|
||||
|
||||
|
|
|
|||
|
|
@ -21,12 +21,12 @@ HELP: graph
|
|||
|
||||
HELP: add-vertex
|
||||
{ $values { "vertex" object } { "edges" "a sequence" } { "graph" "an assoc mapping vertices to sequences of edges" } }
|
||||
{ $description "Adds a vertex to a directed graph, using the " { $snippet "edges" } " quotation to generate a sequence of edges leaving the vertex." }
|
||||
{ $description "Adds a vertex to a directed graph, with " { $snippet "edges" } " as the outward edges from the vertex." }
|
||||
{ $side-effects "graph" } ;
|
||||
|
||||
HELP: remove-vertex
|
||||
{ $values { "vertex" object } { "edges" "a sequence" } { "graph" "an assoc mapping vertices to sequences of edges" } }
|
||||
{ $description "Removes a vertex from a graph, using the quotation to generate a sequence of edges leaving the vertex." }
|
||||
{ $description "Removes a vertex from a graph, using the given edges sequence." }
|
||||
{ $notes "The " { $snippet "edges" } " sequence must equal the value passed to " { $link add-vertex } ", otherwise some vertices of the graph may continue to refer to the removed vertex." }
|
||||
{ $side-effects "graph" } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -251,7 +251,7 @@ TUPLE: cannot-unify-specials ;
|
|||
{ [ dup [ curried? ] all? ] [ unify-curries ] }
|
||||
{ [ dup [ composed? ] all? ] [ unify-composed ] }
|
||||
{ [ dup [ special? ] contains? ] [ cannot-unify-specials ] }
|
||||
{ [ t ] [ drop <computed> ] }
|
||||
[ drop <computed> ]
|
||||
} cond ;
|
||||
|
||||
: unify-stacks ( seq -- stack )
|
||||
|
|
@ -395,7 +395,7 @@ TUPLE: effect-error word effect ;
|
|||
{ [ dup "infer" word-prop ] [ custom-infer ] }
|
||||
{ [ dup "no-effect" word-prop ] [ no-effect ] }
|
||||
{ [ dup "inferred-effect" word-prop ] [ cached-infer ] }
|
||||
{ [ t ] [ dup infer-word make-call-node ] }
|
||||
[ dup infer-word make-call-node ]
|
||||
} cond ;
|
||||
|
||||
TUPLE: recursive-declare-error word ;
|
||||
|
|
|
|||
|
|
@ -33,7 +33,7 @@ TUPLE: utf8 ;
|
|||
{ [ dup -5 shift BIN: 110 number= ] [ double ] }
|
||||
{ [ dup -4 shift BIN: 1110 number= ] [ triple ] }
|
||||
{ [ dup -3 shift BIN: 11110 number= ] [ quad ] }
|
||||
{ [ t ] [ drop replacement-char ] }
|
||||
[ drop replacement-char ]
|
||||
} cond ;
|
||||
|
||||
: decode-utf8 ( stream -- char/f )
|
||||
|
|
@ -59,12 +59,12 @@ M: utf8 decode-char
|
|||
2dup -6 shift encoded
|
||||
encoded
|
||||
] }
|
||||
{ [ t ] [
|
||||
[
|
||||
2dup -18 shift BIN: 11110000 bitor swap stream-write1
|
||||
2dup -12 shift encoded
|
||||
2dup -6 shift encoded
|
||||
encoded
|
||||
] }
|
||||
]
|
||||
} cond ;
|
||||
|
||||
M: utf8 encode-char
|
||||
|
|
|
|||
|
|
@ -112,8 +112,7 @@ ARTICLE: "io.files" "Basic file operations"
|
|||
{ $subsection "file-streams" }
|
||||
{ $subsection "fs-meta" }
|
||||
{ $subsection "directories" }
|
||||
{ $subsection "delete-move-copy" }
|
||||
{ $see-also "os" } ;
|
||||
{ $subsection "delete-move-copy" } ;
|
||||
|
||||
ABOUT: "io.files"
|
||||
|
||||
|
|
|
|||
|
|
@ -95,7 +95,7 @@ ERROR: no-parent-directory path ;
|
|||
1 tail left-trim-separators append-path-empty
|
||||
] }
|
||||
{ [ dup head..? ] [ drop no-parent-directory ] }
|
||||
{ [ t ] [ nip ] }
|
||||
[ nip ]
|
||||
} cond ;
|
||||
|
||||
PRIVATE>
|
||||
|
|
@ -105,7 +105,7 @@ PRIVATE>
|
|||
{ [ dup "\\\\?\\" head? ] [ t ] }
|
||||
{ [ dup length 2 < ] [ f ] }
|
||||
{ [ dup second CHAR: : = ] [ t ] }
|
||||
{ [ t ] [ f ] }
|
||||
[ f ]
|
||||
} cond ;
|
||||
|
||||
: absolute-path? ( path -- ? )
|
||||
|
|
@ -114,7 +114,7 @@ PRIVATE>
|
|||
{ [ dup "resource:" head? ] [ t ] }
|
||||
{ [ os windows? ] [ windows-absolute-path? ] }
|
||||
{ [ dup first path-separator? ] [ t ] }
|
||||
{ [ t ] [ f ] }
|
||||
[ f ]
|
||||
} cond nip ;
|
||||
|
||||
: append-path ( str1 str2 -- str )
|
||||
|
|
@ -130,10 +130,10 @@ PRIVATE>
|
|||
{ [ over absolute-path? over first path-separator? and ] [
|
||||
>r 2 head r> append
|
||||
] }
|
||||
{ [ t ] [
|
||||
[
|
||||
>r right-trim-separators "/" r>
|
||||
left-trim-separators 3append
|
||||
] }
|
||||
]
|
||||
} cond ;
|
||||
|
||||
: prepend-path ( str1 str2 -- str )
|
||||
|
|
@ -220,10 +220,10 @@ HOOK: make-directory io-backend ( path -- )
|
|||
{ [ dup root-directory? ] [ ] }
|
||||
{ [ dup empty? ] [ ] }
|
||||
{ [ dup exists? ] [ ] }
|
||||
{ [ t ] [
|
||||
[
|
||||
dup parent-directory make-directories
|
||||
dup make-directory
|
||||
] }
|
||||
]
|
||||
} cond drop ;
|
||||
|
||||
! Directory listings
|
||||
|
|
@ -322,9 +322,10 @@ C: <pathname> pathname
|
|||
M: pathname <=> [ pathname-string ] compare ;
|
||||
|
||||
! Home directory
|
||||
: home ( -- dir )
|
||||
{
|
||||
{ [ os winnt? ] [ "USERPROFILE" os-env ] }
|
||||
{ [ os wince? ] [ "" resource-path ] }
|
||||
{ [ os unix? ] [ "HOME" os-env ] }
|
||||
} cond ;
|
||||
HOOK: home os ( -- dir )
|
||||
|
||||
M: winnt home "USERPROFILE" os-env ;
|
||||
|
||||
M: wince home "" resource-path ;
|
||||
|
||||
M: unix home "HOME" os-env ;
|
||||
|
|
|
|||
|
|
@ -103,7 +103,7 @@ C: <interval> interval
|
|||
2drop over second over second and
|
||||
[ <interval> ] [ 2drop f ] if
|
||||
] }
|
||||
{ [ t ] [ 2drop <interval> ] }
|
||||
[ 2drop <interval> ]
|
||||
} cond ;
|
||||
|
||||
: interval-intersect ( i1 i2 -- i3 )
|
||||
|
|
@ -202,7 +202,7 @@ SYMBOL: incomparable
|
|||
{ [ 2dup interval-intersect not ] [ (interval<) ] }
|
||||
{ [ 2dup left-endpoint-< ] [ f ] }
|
||||
{ [ 2dup right-endpoint-< ] [ f ] }
|
||||
{ [ t ] [ incomparable ] }
|
||||
[ incomparable ]
|
||||
} cond 2nip ;
|
||||
|
||||
: left-endpoint-<= ( i1 i2 -- ? )
|
||||
|
|
@ -215,7 +215,7 @@ SYMBOL: incomparable
|
|||
{
|
||||
{ [ 2dup interval-intersect not ] [ (interval<) ] }
|
||||
{ [ 2dup right-endpoint-<= ] [ t ] }
|
||||
{ [ t ] [ incomparable ] }
|
||||
[ incomparable ]
|
||||
} cond 2nip ;
|
||||
|
||||
: interval> ( i1 i2 -- ? )
|
||||
|
|
|
|||
|
|
@ -62,7 +62,7 @@ SYMBOL: negative?
|
|||
{
|
||||
{ [ dup empty? ] [ drop f ] }
|
||||
{ [ f over memq? ] [ drop f ] }
|
||||
{ [ t ] [ radix get [ < ] curry all? ] }
|
||||
[ radix get [ < ] curry all? ]
|
||||
} cond ;
|
||||
|
||||
: string>integer ( str -- n/f )
|
||||
|
|
@ -77,7 +77,7 @@ PRIVATE>
|
|||
{
|
||||
{ [ CHAR: / over member? ] [ string>ratio ] }
|
||||
{ [ CHAR: . over member? ] [ string>float ] }
|
||||
{ [ t ] [ string>integer ] }
|
||||
[ string>integer ]
|
||||
} cond
|
||||
r> [ dup [ neg ] when ] when
|
||||
] with-radix ;
|
||||
|
|
@ -134,10 +134,8 @@ M: ratio >base
|
|||
} {
|
||||
[ CHAR: . over member? ]
|
||||
[ ]
|
||||
} {
|
||||
[ t ]
|
||||
[ ".0" append ]
|
||||
}
|
||||
[ ".0" append ]
|
||||
} cond ;
|
||||
|
||||
M: float >base
|
||||
|
|
@ -145,7 +143,7 @@ M: float >base
|
|||
{ [ dup 1.0/0.0 = ] [ drop "1.0/0.0" ] }
|
||||
{ [ dup -1.0/0.0 = ] [ drop "-1.0/0.0" ] }
|
||||
{ [ dup fp-nan? ] [ drop "0.0/0.0" ] }
|
||||
{ [ t ] [ float>string fix-float ] }
|
||||
[ float>string fix-float ]
|
||||
} cond ;
|
||||
|
||||
: number>string ( n -- str ) 10 >base ;
|
||||
|
|
|
|||
|
|
@ -9,23 +9,23 @@ optimizer ;
|
|||
{ [ over #label? not ] [ 2drop f ] }
|
||||
{ [ over #label-word over eq? not ] [ 2drop f ] }
|
||||
{ [ over #label-loop? not ] [ 2drop f ] }
|
||||
{ [ t ] [ 2drop t ] }
|
||||
[ 2drop t ]
|
||||
} cond
|
||||
] curry node-exists? ;
|
||||
|
||||
: label-is-not-loop? ( node word -- ? )
|
||||
[
|
||||
{
|
||||
{ [ over #label? not ] [ 2drop f ] }
|
||||
{ [ over #label-word over eq? not ] [ 2drop f ] }
|
||||
{ [ over #label-loop? ] [ 2drop f ] }
|
||||
{ [ t ] [ 2drop t ] }
|
||||
} cond
|
||||
{ [ over #label? not ] [ f ] }
|
||||
{ [ over #label-word over eq? not ] [ f ] }
|
||||
{ [ over #label-loop? ] [ f ] }
|
||||
[ t ]
|
||||
} cond 2nip
|
||||
] curry node-exists? ;
|
||||
|
||||
: loop-test-1 ( a -- )
|
||||
dup [ 1+ loop-test-1 ] [ drop ] if ; inline
|
||||
|
||||
|
||||
[ t ] [
|
||||
[ loop-test-1 ] dataflow dup detect-loops
|
||||
\ loop-test-1 label-is-loop?
|
||||
|
|
|
|||
|
|
@ -156,7 +156,7 @@ SYMBOL: potential-loops
|
|||
{ [ dup null class< ] [ drop f f ] }
|
||||
{ [ dup \ f class-not class< ] [ drop t t ] }
|
||||
{ [ dup \ f class< ] [ drop f t ] }
|
||||
{ [ t ] [ drop f f ] }
|
||||
[ drop f f ]
|
||||
} cond
|
||||
] if ;
|
||||
|
||||
|
|
|
|||
|
|
@ -36,7 +36,7 @@ DEFER: (flat-length)
|
|||
! not inline
|
||||
{ [ dup inline? not ] [ drop 1 ] }
|
||||
! inline
|
||||
{ [ t ] [ dup dup set word-def (flat-length) ] }
|
||||
[ dup dup set word-def (flat-length) ]
|
||||
} cond ;
|
||||
|
||||
: (flat-length) ( seq -- n )
|
||||
|
|
@ -45,7 +45,7 @@ DEFER: (flat-length)
|
|||
{ [ dup quotation? ] [ (flat-length) 1+ ] }
|
||||
{ [ dup array? ] [ (flat-length) ] }
|
||||
{ [ dup word? ] [ word-flat-length ] }
|
||||
{ [ t ] [ drop 1 ] }
|
||||
[ drop 1 ]
|
||||
} cond
|
||||
] map sum ;
|
||||
|
||||
|
|
@ -94,7 +94,7 @@ DEFER: (flat-length)
|
|||
dup node-param {
|
||||
{ [ dup standard-generic? ] [ inline-standard-method ] }
|
||||
{ [ dup math-generic? ] [ inline-math-method ] }
|
||||
{ [ t ] [ 2drop t ] }
|
||||
[ 2drop t ]
|
||||
} cond ;
|
||||
|
||||
! Resolve type checks at compile time where possible
|
||||
|
|
@ -217,5 +217,5 @@ M: #call optimize-node*
|
|||
{ [ dup optimize-predicate? ] [ optimize-predicate ] }
|
||||
{ [ dup optimistic-inline? ] [ optimistic-inline ] }
|
||||
{ [ dup method-body-inline? ] [ optimistic-inline ] }
|
||||
{ [ t ] [ inline-method ] }
|
||||
[ inline-method ]
|
||||
} cond dup not ;
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@ SYMBOL: @
|
|||
{ [ dup @ eq? ] [ drop match-@ ] }
|
||||
{ [ dup class? ] [ match-class ] }
|
||||
{ [ over value? not ] [ 2drop f ] }
|
||||
{ [ t ] [ swap value-literal = ] }
|
||||
[ swap value-literal = ]
|
||||
} cond ;
|
||||
|
||||
: node-match? ( node values pattern -- ? )
|
||||
|
|
|
|||
|
|
@ -57,7 +57,7 @@ IN: optimizer.specializers
|
|||
[ dup "specializer" word-prop ]
|
||||
[ "specializer" word-prop specialize-quot ]
|
||||
}
|
||||
{ [ t ] [ drop ] }
|
||||
[ drop ]
|
||||
} cond ;
|
||||
|
||||
: specialized-length ( specializer -- n )
|
||||
|
|
|
|||
|
|
@ -324,7 +324,7 @@ M: staging-violation summary
|
|||
{ [ dup not ] [ drop unexpected-eof t ] }
|
||||
{ [ dup delimiter? ] [ unexpected t ] }
|
||||
{ [ dup parsing? ] [ nip execute-parsing t ] }
|
||||
{ [ t ] [ pick push drop t ] }
|
||||
[ pick push drop t ]
|
||||
} cond ;
|
||||
|
||||
: (parse-until) ( accum end -- accum )
|
||||
|
|
|
|||
|
|
@ -107,7 +107,7 @@ SYMBOL: ->
|
|||
{ [ dup word? not ] [ , ] }
|
||||
{ [ dup "break?" word-prop ] [ drop ] }
|
||||
{ [ dup "step-into?" word-prop ] [ remove-step-into ] }
|
||||
{ [ t ] [ , ] }
|
||||
[ , ]
|
||||
} cond
|
||||
] each
|
||||
] [ ] make ;
|
||||
|
|
|
|||
|
|
@ -61,7 +61,7 @@ IN: bootstrap.syntax
|
|||
scan {
|
||||
{ [ dup length 1 = ] [ first ] }
|
||||
{ [ "\\" ?head ] [ next-escape drop ] }
|
||||
{ [ t ] [ name>char-hook get call ] }
|
||||
[ name>char-hook get call ]
|
||||
} cond parsed
|
||||
] define-syntax
|
||||
|
||||
|
|
|
|||
|
|
@ -101,7 +101,7 @@ HELP: set-os-envs
|
|||
{ $values { "assoc" "an association mapping strings to strings" } }
|
||||
{ $description "Replaces the current set of environment variables." }
|
||||
{ $notes
|
||||
"Names and values of environment variables are operating system-specific."
|
||||
"Names and values of environment variables are operating system-specific. Windows NT allows values up to 32766 characters in length."
|
||||
}
|
||||
{ $errors "Windows CE has no concept of environment variables, so this word throws an error there." } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
USING: math tools.test system prettyprint namespaces kernel ;
|
||||
USING: math tools.test system prettyprint namespaces kernel
|
||||
strings sequences ;
|
||||
IN: system.tests
|
||||
|
||||
os wince? [
|
||||
|
|
@ -19,3 +20,8 @@ os unix? [
|
|||
[ ] [ "factor-test-key-1" unset-os-env ] unit-test
|
||||
[ f ] [ "factor-test-key-1" os-env ] unit-test
|
||||
|
||||
[ ] [
|
||||
32766 CHAR: a <string> "factor-test-key-long" set-os-env
|
||||
] unit-test
|
||||
[ 32766 ] [ "factor-test-key-long" os-env length ] unit-test
|
||||
[ ] [ "factor-test-key-long" unset-os-env ] unit-test
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@
|
|||
IN: threads
|
||||
USING: arrays hashtables heaps kernel kernel.private math
|
||||
namespaces sequences vectors continuations continuations.private
|
||||
dlists assocs system combinators init boxes ;
|
||||
dlists assocs system combinators init boxes accessors ;
|
||||
|
||||
SYMBOL: initial-thread
|
||||
|
||||
|
|
@ -18,11 +18,10 @@ mailbox variables sleep-entry ;
|
|||
|
||||
! Thread-local storage
|
||||
: tnamespace ( -- assoc )
|
||||
self dup thread-variables
|
||||
[ ] [ H{ } clone dup rot set-thread-variables ] ?if ;
|
||||
self variables>> [ H{ } clone dup self (>>variables) ] unless* ;
|
||||
|
||||
: tget ( key -- value )
|
||||
self thread-variables at ;
|
||||
self variables>> at ;
|
||||
|
||||
: tset ( value key -- )
|
||||
tnamespace set-at ;
|
||||
|
|
@ -35,7 +34,7 @@ mailbox variables sleep-entry ;
|
|||
: thread ( id -- thread ) threads at ;
|
||||
|
||||
: thread-registered? ( thread -- ? )
|
||||
thread-id threads key? ;
|
||||
id>> threads key? ;
|
||||
|
||||
: check-unregistered
|
||||
dup thread-registered?
|
||||
|
|
@ -48,59 +47,58 @@ mailbox variables sleep-entry ;
|
|||
<PRIVATE
|
||||
|
||||
: register-thread ( thread -- )
|
||||
check-unregistered dup thread-id threads set-at ;
|
||||
check-unregistered dup id>> threads set-at ;
|
||||
|
||||
: unregister-thread ( thread -- )
|
||||
check-registered thread-id threads delete-at ;
|
||||
check-registered id>> threads delete-at ;
|
||||
|
||||
: set-self ( thread -- ) 40 setenv ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: <thread> ( quot name -- thread )
|
||||
\ thread counter <box> [ ] {
|
||||
set-thread-quot
|
||||
set-thread-name
|
||||
set-thread-id
|
||||
set-thread-continuation
|
||||
set-thread-exit-handler
|
||||
} \ thread construct ;
|
||||
\ thread construct-empty
|
||||
swap >>name
|
||||
swap >>quot
|
||||
\ thread counter >>id
|
||||
<box> >>continuation
|
||||
[ ] >>exit-handler ;
|
||||
|
||||
: run-queue 42 getenv ;
|
||||
|
||||
: sleep-queue 43 getenv ;
|
||||
|
||||
: resume ( thread -- )
|
||||
f over set-thread-state
|
||||
f >>state
|
||||
check-registered run-queue push-front ;
|
||||
|
||||
: resume-now ( thread -- )
|
||||
f over set-thread-state
|
||||
f >>state
|
||||
check-registered run-queue push-back ;
|
||||
|
||||
: resume-with ( obj thread -- )
|
||||
f over set-thread-state
|
||||
f >>state
|
||||
check-registered 2array run-queue push-front ;
|
||||
|
||||
: sleep-time ( -- ms/f )
|
||||
{
|
||||
{ [ run-queue dlist-empty? not ] [ 0 ] }
|
||||
{ [ sleep-queue heap-empty? ] [ f ] }
|
||||
{ [ t ] [ sleep-queue heap-peek nip millis [-] ] }
|
||||
[ sleep-queue heap-peek nip millis [-] ]
|
||||
} cond ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: schedule-sleep ( thread ms -- )
|
||||
>r check-registered dup r> sleep-queue heap-push*
|
||||
swap set-thread-sleep-entry ;
|
||||
>>sleep-entry drop ;
|
||||
|
||||
: expire-sleep? ( heap -- ? )
|
||||
dup heap-empty?
|
||||
[ drop f ] [ heap-peek nip millis <= ] if ;
|
||||
|
||||
: expire-sleep ( thread -- )
|
||||
f over set-thread-sleep-entry resume ;
|
||||
f >>sleep-entry resume ;
|
||||
|
||||
: expire-sleep-loop ( -- )
|
||||
sleep-queue
|
||||
|
|
@ -123,21 +121,21 @@ PRIVATE>
|
|||
] [
|
||||
pop-back
|
||||
dup array? [ first2 ] [ f swap ] if dup set-self
|
||||
f over set-thread-state
|
||||
thread-continuation box>
|
||||
f >>state
|
||||
continuation>> box>
|
||||
continue-with
|
||||
] if ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: stop ( -- )
|
||||
self dup thread-exit-handler call
|
||||
self dup exit-handler>> call
|
||||
unregister-thread next ;
|
||||
|
||||
: suspend ( quot state -- obj )
|
||||
[
|
||||
self thread-continuation >box
|
||||
self set-thread-state
|
||||
self continuation>> >box
|
||||
self (>>state)
|
||||
self swap call next
|
||||
] callcc1 2nip ; inline
|
||||
|
||||
|
|
@ -157,9 +155,9 @@ M: real sleep
|
|||
millis + >integer sleep-until ;
|
||||
|
||||
: interrupt ( thread -- )
|
||||
dup thread-state [
|
||||
dup thread-sleep-entry [ sleep-queue heap-delete ] when*
|
||||
f over set-thread-sleep-entry
|
||||
dup state>> [
|
||||
dup sleep-entry>> [ sleep-queue heap-delete ] when*
|
||||
f >>sleep-entry
|
||||
dup resume
|
||||
] when drop ;
|
||||
|
||||
|
|
@ -171,7 +169,7 @@ M: real sleep
|
|||
V{ } set-catchstack
|
||||
{ } set-retainstack
|
||||
>r { } set-datastack r>
|
||||
thread-quot [ call stop ] call-clear
|
||||
quot>> [ call stop ] call-clear
|
||||
] 1 (throw)
|
||||
] "spawn" suspend 2drop ;
|
||||
|
||||
|
|
@ -196,8 +194,8 @@ GENERIC: error-in-thread ( error thread -- )
|
|||
<min-heap> 43 setenv
|
||||
initial-thread global
|
||||
[ drop f "Initial" <thread> ] cache
|
||||
<box> over set-thread-continuation
|
||||
f over set-thread-state
|
||||
<box> >>continuation
|
||||
f >>state
|
||||
dup register-thread
|
||||
set-self ;
|
||||
|
||||
|
|
|
|||
|
|
@ -284,7 +284,7 @@ HELP: <word>
|
|||
|
||||
HELP: gensym
|
||||
{ $values { "word" word } }
|
||||
{ $description "Creates an uninterned word that is not equal to any other word in the system. Gensyms have an automatically-generated name based on a prefix and an incrementing counter." }
|
||||
{ $description "Creates an uninterned word that is not equal to any other word in the system." }
|
||||
{ $examples { $unchecked-example "gensym ." "G:260561" } }
|
||||
{ $notes "Gensyms are often used as placeholder values that have no meaning of their own but must be unique. For example, the compiler uses gensyms to label sections of code." } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -2,8 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays definitions graphs assocs kernel kernel.private
|
||||
slots.private math namespaces sequences strings vectors sbufs
|
||||
quotations assocs hashtables sorting math.parser words.private
|
||||
vocabs combinators ;
|
||||
quotations assocs hashtables sorting words.private vocabs ;
|
||||
IN: words
|
||||
|
||||
: word ( -- word ) \ word get-global ;
|
||||
|
|
@ -66,11 +65,11 @@ SYMBOL: bootstrapping?
|
|||
GENERIC: crossref? ( word -- ? )
|
||||
|
||||
M: word crossref?
|
||||
{
|
||||
{ [ dup "forgotten" word-prop ] [ f ] }
|
||||
{ [ dup word-vocabulary ] [ t ] }
|
||||
{ [ t ] [ f ] }
|
||||
} cond nip ;
|
||||
dup "forgotten" word-prop [
|
||||
drop f
|
||||
] [
|
||||
word-vocabulary >boolean
|
||||
] if ;
|
||||
|
||||
GENERIC# (quot-uses) 1 ( obj assoc -- )
|
||||
|
||||
|
|
@ -191,7 +190,7 @@ M: word subwords drop f ;
|
|||
{ "methods" "combination" "default-method" } reset-props ;
|
||||
|
||||
: gensym ( -- word )
|
||||
"G:" \ gensym counter number>string append f <word> ;
|
||||
"( gensym )" f <word> ;
|
||||
|
||||
: define-temp ( quot -- word )
|
||||
gensym dup rot define ;
|
||||
|
|
|
|||
|
|
@ -9,6 +9,7 @@ namespaces random ;
|
|||
{ [ os unix? ] [ "random.unix" require ] }
|
||||
} cond
|
||||
|
||||
! [ [ 32 random-bits ] with-secure-random <mersenne-twister> random-generator set-global ]
|
||||
[ millis <mersenne-twister> random-generator set-global ]
|
||||
"generator.random" add-init-hook
|
||||
[
|
||||
[ 32 random-bits ] with-secure-random
|
||||
<mersenne-twister> random-generator set-global
|
||||
] "generator.random" add-init-hook
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ IN: bunny.model
|
|||
numbers {
|
||||
{ [ dup length 5 = ] [ 3 head pick push ] }
|
||||
{ [ dup first 3 = ] [ 1 tail over push ] }
|
||||
{ [ t ] [ drop ] }
|
||||
[ drop ]
|
||||
} cond (parse-model)
|
||||
] when* ;
|
||||
|
||||
|
|
|
|||
|
|
@ -10,17 +10,17 @@ TUPLE: png-gadget png ;
|
|||
|
||||
ERROR: cairo-error string ;
|
||||
|
||||
: check-zero
|
||||
: check-zero ( n -- n )
|
||||
dup zero? [
|
||||
"PNG dimension is 0" cairo-error
|
||||
] when ;
|
||||
|
||||
: cairo-png-error ( n -- )
|
||||
{
|
||||
{ [ dup CAIRO_STATUS_NO_MEMORY = ] [ "Cairo: no memory" cairo-error ] }
|
||||
{ [ dup CAIRO_STATUS_FILE_NOT_FOUND = ] [ "Cairo: file not found" cairo-error ] }
|
||||
{ [ dup CAIRO_STATUS_READ_ERROR = ] [ "Cairo: read error" cairo-error ] }
|
||||
{ [ t ] [ drop ] }
|
||||
{ CAIRO_STATUS_NO_MEMORY [ "Cairo: no memory" cairo-error ] }
|
||||
{ CAIRO_STATUS_FILE_NOT_FOUND [ "Cairo: file not found" cairo-error ] }
|
||||
{ CAIRO_STATUS_READ_ERROR [ "Cairo: read error" cairo-error ] }
|
||||
[ drop ]
|
||||
} cond ;
|
||||
|
||||
: <png> ( path -- png )
|
||||
|
|
|
|||
|
|
@ -5,12 +5,11 @@ IN: calendar.windows
|
|||
M: windows gmt-offset ( -- hours minutes seconds )
|
||||
"TIME_ZONE_INFORMATION" <c-object>
|
||||
dup GetTimeZoneInformation {
|
||||
{ [ dup TIME_ZONE_ID_INVALID = ] [ win32-error-string throw ] }
|
||||
{ [ dup [ TIME_ZONE_ID_UNKNOWN = ] [ TIME_ZONE_ID_STANDARD = ] bi or ] [
|
||||
drop TIME_ZONE_INFORMATION-Bias ] }
|
||||
{ [ dup TIME_ZONE_ID_DAYLIGHT = ] [
|
||||
drop
|
||||
{ TIME_ZONE_ID_INVALID [ win32-error-string throw ] }
|
||||
{ TIME_ZONE_ID_UNKNOWN [ TIME_ZONE_INFORMATION-Bias ] }
|
||||
{ TIME_ZONE_ID_STANDARD [ TIME_ZONE_INFORMATION-Bias ] }
|
||||
{ TIME_ZONE_ID_DAYLIGHT [
|
||||
[ TIME_ZONE_INFORMATION-Bias ]
|
||||
[ TIME_ZONE_INFORMATION-DaylightBias ] bi +
|
||||
] }
|
||||
} cond neg 60 /mod 0 ;
|
||||
} case neg 60 /mod 0 ;
|
||||
|
|
|
|||
|
|
@ -1,8 +1,9 @@
|
|||
! Copyright (C) 2006, 2007 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien io kernel namespaces core-foundation cocoa.messages
|
||||
cocoa cocoa.classes cocoa.runtime sequences threads
|
||||
debugger init inspector kernel.private ;
|
||||
USING: alien io kernel namespaces core-foundation
|
||||
core-foundation.run-loop cocoa.messages cocoa cocoa.classes
|
||||
cocoa.runtime sequences threads debugger init inspector
|
||||
kernel.private ;
|
||||
IN: cocoa.application
|
||||
|
||||
: <NSString> ( str -- alien ) <CFString> -> autorelease ;
|
||||
|
|
@ -21,8 +22,6 @@ IN: cocoa.application
|
|||
: with-cocoa ( quot -- )
|
||||
[ NSApp drop call ] with-autorelease-pool ;
|
||||
|
||||
: CFRunLoopDefaultMode "kCFRunLoopDefaultMode" <NSString> ;
|
||||
|
||||
: next-event ( app -- event )
|
||||
0 f CFRunLoopDefaultMode 1
|
||||
-> nextEventMatchingMask:untilDate:inMode:dequeue: ;
|
||||
|
|
|
|||
|
|
@ -154,7 +154,7 @@ H{
|
|||
{ [ dup CHAR: ^ = ] [ 3drop "void*" ] }
|
||||
{ [ dup CHAR: { = ] [ drop objc-struct-type ] }
|
||||
{ [ dup CHAR: [ = ] [ 3drop "void*" ] }
|
||||
{ [ t ] [ 2nip 1string objc>alien-types get at ] }
|
||||
[ 2nip 1string objc>alien-types get at ]
|
||||
} cond ;
|
||||
|
||||
: parse-objc-type ( string -- ctype ) 0 swap (parse-objc-type) ;
|
||||
|
|
|
|||
|
|
@ -57,7 +57,7 @@ HELP: mailbox-get?
|
|||
|
||||
|
||||
ARTICLE: "concurrency.mailboxes" "Mailboxes"
|
||||
"A " { $emphasis "mailbox" } " is a first-in-first-out queue where the operation of removing an element blocks if the queue is empty, instead of throwing an error."
|
||||
"A " { $emphasis "mailbox" } " is a first-in-first-out queue where the operation of removing an element blocks if the queue is empty, instead of throwing an error. Mailboxes are implemented in the " { $vocab-link "concurrency.mailboxes" } " vocabulary."
|
||||
{ $subsection mailbox }
|
||||
{ $subsection <mailbox> }
|
||||
"Removing the first element:"
|
||||
|
|
@ -73,3 +73,5 @@ ARTICLE: "concurrency.mailboxes" "Mailboxes"
|
|||
"Testing if a mailbox is empty:"
|
||||
{ $subsection mailbox-empty? }
|
||||
{ $subsection while-mailbox-empty } ;
|
||||
|
||||
ABOUT: "concurrency.mailboxes"
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
IN: concurrency.mailboxes.tests
|
||||
USING: concurrency.mailboxes vectors sequences threads
|
||||
tools.test math kernel strings ;
|
||||
USING: concurrency.mailboxes concurrency.count-downs vectors
|
||||
sequences threads tools.test math kernel strings namespaces
|
||||
continuations calendar ;
|
||||
|
||||
[ V{ 1 2 3 } ] [
|
||||
0 <vector>
|
||||
|
|
@ -38,3 +39,37 @@ tools.test math kernel strings ;
|
|||
"junk2" over mailbox-put
|
||||
mailbox-get
|
||||
] unit-test
|
||||
|
||||
<mailbox> "m" set
|
||||
|
||||
1 <count-down> "c" set
|
||||
1 <count-down> "d" set
|
||||
|
||||
[
|
||||
"c" get await
|
||||
[ "m" get mailbox-get drop ]
|
||||
[ drop "d" get count-down ] recover
|
||||
] "Mailbox close test" spawn drop
|
||||
|
||||
[ ] [ "c" get count-down ] unit-test
|
||||
[ ] [ "m" get dispose ] unit-test
|
||||
[ ] [ "d" get 5 seconds await-timeout ] unit-test
|
||||
|
||||
[ ] [ "m" get dispose ] unit-test
|
||||
|
||||
<mailbox> "m" set
|
||||
|
||||
1 <count-down> "c" set
|
||||
1 <count-down> "d" set
|
||||
|
||||
[
|
||||
"c" get await
|
||||
"m" get wait-for-close
|
||||
"d" get count-down
|
||||
] "Mailbox close test" spawn drop
|
||||
|
||||
[ ] [ "c" get count-down ] unit-test
|
||||
[ ] [ "m" get dispose ] unit-test
|
||||
[ ] [ "d" get 5 seconds await-timeout ] unit-test
|
||||
|
||||
[ ] [ "m" get dispose ] unit-test
|
||||
|
|
|
|||
|
|
@ -3,41 +3,50 @@
|
|||
IN: concurrency.mailboxes
|
||||
USING: dlists threads sequences continuations
|
||||
namespaces random math quotations words kernel arrays assocs
|
||||
init system concurrency.conditions ;
|
||||
init system concurrency.conditions accessors ;
|
||||
|
||||
TUPLE: mailbox threads data ;
|
||||
TUPLE: mailbox threads data closed ;
|
||||
|
||||
: check-closed ( mailbox -- )
|
||||
closed>> [ "Mailbox closed" throw ] when ; inline
|
||||
|
||||
M: mailbox dispose
|
||||
t >>closed threads>> notify-all ;
|
||||
|
||||
: <mailbox> ( -- mailbox )
|
||||
<dlist> <dlist> mailbox construct-boa ;
|
||||
<dlist> <dlist> f mailbox construct-boa ;
|
||||
|
||||
: mailbox-empty? ( mailbox -- bool )
|
||||
mailbox-data dlist-empty? ;
|
||||
data>> dlist-empty? ;
|
||||
|
||||
: mailbox-put ( obj mailbox -- )
|
||||
[ mailbox-data push-front ] keep
|
||||
mailbox-threads notify-all yield ;
|
||||
[ data>> push-front ]
|
||||
[ threads>> notify-all ] bi yield ;
|
||||
|
||||
: wait-for-mailbox ( mailbox timeout -- )
|
||||
>r threads>> r> "mailbox" wait ;
|
||||
|
||||
: block-unless-pred ( mailbox timeout pred -- )
|
||||
pick mailbox-data over dlist-contains? [
|
||||
pick check-closed
|
||||
pick data>> over dlist-contains? [
|
||||
3drop
|
||||
] [
|
||||
>r over mailbox-threads over "mailbox" wait r>
|
||||
block-unless-pred
|
||||
>r 2dup wait-for-mailbox r> block-unless-pred
|
||||
] if ; inline
|
||||
|
||||
: block-if-empty ( mailbox timeout -- mailbox )
|
||||
over check-closed
|
||||
over mailbox-empty? [
|
||||
over mailbox-threads over "mailbox" wait
|
||||
block-if-empty
|
||||
2dup wait-for-mailbox block-if-empty
|
||||
] [
|
||||
drop
|
||||
] if ;
|
||||
|
||||
: mailbox-peek ( mailbox -- obj )
|
||||
mailbox-data peek-back ;
|
||||
data>> peek-back ;
|
||||
|
||||
: mailbox-get-timeout ( mailbox timeout -- obj )
|
||||
block-if-empty mailbox-data pop-back ;
|
||||
block-if-empty data>> pop-back ;
|
||||
|
||||
: mailbox-get ( mailbox -- obj )
|
||||
f mailbox-get-timeout ;
|
||||
|
|
@ -45,7 +54,7 @@ TUPLE: mailbox threads data ;
|
|||
: mailbox-get-all-timeout ( mailbox timeout -- array )
|
||||
block-if-empty
|
||||
[ dup mailbox-empty? ]
|
||||
[ dup mailbox-data pop-back ]
|
||||
[ dup data>> pop-back ]
|
||||
[ ] unfold nip ;
|
||||
|
||||
: mailbox-get-all ( mailbox -- array )
|
||||
|
|
@ -60,11 +69,18 @@ TUPLE: mailbox threads data ;
|
|||
|
||||
: mailbox-get-timeout? ( mailbox timeout pred -- obj )
|
||||
3dup block-unless-pred
|
||||
nip >r mailbox-data r> delete-node-if ; inline
|
||||
nip >r data>> r> delete-node-if ; inline
|
||||
|
||||
: mailbox-get? ( mailbox pred -- obj )
|
||||
f swap mailbox-get-timeout? ; inline
|
||||
|
||||
: wait-for-close-timeout ( mailbox timeout -- )
|
||||
over closed>>
|
||||
[ 2drop ] [ 2dup wait-for-mailbox wait-for-close-timeout ] if ;
|
||||
|
||||
: wait-for-close ( mailbox -- )
|
||||
f wait-for-close-timeout ;
|
||||
|
||||
TUPLE: linked-error thread ;
|
||||
|
||||
: <linked-error> ( error thread -- linked )
|
||||
|
|
|
|||
|
|
@ -32,7 +32,7 @@ HELP: spawn-linked
|
|||
{ $description "Start a thread which runs the given quotation. If that quotation throws an error which is not caught then the error will get propagated to the thread that spawned it. This can be used to set up 'supervisor' threades that restart child threades that crash due to uncaught errors.\n" }
|
||||
{ $see-also spawn } ;
|
||||
|
||||
ARTICLE: { "concurrency" "messaging" } "Mailboxes"
|
||||
ARTICLE: { "concurrency" "messaging" } "Sending and receiving messages"
|
||||
"Each thread has an associated mailbox. Other threads can place items on this queue by sending the thread a message. A thread can check its mailbox for messages, blocking if none are pending, and thread them as they are queued."
|
||||
$nl
|
||||
"The messages that are sent from thread to thread are any Factor value. Factor tuples are ideal for this sort of thing as you can send a tuple to a thread and the generic word dispatch mechanism can be used to perform actions depending on what the type of the tuple is."
|
||||
|
|
@ -43,7 +43,8 @@ $nl
|
|||
{ $subsection receive }
|
||||
{ $subsection receive-timeout }
|
||||
{ $subsection receive-if }
|
||||
{ $subsection receive-if-timeout } ;
|
||||
{ $subsection receive-if-timeout }
|
||||
{ $see-also "concurrency.mailboxes" } ;
|
||||
|
||||
ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous sends"
|
||||
"The " { $link send } " word sends a message asynchronously, and the sending thread continues immediately. It is also possible to send a message to a thread and block until a response is received:"
|
||||
|
|
|
|||
|
|
@ -3,7 +3,8 @@
|
|||
!
|
||||
USING: kernel threads vectors arrays sequences
|
||||
namespaces tools.test continuations dlists strings math words
|
||||
match quotations concurrency.messaging concurrency.mailboxes ;
|
||||
match quotations concurrency.messaging concurrency.mailboxes
|
||||
concurrency.count-downs ;
|
||||
IN: concurrency.messaging.tests
|
||||
|
||||
[ ] [ my-mailbox mailbox-data dlist-delete-all ] unit-test
|
||||
|
|
@ -52,4 +53,15 @@ SYMBOL: exit
|
|||
[ value , self , ] { } make "counter" get send
|
||||
receive
|
||||
exit "counter" get send
|
||||
] unit-test
|
||||
] unit-test
|
||||
|
||||
! Not yet
|
||||
|
||||
! 1 <count-down> "c" set
|
||||
|
||||
! [
|
||||
! "c" get count-down
|
||||
! receive drop
|
||||
! ] "Bad synchronous send" spawn "t" set
|
||||
|
||||
! [ 3 "t" get send-synchronous ] must-fail
|
||||
|
|
@ -9,9 +9,9 @@ TYPEDEF: void* CFBundleRef
|
|||
TYPEDEF: void* CFStringRef
|
||||
TYPEDEF: void* CFURLRef
|
||||
TYPEDEF: void* CFUUIDRef
|
||||
TYPEDEF: void* CFRunLoopRef
|
||||
TYPEDEF: bool Boolean
|
||||
TYPEDEF: int CFIndex
|
||||
TYPEDEF: int SInt32
|
||||
TYPEDEF: double CFTimeInterval
|
||||
TYPEDEF: double CFAbsoluteTime
|
||||
|
||||
|
|
@ -85,5 +85,3 @@ FUNCTION: void CFRelease ( void* cf ) ;
|
|||
] [
|
||||
"Cannot load bundled named " prepend throw
|
||||
] ?if ;
|
||||
|
||||
FUNCTION: CFRunLoopRef CFRunLoopGetMain ( ) ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2008 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types alien.syntax kernel math sequences
|
||||
namespaces assocs init continuations core-foundation ;
|
||||
namespaces assocs init accessors continuations combinators
|
||||
core-foundation core-foundation.run-loop ;
|
||||
IN: core-foundation.fsevents
|
||||
|
||||
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
|
||||
|
|
@ -151,12 +152,10 @@ SYMBOL: event-stream-callbacks
|
|||
|
||||
[
|
||||
event-stream-callbacks global
|
||||
[ [ drop expired? not ] assoc-subset ] change-at
|
||||
[ [ drop expired? not ] assoc-subset H{ } assoc-like ] change-at
|
||||
1 \ event-stream-counter set-global
|
||||
] "core-foundation" add-init-hook
|
||||
|
||||
event-stream-callbacks global [ H{ } assoc-like ] change-at
|
||||
|
||||
: add-event-source-callback ( quot -- id )
|
||||
event-stream-counter <alien>
|
||||
[ event-stream-callbacks get set-at ] keep ;
|
||||
|
|
@ -184,11 +183,11 @@ event-stream-callbacks global [ H{ } assoc-like ] change-at
|
|||
}
|
||||
"cdecl" [
|
||||
[ >event-triple ] 3curry map
|
||||
swap event-stream-callbacks get at call
|
||||
drop
|
||||
swap event-stream-callbacks get at
|
||||
dup [ call drop ] [ 3drop ] if
|
||||
] alien-callback ;
|
||||
|
||||
TUPLE: event-stream info handle ;
|
||||
TUPLE: event-stream info handle closed ;
|
||||
|
||||
: <event-stream> ( quot paths latency flags -- event-stream )
|
||||
>r >r >r
|
||||
|
|
@ -196,9 +195,15 @@ TUPLE: event-stream info handle ;
|
|||
>r master-event-source-callback r>
|
||||
r> r> r> <FSEventStream>
|
||||
dup enable-event-stream
|
||||
event-stream construct-boa ;
|
||||
f event-stream construct-boa ;
|
||||
|
||||
M: event-stream dispose
|
||||
dup event-stream-info remove-event-source-callback
|
||||
event-stream-handle dup disable-event-stream
|
||||
FSEventStreamRelease ;
|
||||
dup closed>> [ drop ] [
|
||||
t >>closed
|
||||
{
|
||||
[ info>> remove-event-source-callback ]
|
||||
[ handle>> disable-event-stream ]
|
||||
[ handle>> FSEventStreamInvalidate ]
|
||||
[ handle>> FSEventStreamRelease ]
|
||||
} cleave
|
||||
] if ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,38 @@
|
|||
! Copyright (C) 2008 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.syntax kernel threads init namespaces alien
|
||||
core-foundation ;
|
||||
IN: core-foundation.run-loop
|
||||
|
||||
: kCFRunLoopRunFinished 1 ; inline
|
||||
: kCFRunLoopRunStopped 2 ; inline
|
||||
: kCFRunLoopRunTimedOut 3 ; inline
|
||||
: kCFRunLoopRunHandledSource 4 ; inline
|
||||
|
||||
TYPEDEF: void* CFRunLoopRef
|
||||
|
||||
FUNCTION: CFRunLoopRef CFRunLoopGetMain ( ) ;
|
||||
|
||||
FUNCTION: SInt32 CFRunLoopRunInMode (
|
||||
CFStringRef mode,
|
||||
CFTimeInterval seconds,
|
||||
Boolean returnAfterSourceHandled
|
||||
) ;
|
||||
|
||||
: CFRunLoopDefaultMode ( -- alien )
|
||||
#! Ugly, but we don't have static NSStrings
|
||||
\ CFRunLoopDefaultMode get-global dup expired? [
|
||||
drop
|
||||
"kCFRunLoopDefaultMode" <CFString>
|
||||
dup \ CFRunLoopDefaultMode set-global
|
||||
] when ;
|
||||
|
||||
: run-loop-thread ( -- )
|
||||
CFRunLoopDefaultMode 0 f CFRunLoopRunInMode
|
||||
kCFRunLoopRunHandledSource = [ 1000 sleep ] unless
|
||||
run-loop-thread ;
|
||||
|
||||
: start-run-loop-thread ( -- )
|
||||
[ run-loop-thread t ] "CFRunLoop dispatcher" spawn-server drop ;
|
||||
|
||||
[ start-run-loop-thread ] "core-foundation.run-loop" add-init-hook
|
||||
|
|
@ -38,5 +38,3 @@ TUPLE: person name age ;
|
|||
{ offset 40 }
|
||||
{ limit 20 }
|
||||
} ;
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -55,7 +55,7 @@ TUPLE: no-sql-match ;
|
|||
{ [ dup number? ] [ number>string sql% ] }
|
||||
{ [ dup symbol? ] [ unparse sql% ] }
|
||||
{ [ dup word? ] [ unparse sql% ] }
|
||||
{ [ t ] [ T{ no-sql-match } throw ] }
|
||||
[ T{ no-sql-match } throw ]
|
||||
} cond ;
|
||||
|
||||
: parse-sql ( obj -- sql in-spec out-spec in out )
|
||||
|
|
|
|||
|
|
@ -20,7 +20,7 @@ IN: db.sqlite.lib
|
|||
{
|
||||
{ [ dup SQLITE_OK = ] [ drop ] }
|
||||
{ [ dup SQLITE_ERROR = ] [ sqlite-statement-error ] }
|
||||
{ [ t ] [ sqlite-error ] }
|
||||
[ sqlite-error ]
|
||||
} cond ;
|
||||
|
||||
: sqlite-open ( filename -- db )
|
||||
|
|
|
|||
|
|
@ -151,14 +151,14 @@ TUPLE: char-elt ;
|
|||
-rot {
|
||||
{ [ over { 0 0 } = ] [ drop ] }
|
||||
{ [ over second zero? ] [ >r first 1- r> line-end ] }
|
||||
{ [ t ] [ pick call ] }
|
||||
[ pick call ]
|
||||
} cond nip ; inline
|
||||
|
||||
: (next-char) ( loc document quot -- loc )
|
||||
-rot {
|
||||
{ [ 2dup doc-end = ] [ drop ] }
|
||||
{ [ 2dup line-end? ] [ drop first 1+ 0 2array ] }
|
||||
{ [ t ] [ pick call ] }
|
||||
[ pick call ]
|
||||
} cond nip ; inline
|
||||
|
||||
M: char-elt prev-elt
|
||||
|
|
|
|||
|
|
@ -22,11 +22,11 @@ DEFER: (fry)
|
|||
drop 1quotation
|
||||
] [
|
||||
unclip {
|
||||
{ , [ [ curry ] ((fry)) ] }
|
||||
{ @ [ [ compose ] ((fry)) ] }
|
||||
{ \ , [ [ curry ] ((fry)) ] }
|
||||
{ \ @ [ [ compose ] ((fry)) ] }
|
||||
|
||||
! to avoid confusion, remove if fry goes core
|
||||
{ namespaces:, [ [ curry ] ((fry)) ] }
|
||||
{ \ namespaces:, [ [ curry ] ((fry)) ] }
|
||||
|
||||
[ swap >r suffix r> (fry) ]
|
||||
} case
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@ IN: hardware-info
|
|||
{ [ os windows? ] [ "hardware-info.windows" ] }
|
||||
{ [ os linux? ] [ "hardware-info.linux" ] }
|
||||
{ [ os macosx? ] [ "hardware-info.macosx" ] }
|
||||
{ [ t ] [ f ] }
|
||||
[ f ]
|
||||
} cond [ require ] when* >>
|
||||
|
||||
: hardware-report. ( -- )
|
||||
|
|
|
|||
|
|
@ -199,7 +199,7 @@ ARTICLE: "cookbook-io" "Input and output cookbook"
|
|||
}
|
||||
"Convert a file of 4-byte cells from little to big endian or vice versa, by directly mapping it into memory and operating on it with sequence words:"
|
||||
{ $code
|
||||
"\"mydata.dat\" dup file-info file-info-length ["
|
||||
"\"mydata.dat\" dup file-info size>> ["
|
||||
" 4 <sliced-groups> [ reverse-here ] change-each"
|
||||
"] with-mapped-file"
|
||||
}
|
||||
|
|
|
|||
|
|
@ -139,7 +139,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ;
|
|||
{
|
||||
{ [ dup empty? ] [ (:help-none) ] }
|
||||
{ [ dup length 1 = ] [ first help ] }
|
||||
{ [ t ] [ (:help-multi) ] }
|
||||
[ (:help-multi) ]
|
||||
} cond (:help-debugger) ;
|
||||
|
||||
: remove-article ( name -- )
|
||||
|
|
|
|||
|
|
@ -92,7 +92,7 @@ M: printer print-tag ( tag -- )
|
|||
[ print-closing-named-tag ] }
|
||||
{ [ dup tag-name string? ]
|
||||
[ print-opening-named-tag ] }
|
||||
{ [ t ] [ <unknown-tag-error> throw ] }
|
||||
[ <unknown-tag-error> throw ]
|
||||
} cond ;
|
||||
|
||||
SYMBOL: tablestack
|
||||
|
|
|
|||
|
|
@ -145,10 +145,10 @@ TUPLE: cookie name value path domain expires http-only ;
|
|||
|
||||
: (unparse-cookie) ( key value -- )
|
||||
{
|
||||
{ [ dup f eq? ] [ 2drop ] }
|
||||
{ [ dup t eq? ] [ drop , ] }
|
||||
{ [ t ] [ "=" swap 3append , ] }
|
||||
} cond ;
|
||||
{ f [ drop ] }
|
||||
{ t [ , ] }
|
||||
[ "=" swap 3append , ]
|
||||
} case ;
|
||||
|
||||
: unparse-cookie ( cookie -- strings )
|
||||
[
|
||||
|
|
@ -399,7 +399,7 @@ body ;
|
|||
{ [ dup not ] [ drop ] }
|
||||
{ [ dup string? ] [ write ] }
|
||||
{ [ dup callable? ] [ call ] }
|
||||
{ [ t ] [ stdio get stream-copy ] }
|
||||
[ stdio get stream-copy ]
|
||||
} cond ;
|
||||
|
||||
M: response write-response ( respose -- )
|
||||
|
|
|
|||
|
|
@ -89,7 +89,7 @@ SYMBOL: form-hook
|
|||
{
|
||||
{ [ over "http://" head? ] [ link>string ] }
|
||||
{ [ over "/" head? ] [ absolute-redirect ] }
|
||||
{ [ t ] [ relative-redirect ] }
|
||||
[ relative-redirect ]
|
||||
} cond ;
|
||||
|
||||
: <redirect> ( to query code message -- response )
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ IN: http.server.static
|
|||
TUPLE: file-responder root hook special ;
|
||||
|
||||
: file-http-date ( filename -- string )
|
||||
file-info file-info-modified timestamp>http-string ;
|
||||
file-info modified>> timestamp>http-string ;
|
||||
|
||||
: last-modified-matches? ( filename -- ? )
|
||||
file-http-date dup [
|
||||
|
|
@ -27,7 +27,7 @@ TUPLE: file-responder root hook special ;
|
|||
[
|
||||
<content>
|
||||
swap
|
||||
[ file-info file-info-size "content-length" set-header ]
|
||||
[ file-info size>> "content-length" set-header ]
|
||||
[ file-http-date "last-modified" set-header ]
|
||||
[ '[ , binary <file-reader> stdio get stream-copy ] >>body ]
|
||||
tri
|
||||
|
|
|
|||
|
|
@ -26,7 +26,7 @@ M: template-lexer skip-word
|
|||
{
|
||||
{ [ 2dup nth CHAR: " = ] [ drop 1+ ] }
|
||||
{ [ 2dup swap tail-slice "%>" head? ] [ drop 2 + ] }
|
||||
{ [ t ] [ f skip ] }
|
||||
[ f skip ]
|
||||
} cond
|
||||
] change-lexer-column ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: inverse tools.test arrays math kernel sequences
|
||||
math.functions math.constants ;
|
||||
math.functions math.constants continuations ;
|
||||
IN: inverse-tests
|
||||
|
||||
[ 2 ] [ { 3 2 } [ 3 swap 2array ] undo ] unit-test
|
||||
|
|
@ -51,7 +51,7 @@ C: <nil> nil
|
|||
{
|
||||
{ [ <cons> ] [ list-sum + ] }
|
||||
{ [ <nil> ] [ 0 ] }
|
||||
{ [ ] [ "Malformed list" throw ] }
|
||||
[ "Malformed list" throw ]
|
||||
} switch ;
|
||||
|
||||
[ 10 ] [ 1 2 3 4 <nil> <cons> <cons> <cons> <cons> list-sum ] unit-test
|
||||
|
|
@ -59,6 +59,7 @@ C: <nil> nil
|
|||
[ 1 2 ] [ 1 2 <cons> [ <cons> ] undo ] unit-test
|
||||
[ t ] [ 1 2 <cons> [ <cons> ] matches? ] unit-test
|
||||
[ f ] [ 1 2 <cons> [ <foo> ] matches? ] unit-test
|
||||
[ "Malformed list" ] [ [ f list-sum ] [ ] recover ] unit-test
|
||||
|
||||
: empty-cons ( -- cons ) cons construct-empty ;
|
||||
: cons* ( cdr car -- cons ) { set-cons-cdr set-cons-car } cons construct ;
|
||||
|
|
@ -68,3 +69,4 @@ C: <nil> nil
|
|||
|
||||
[ t ] [ pi [ pi ] matches? ] unit-test
|
||||
[ 0.0 ] [ 0.0 pi + [ pi + ] undo ] unit-test
|
||||
[ ] [ 3 [ _ ] undo ] unit-test
|
||||
|
|
|
|||
|
|
@ -60,11 +60,13 @@ PREDICATE: math-inverse < word "math-inverse" word-prop ;
|
|||
PREDICATE: pop-inverse < word "pop-length" word-prop ;
|
||||
UNION: explicit-inverse normal-inverse math-inverse pop-inverse ;
|
||||
|
||||
: enough? ( stack quot -- ? )
|
||||
[ >r length r> 1quotation infer effect-in >= ] [ 3drop f ]
|
||||
recover ;
|
||||
: enough? ( stack word -- ? )
|
||||
dup deferred? [ 2drop f ] [
|
||||
[ >r length r> 1quotation infer effect-in >= ]
|
||||
[ 3drop f ] recover
|
||||
] if ;
|
||||
|
||||
: fold-word ( stack quot -- stack )
|
||||
: fold-word ( stack word -- stack )
|
||||
2dup enough?
|
||||
[ 1quotation with-datastack ] [ >r % r> , { } ] if ;
|
||||
|
||||
|
|
@ -72,10 +74,10 @@ UNION: explicit-inverse normal-inverse math-inverse pop-inverse ;
|
|||
[ { } swap [ fold-word ] each % ] [ ] make ;
|
||||
|
||||
: flattenable? ( object -- ? )
|
||||
[ [ word? ] [ primitive? not ] and? ] [
|
||||
{ [ word? ] [ primitive? not ] [
|
||||
{ "inverse" "math-inverse" "pop-inverse" }
|
||||
[ word-prop ] with contains? not
|
||||
] and? ;
|
||||
] } <-&& ;
|
||||
|
||||
: (flatten) ( quot -- )
|
||||
[ dup flattenable? [ word-def (flatten) ] [ , ] if ] each ;
|
||||
|
|
@ -159,7 +161,7 @@ MACRO: undo ( quot -- ) [undo] ;
|
|||
2curry
|
||||
] define-pop-inverse
|
||||
|
||||
: _ f ;
|
||||
DEFER: _
|
||||
\ _ [ drop ] define-inverse
|
||||
|
||||
: both ( object object -- object )
|
||||
|
|
@ -256,6 +258,7 @@ M: no-match summary drop "Fall through in switch" ;
|
|||
[ no-match ] [ swap \ recover-fail 3array >quotation ] reduce ;
|
||||
|
||||
: [switch] ( quot-alist -- quot )
|
||||
[ dup quotation? [ [ ] swap 2array ] when ] map
|
||||
reverse [ >r [undo] r> compose ] { } assoc>map
|
||||
recover-chain ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
! Copyright (C) 2008 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.syntax help.markup io.encodings.8-bit.private ;
|
||||
USING: help.syntax help.markup io.encodings.8-bit.private
|
||||
strings ;
|
||||
IN: io.encodings.8-bit
|
||||
|
||||
ARTICLE: "io.encodings.8-bit" "8-bit encodings"
|
||||
|
|
@ -34,8 +35,8 @@ HELP: 8-bit
|
|||
{ $class-description "Describes an 8-bit encoding, including its name (a symbol) and a table used for encoding and decoding." } ;
|
||||
|
||||
HELP: define-8-bit-encoding
|
||||
{ $values { "name" "a string" } { "path" "a path" } }
|
||||
{ $description "Creates a new encoding with the given name, using the resource file at the path to tell how to encode and decode octets. The resource file should be in a similar format to those at " { $url "ftp://ftp.unicode.org/Public/MAPPINGS/ISO8859/" } } ;
|
||||
{ $values { "name" string } { "stream" "an input stream" } }
|
||||
{ $description "Creates a new encoding. The stream should be in a similar format to those at " { $url "ftp://ftp.unicode.org/Public/MAPPINGS/ISO8859/" } } ;
|
||||
|
||||
HELP: latin1
|
||||
{ $description "This is the ISO-8859-1 encoding, also called Latin-1: Western European. It is an 8-bit superset of ASCII which is the default for a mimetype starting with 'text' and provides the characters necessary for most western European languages." }
|
||||
|
|
|
|||
|
|
@ -29,9 +29,10 @@ IN: io.encodings.8-bit
|
|||
{ "mac-roman" "ROMAN" }
|
||||
} ;
|
||||
|
||||
: full-path ( file-name -- path )
|
||||
: encoding-file ( file-name -- stream )
|
||||
"extra/io/encodings/8-bit/" ".TXT"
|
||||
swapd 3append resource-path ;
|
||||
swapd 3append resource-path
|
||||
ascii <file-reader> ;
|
||||
|
||||
: tail-if ( seq n -- newseq )
|
||||
2dup swap length <= [ tail ] [ drop ] if ;
|
||||
|
|
@ -48,8 +49,8 @@ IN: io.encodings.8-bit
|
|||
: ch>byte ( assoc -- newassoc )
|
||||
[ swap ] assoc-map >hashtable ;
|
||||
|
||||
: parse-file ( file-name -- byte>ch ch>byte )
|
||||
ascii file-lines process-contents
|
||||
: parse-file ( path -- byte>ch ch>byte )
|
||||
lines process-contents
|
||||
[ byte>ch ] [ ch>byte ] bi ;
|
||||
|
||||
TUPLE: 8-bit name decode encode ;
|
||||
|
|
@ -71,13 +72,13 @@ M: 8-bit decode-char
|
|||
: make-8-bit ( word byte>ch ch>byte -- )
|
||||
[ 8-bit construct-boa ] 2curry dupd curry define ;
|
||||
|
||||
: define-8-bit-encoding ( name path -- )
|
||||
: define-8-bit-encoding ( name stream -- )
|
||||
>r in get create r> parse-file make-8-bit ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
[
|
||||
"io.encodings.8-bit" in [
|
||||
mappings [ full-path define-8-bit-encoding ] assoc-each
|
||||
mappings [ encoding-file define-8-bit-encoding ] assoc-each
|
||||
] with-variable
|
||||
] with-compilation-unit
|
||||
|
|
|
|||
|
|
@ -129,9 +129,6 @@ HELP: <process>
|
|||
{ $values { "process" process } }
|
||||
{ $description "Creates a new, empty process. It must be filled in before being passed to " { $link run-process } "." } ;
|
||||
|
||||
HELP: process-stream
|
||||
{ $class-description "A bidirectional stream for interacting with a running process. Instances are created by calling " { $link <process-stream> } ". The " { $link process-stream-process } " slot holds a " { $link process } " instance." } ;
|
||||
|
||||
HELP: <process-stream>
|
||||
{ $values
|
||||
{ "desc" "a launch descriptor" }
|
||||
|
|
@ -144,7 +141,7 @@ HELP: with-process-stream
|
|||
{ "desc" "a launch descriptor" }
|
||||
{ "quot" quotation }
|
||||
{ "status" "an exit code" } }
|
||||
{ $description "Calls " { $snippet "quot" } " in a dynamic scope where " { $link stdio } " is rebound to a " { $link process-stream } ". After the quotation returns, waits for the process to end and outputs the exit code." } ;
|
||||
{ $description "Calls " { $snippet "quot" } " in a dynamic scope where " { $link stdio } " is rebound to a process stream. After the quotation returns, waits for the process to end and outputs the exit code." } ;
|
||||
|
||||
HELP: wait-for-process
|
||||
{ $values { "process" process } { "status" integer } }
|
||||
|
|
|
|||
|
|
@ -150,18 +150,18 @@ M: process timed-out kill-process ;
|
|||
|
||||
HOOK: (process-stream) io-backend ( process -- handle in out )
|
||||
|
||||
TUPLE: process-stream process ;
|
||||
: <process-stream*> ( desc encoding -- stream process )
|
||||
>r >process dup dup (process-stream) <reader&writer>
|
||||
r> <encoder-duplex> -roll
|
||||
process-started ;
|
||||
|
||||
: <process-stream> ( desc encoding -- stream )
|
||||
>r >process dup dup (process-stream)
|
||||
>r >r process-started process-stream construct-boa
|
||||
r> r> <reader&writer> r> <encoder-duplex>
|
||||
over set-delegate ;
|
||||
<process-stream*> drop ; inline
|
||||
|
||||
: with-process-stream ( desc quot -- status )
|
||||
swap <process-stream>
|
||||
swap <process-stream*> >r
|
||||
[ swap with-stream ] keep
|
||||
process>> wait-for-process ; inline
|
||||
r> wait-for-process ; inline
|
||||
|
||||
: notify-exit ( process status -- )
|
||||
>>status
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
USING: io io.mmap io.files kernel tools.test continuations
|
||||
sequences io.encodings.ascii ;
|
||||
sequences io.encodings.ascii accessors ;
|
||||
IN: io.mmap.tests
|
||||
|
||||
[ "mmap-test-file.txt" resource-path delete-file ] ignore-errors
|
||||
[ ] [ "12345" "mmap-test-file.txt" resource-path ascii set-file-contents ] unit-test
|
||||
[ ] [ "mmap-test-file.txt" resource-path dup file-info file-info-size [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test
|
||||
[ 5 ] [ "mmap-test-file.txt" resource-path dup file-info file-info-size [ length ] with-mapped-file ] unit-test
|
||||
[ ] [ "mmap-test-file.txt" resource-path dup file-info size>> [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test
|
||||
[ 5 ] [ "mmap-test-file.txt" resource-path dup file-info size>> [ length ] with-mapped-file ] unit-test
|
||||
[ "22345" ] [ "mmap-test-file.txt" resource-path ascii file-contents ] unit-test
|
||||
[ "mmap-test-file.txt" resource-path delete-file ] ignore-errors
|
||||
|
|
|
|||
|
|
@ -1,58 +1,108 @@
|
|||
IN: io.monitors
|
||||
USING: help.markup help.syntax continuations ;
|
||||
USING: help.markup help.syntax continuations
|
||||
concurrency.mailboxes quotations ;
|
||||
|
||||
HELP: with-monitors
|
||||
{ $values { "quot" quotation } }
|
||||
{ $description "Calls a quotation in a new dynamic scope where file system monitor operations can be performed." }
|
||||
{ $errors "Throws an error if the platform does not support file system change monitors." } ;
|
||||
|
||||
HELP: <monitor>
|
||||
{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "monitor" "a new monitor" } }
|
||||
{ $description "Opens a file system change monitor which listens for changes on " { $snippet "path" } ". The boolean indicates whether changes in subdirectories should be reported."
|
||||
$nl
|
||||
"Not all operating systems support recursive monitors; if recursive monitoring is not available, an error is thrown and the caller must implement alternative logic for monitoring subdirectories." } ;
|
||||
{ $contract "Opens a file system change monitor which listens for changes on " { $snippet "path" } ". The boolean indicates whether changes in subdirectories should be reported." }
|
||||
{ $errors "Throws an error if the pathname does not exist, if a monitor could not be created or if the platform does not support monitors." } ;
|
||||
|
||||
HELP: (monitor)
|
||||
{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "mailbox" mailbox } { "monitor" "a new monitor" } }
|
||||
{ $contract "Opens a file system change monitor which listens for changes on " { $snippet "path" } " and posts notifications to " { $snippet "mailbox" } " as triples with shape " { $snippet "{ path changed monitor } " } ". The boolean indicates whether changes in subdirectories should be reported." }
|
||||
{ $errors "Throws an error if the pathname does not exist, if a monitor could not be created or if the platform does not support monitors." } ;
|
||||
|
||||
HELP: next-change
|
||||
{ $values { "monitor" "a monitor" } { "path" "a pathname string" } { "changed" "a change descriptor" } }
|
||||
{ $description "Waits for file system changes and outputs the pathname of the first changed file. The change descriptor is a sequence of symbols documented in " { $link "io.monitors.descriptors" } "." } ;
|
||||
{ $contract "Waits for file system changes and outputs the pathname of the first changed file. The change descriptor is a sequence of symbols documented in " { $link "io.monitors.descriptors" } "." }
|
||||
{ $errors "Throws an error if the monitor is closed from another thread." } ;
|
||||
|
||||
HELP: with-monitor
|
||||
{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "quot" "a quotation with stack effect " { $snippet "( monitor -- )" } } }
|
||||
{ $description "Opens a file system change monitor and passes it to the quotation. Closes the monitor after the quotation returns or throws an error." } ;
|
||||
{ $description "Opens a file system change monitor and passes it to the quotation. Closes the monitor after the quotation returns or throws an error." }
|
||||
{ $errors "Throws an error if the pathname does not exist, if a monitor could not be created or if the platform does not support monitors." } ;
|
||||
|
||||
HELP: +add-file+
|
||||
{ $description "Indicates that the file has been added to the directory." } ;
|
||||
{ $description "Indicates that a file has been added to its parent directory." } ;
|
||||
|
||||
HELP: +remove-file+
|
||||
{ $description "Indicates that the file has been removed from the directory." } ;
|
||||
{ $description "Indicates that a file has been removed from its parent directory." } ;
|
||||
|
||||
HELP: +modify-file+
|
||||
{ $description "Indicates that the file contents have changed." } ;
|
||||
{ $description "Indicates that a file's contents have changed." } ;
|
||||
|
||||
HELP: +rename-file-old+
|
||||
{ $description "Indicates that a file has been renamed, and this is the old name." } ;
|
||||
|
||||
HELP: +rename-file-new+
|
||||
{ $description "Indicates that a file has been renamed, and this is the new name." } ;
|
||||
|
||||
HELP: +rename-file+
|
||||
{ $description "Indicates that file has been renamed." } ;
|
||||
{ $description "Indicates that a file has been renamed." } ;
|
||||
|
||||
ARTICLE: "io.monitors.descriptors" "File system change descriptors"
|
||||
"Change descriptors output by " { $link next-change } ":"
|
||||
{ $subsection +add-file+ }
|
||||
{ $subsection +remove-file+ }
|
||||
{ $subsection +modify-file+ }
|
||||
{ $subsection +rename-file+ }
|
||||
{ $subsection +add-file+ } ;
|
||||
{ $subsection +rename-file-old+ }
|
||||
{ $subsection +rename-file-new+ }
|
||||
{ $subsection +rename-file+ } ;
|
||||
|
||||
ARTICLE: "io.monitors.platforms" "Monitors on different platforms"
|
||||
"Whether the " { $snippet "path" } " output value of " { $link next-change } " contains an absolute path or a path relative to the path given to " { $link <monitor> } " is platform-specific. User code should not assume either case."
|
||||
{ $heading "Mac OS X" }
|
||||
"Factor uses " { $snippet "FSEventStream" } "s to implement monitors on Mac OS X. This requires Mac OS X 10.5 or later."
|
||||
$nl
|
||||
{ $snippet "FSEventStream" } "s always monitor directory hierarchies recursively, and the " { $snippet "recursive?" } " parameter to " { $link <monitor> } " has no effect."
|
||||
$nl
|
||||
"The " { $snippet "changed" } " output value of the " { $link next-change } " word always outputs " { $link +modify-file+ } " and the " { $snippet "path" } " output value is always the directory containing the file that changed. Unlike other platforms, fine-grained information is not available."
|
||||
{ $heading "Windows" }
|
||||
"Factor uses " { $snippet "ReadDirectoryChanges" } " to implement monitors on Windows."
|
||||
$nl
|
||||
"Both recursive and non-recursive monitors are directly supported by the operating system."
|
||||
{ $heading "Linux" }
|
||||
"Factor uses " { $snippet "inotify" } " to implement monitors on Linux. This requires Linux kernel version 2.6.16 or later."
|
||||
$nl
|
||||
"Factor simulates recursive monitors by creating a hierarchy of monitors for every subdirectory, since " { $snippet "inotify" } " can only monitor a single directory. This is transparent to user code."
|
||||
$nl
|
||||
"Inside a single " { $link with-monitors } " scope, only one monitor may be created for any given directory."
|
||||
{ $heading "BSD" }
|
||||
"Factor uses " { $snippet "kqueue" } " to implement monitors on BSD."
|
||||
$nl
|
||||
"The " { $snippet "kqueue" } " system is limited to monitoring individual files and directories. Monitoring a directory only notifies of files being added and removed to the directory itself, not of changes to file contents."
|
||||
{ $heading "Windows CE" }
|
||||
"Windows CE does not support monitors." ;
|
||||
|
||||
ARTICLE: "io.monitors" "File system change monitors"
|
||||
"File system change monitors listen for changes to file names, attributes and contents under a specified directory. They can optionally be recursive, in which case subdirectories are also monitored."
|
||||
$nl
|
||||
"Monitoring operations must be wrapped in a combinator:"
|
||||
{ $subsection with-monitors }
|
||||
"Creating a file system change monitor and listening for changes:"
|
||||
{ $subsection <monitor> }
|
||||
{ $subsection next-change }
|
||||
"An alternative programming style is where instead of having a thread listen for changes on a monitor, change notifications are posted to a mailbox:"
|
||||
{ $subsection (monitor) }
|
||||
{ $subsection "io.monitors.descriptors" }
|
||||
"Monitors are closed by calling " { $link dispose } " or " { $link with-disposal } "."
|
||||
$nl
|
||||
"A utility combinator which opens a monitor and cleans it up after:"
|
||||
{ $subsection "io.monitors.platforms" }
|
||||
"Monitors are closed by calling " { $link dispose } " or " { $link with-disposal } ". An easy way to pair construction with disposal is to use a combinator:"
|
||||
{ $subsection with-monitor }
|
||||
"An example which watches the Factor directory for changes:"
|
||||
"Monitors support the " { $link "io.timeouts" } "."
|
||||
$nl
|
||||
"An example which watches a directory for changes:"
|
||||
{ $code
|
||||
"USE: io.monitors"
|
||||
": watch-loop ( monitor -- )"
|
||||
" dup next-change . . nl nl flush watch-loop ;"
|
||||
""
|
||||
"\"\" resource-path f [ watch-loop ] with-monitor"
|
||||
": watch-directory ( path -- )"
|
||||
" [ t [ watch-loop ] with-monitor ] with-monitors"
|
||||
} ;
|
||||
|
||||
ABOUT: "io.monitors"
|
||||
|
|
|
|||
|
|
@ -3,36 +3,89 @@ USING: io.monitors tools.test io.files system sequences
|
|||
continuations namespaces concurrency.count-downs kernel io
|
||||
threads calendar prettyprint ;
|
||||
|
||||
os { winnt macosx linux } member? [
|
||||
[ "monitor-test" temp-file delete-tree ] ignore-errors
|
||||
os { winnt linux macosx } member? [
|
||||
[
|
||||
[ "monitor-test" temp-file delete-tree ] ignore-errors
|
||||
|
||||
[ ] [ "monitor-test/xyz" temp-file make-directories ] unit-test
|
||||
[ ] [ "monitor-test" temp-file make-directory ] unit-test
|
||||
|
||||
[ ] [ "monitor-test" temp-file t <monitor> "m" set ] unit-test
|
||||
[ ] [ "monitor-test" temp-file t <monitor> "m" set ] unit-test
|
||||
|
||||
[ ] [ 1 <count-down> "b" set ] unit-test
|
||||
[ ] [ "monitor-test/a1" temp-file make-directory ] unit-test
|
||||
|
||||
[ ] [ 1 <count-down> "c" set ] unit-test
|
||||
[ ] [ "monitor-test/a2" temp-file make-directory ] unit-test
|
||||
|
||||
[ ] [
|
||||
[
|
||||
"b" get count-down
|
||||
[
|
||||
"m" get next-change drop
|
||||
dup print flush right-trim-separators
|
||||
"xyz" tail? not
|
||||
] [ ] [ ] while
|
||||
"c" get count-down
|
||||
] "Monitor test thread" spawn drop
|
||||
] unit-test
|
||||
[ ] [ "monitor-test/a1" temp-file "monitor-test/a2" temp-file move-file-into ] unit-test
|
||||
|
||||
[ ] [ "b" get await ] unit-test
|
||||
[ t ] [ "monitor-test/a2/a1" temp-file exists? ] unit-test
|
||||
|
||||
[ ] [ "monitor-test/xyz/test.txt" temp-file touch-file ] unit-test
|
||||
[ ] [ "monitor-test/a2/a1/a3.txt" temp-file touch-file ] unit-test
|
||||
|
||||
[ ] [ "c" get 30 seconds await-timeout ] unit-test
|
||||
[ t ] [ "monitor-test/a2/a1/a3.txt" temp-file exists? ] unit-test
|
||||
|
||||
[ ] [ "m" get dispose ] unit-test
|
||||
[ ] [ "monitor-test/a2/a1/a4.txt" temp-file touch-file ] unit-test
|
||||
[ ] [ "monitor-test/a2/a1/a5.txt" temp-file touch-file ] unit-test
|
||||
[ ] [ "monitor-test/a2/a1/a4.txt" temp-file delete-file ] unit-test
|
||||
[ ] [ "monitor-test/a2/a1/a5.txt" temp-file "monitor-test/a2/a1/a4.txt" temp-file move-file ] unit-test
|
||||
|
||||
[ "m" get dispose ] must-fail
|
||||
[ t ] [ "monitor-test/a2/a1/a4.txt" temp-file exists? ] unit-test
|
||||
|
||||
[ ] [ "m" get dispose ] unit-test
|
||||
] with-monitors
|
||||
|
||||
|
||||
[
|
||||
[ "monitor-test" temp-file delete-tree ] ignore-errors
|
||||
|
||||
[ ] [ "monitor-test/xyz" temp-file make-directories ] unit-test
|
||||
|
||||
[ ] [ "monitor-test" temp-file t <monitor> "m" set ] unit-test
|
||||
|
||||
[ ] [ 1 <count-down> "b" set ] unit-test
|
||||
|
||||
[ ] [ 1 <count-down> "c1" set ] unit-test
|
||||
|
||||
[ ] [ 1 <count-down> "c2" set ] unit-test
|
||||
|
||||
[ ] [
|
||||
[
|
||||
"b" get count-down
|
||||
|
||||
[
|
||||
"m" get next-change drop
|
||||
dup print flush
|
||||
dup parent-directory
|
||||
[ right-trim-separators "xyz" tail? ] either? not
|
||||
] [ ] [ ] while
|
||||
|
||||
"c1" get count-down
|
||||
|
||||
[
|
||||
"m" get next-change drop
|
||||
dup print flush
|
||||
dup parent-directory
|
||||
[ right-trim-separators "yxy" tail? ] either? not
|
||||
] [ ] [ ] while
|
||||
|
||||
"c2" get count-down
|
||||
] "Monitor test thread" spawn drop
|
||||
] unit-test
|
||||
|
||||
[ ] [ "b" get await ] unit-test
|
||||
|
||||
[ ] [ "monitor-test/xyz/test.txt" temp-file touch-file ] unit-test
|
||||
|
||||
[ ] [ "c1" get 15 seconds await-timeout ] unit-test
|
||||
|
||||
[ ] [ "monitor-test/subdir/blah/yxy" temp-file make-directories ] unit-test
|
||||
|
||||
[ ] [ "monitor-test/subdir/blah/yxy/test.txt" temp-file touch-file ] unit-test
|
||||
|
||||
[ ] [ "c2" get 15 seconds await-timeout ] unit-test
|
||||
|
||||
! Dispose twice
|
||||
[ ] [ "m" get dispose ] unit-test
|
||||
|
||||
[ ] [ "m" get dispose ] unit-test
|
||||
] with-monitors
|
||||
] when
|
||||
|
|
|
|||
|
|
@ -1,83 +1,55 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io.backend kernel continuations namespaces sequences
|
||||
assocs hashtables sorting arrays threads boxes io.timeouts ;
|
||||
IN: io.monitors
|
||||
|
||||
<PRIVATE
|
||||
|
||||
TUPLE: monitor queue closed? ;
|
||||
|
||||
: check-monitor ( monitor -- )
|
||||
monitor-closed? [ "Monitor closed" throw ] when ;
|
||||
|
||||
: (monitor) ( delegate -- monitor )
|
||||
H{ } clone {
|
||||
set-delegate
|
||||
set-monitor-queue
|
||||
} monitor construct ;
|
||||
|
||||
GENERIC: fill-queue ( monitor -- )
|
||||
|
||||
: changed-file ( changed path -- )
|
||||
namespace [ append ] change-at ;
|
||||
|
||||
: dequeue-change ( assoc -- path changes )
|
||||
delete-any prune natural-sort >array ;
|
||||
|
||||
M: monitor dispose
|
||||
dup check-monitor
|
||||
t over set-monitor-closed?
|
||||
delegate dispose ;
|
||||
|
||||
! Simple monitor; used on Linux and Mac OS X. On Windows,
|
||||
! monitors are full-fledged ports.
|
||||
TUPLE: simple-monitor handle callback timeout ;
|
||||
|
||||
M: simple-monitor timeout simple-monitor-timeout ;
|
||||
|
||||
M: simple-monitor set-timeout set-simple-monitor-timeout ;
|
||||
|
||||
: <simple-monitor> ( handle -- simple-monitor )
|
||||
f (monitor) <box> {
|
||||
set-simple-monitor-handle
|
||||
set-delegate
|
||||
set-simple-monitor-callback
|
||||
} simple-monitor construct ;
|
||||
|
||||
: construct-simple-monitor ( handle class -- simple-monitor )
|
||||
>r <simple-monitor> r> construct-delegate ; inline
|
||||
|
||||
: notify-callback ( simple-monitor -- )
|
||||
simple-monitor-callback [ resume ] if-box? ;
|
||||
|
||||
M: simple-monitor timed-out
|
||||
notify-callback ;
|
||||
|
||||
M: simple-monitor fill-queue ( monitor -- )
|
||||
[
|
||||
[ swap simple-monitor-callback >box ]
|
||||
"monitor" suspend drop
|
||||
] with-timeout
|
||||
check-monitor ;
|
||||
|
||||
M: simple-monitor dispose ( monitor -- )
|
||||
dup delegate dispose notify-callback ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
HOOK: <monitor> io-backend ( path recursive? -- monitor )
|
||||
|
||||
: next-change ( monitor -- path changed )
|
||||
dup check-monitor
|
||||
dup monitor-queue dup assoc-empty? [
|
||||
drop dup fill-queue next-change
|
||||
] [ nip dequeue-change ] if ;
|
||||
|
||||
SYMBOL: +add-file+
|
||||
SYMBOL: +remove-file+
|
||||
SYMBOL: +modify-file+
|
||||
SYMBOL: +rename-file+
|
||||
|
||||
: with-monitor ( path recursive? quot -- )
|
||||
>r <monitor> r> with-disposal ; inline
|
||||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io.backend kernel continuations namespaces sequences
|
||||
assocs hashtables sorting arrays threads boxes io.timeouts
|
||||
accessors concurrency.mailboxes ;
|
||||
IN: io.monitors
|
||||
|
||||
HOOK: init-monitors io-backend ( -- )
|
||||
|
||||
M: object init-monitors ;
|
||||
|
||||
HOOK: dispose-monitors io-backend ( -- )
|
||||
|
||||
M: object dispose-monitors ;
|
||||
|
||||
: with-monitors ( quot -- )
|
||||
[
|
||||
init-monitors
|
||||
[ dispose-monitors ] [ ] cleanup
|
||||
] with-scope ; inline
|
||||
|
||||
TUPLE: monitor < identity-tuple path queue timeout ;
|
||||
|
||||
M: monitor hashcode* path>> hashcode* ;
|
||||
|
||||
M: monitor timeout timeout>> ;
|
||||
|
||||
M: monitor set-timeout (>>timeout) ;
|
||||
|
||||
: construct-monitor ( path mailbox class -- monitor )
|
||||
construct-empty
|
||||
swap >>queue
|
||||
swap >>path ; inline
|
||||
|
||||
: queue-change ( path changes monitor -- )
|
||||
3dup and and
|
||||
[ [ 3array ] keep queue>> mailbox-put ] [ 3drop ] if ;
|
||||
|
||||
HOOK: (monitor) io-backend ( path recursive? mailbox -- monitor )
|
||||
|
||||
: <monitor> ( path recursive? -- monitor )
|
||||
<mailbox> (monitor) ;
|
||||
|
||||
: next-change ( monitor -- path changed )
|
||||
[ queue>> ] [ timeout ] bi mailbox-get-timeout first2 ;
|
||||
|
||||
SYMBOL: +add-file+
|
||||
SYMBOL: +remove-file+
|
||||
SYMBOL: +modify-file+
|
||||
SYMBOL: +rename-file-old+
|
||||
SYMBOL: +rename-file-new+
|
||||
SYMBOL: +rename-file+
|
||||
|
||||
: with-monitor ( path recursive? quot -- )
|
||||
>r <monitor> r> with-disposal ; inline
|
||||
|
|
|
|||
|
|
@ -0,0 +1,59 @@
|
|||
USING: accessors math kernel namespaces continuations
|
||||
io.files io.monitors io.monitors.recursive io.backend
|
||||
concurrency.mailboxes
|
||||
tools.test ;
|
||||
IN: io.monitors.recursive.tests
|
||||
|
||||
\ pump-thread must-infer
|
||||
|
||||
SINGLETON: mock-io-backend
|
||||
|
||||
TUPLE: counter i ;
|
||||
|
||||
SYMBOL: dummy-monitor-created
|
||||
SYMBOL: dummy-monitor-disposed
|
||||
|
||||
TUPLE: dummy-monitor < monitor ;
|
||||
|
||||
M: dummy-monitor dispose
|
||||
drop dummy-monitor-disposed get [ 1+ ] change-i drop ;
|
||||
|
||||
M: mock-io-backend (monitor)
|
||||
nip
|
||||
over exists? [
|
||||
dummy-monitor construct-monitor
|
||||
dummy-monitor-created get [ 1+ ] change-i drop
|
||||
] [
|
||||
"Does not exist" throw
|
||||
] if ;
|
||||
|
||||
M: mock-io-backend link-info
|
||||
global [ link-info ] bind ;
|
||||
|
||||
[ ] [ 0 counter construct-boa dummy-monitor-created set ] unit-test
|
||||
[ ] [ 0 counter construct-boa dummy-monitor-disposed set ] unit-test
|
||||
|
||||
[ ] [
|
||||
mock-io-backend io-backend [
|
||||
"" resource-path <mailbox> <recursive-monitor> dispose
|
||||
] with-variable
|
||||
] unit-test
|
||||
|
||||
[ t ] [ dummy-monitor-created get i>> 0 > ] unit-test
|
||||
|
||||
[ t ] [ dummy-monitor-created get i>> dummy-monitor-disposed get i>> = ] unit-test
|
||||
|
||||
[ "doesnotexist" temp-file delete-tree ] ignore-errors
|
||||
|
||||
[
|
||||
mock-io-backend io-backend [
|
||||
"doesnotexist" temp-file <mailbox> <recursive-monitor> dispose
|
||||
] with-variable
|
||||
] must-fail
|
||||
|
||||
[ ] [
|
||||
mock-io-backend io-backend [
|
||||
"" resource-path <mailbox> <recursive-monitor>
|
||||
[ dispose ] [ dispose ] bi
|
||||
] with-variable
|
||||
] unit-test
|
||||
|
|
@ -0,0 +1,105 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors sequences assocs arrays continuations combinators kernel
|
||||
threads concurrency.messaging concurrency.mailboxes
|
||||
concurrency.promises
|
||||
io.files io.monitors ;
|
||||
IN: io.monitors.recursive
|
||||
|
||||
! Simulate recursive monitors on platforms that don't have them
|
||||
|
||||
TUPLE: recursive-monitor < monitor children thread ready ;
|
||||
|
||||
DEFER: add-child-monitor
|
||||
|
||||
: qualify-path ( path -- path' )
|
||||
monitor tget path>> prepend-path ;
|
||||
|
||||
: add-child-monitors ( path -- )
|
||||
#! We yield since this directory scan might take a while.
|
||||
[
|
||||
directory* [ first add-child-monitor yield ] each
|
||||
] curry ignore-errors ;
|
||||
|
||||
: add-child-monitor ( path -- )
|
||||
qualify-path dup link-info type>> +directory+ eq? [
|
||||
[ add-child-monitors ]
|
||||
[
|
||||
[ f my-mailbox (monitor) ] keep
|
||||
monitor tget children>> set-at
|
||||
] bi
|
||||
] [ drop ] if ;
|
||||
|
||||
USE: io
|
||||
USE: prettyprint
|
||||
|
||||
: remove-child-monitor ( monitor -- )
|
||||
monitor tget children>> delete-at*
|
||||
[ dispose ] [ drop ] if ;
|
||||
|
||||
M: recursive-monitor dispose
|
||||
dup queue>> closed>> [
|
||||
drop
|
||||
] [
|
||||
[ "stop" swap thread>> send-synchronous drop ]
|
||||
[ queue>> dispose ] bi
|
||||
] if ;
|
||||
|
||||
: stop-pump ( -- )
|
||||
monitor tget children>> [ nip dispose ] assoc-each ;
|
||||
|
||||
: pump-step ( msg -- )
|
||||
first3 path>> swap >r prepend-path r> monitor tget 3array
|
||||
monitor tget queue>>
|
||||
mailbox-put ;
|
||||
|
||||
: child-added ( path monitor -- )
|
||||
path>> prepend-path add-child-monitor ;
|
||||
|
||||
: child-removed ( path monitor -- )
|
||||
path>> prepend-path remove-child-monitor ;
|
||||
|
||||
: update-hierarchy ( msg -- )
|
||||
first3 swap [
|
||||
{
|
||||
{ +add-file+ [ child-added ] }
|
||||
{ +remove-file+ [ child-removed ] }
|
||||
{ +rename-file-old+ [ child-removed ] }
|
||||
{ +rename-file-new+ [ child-added ] }
|
||||
[ 3drop ]
|
||||
} case
|
||||
] with with each ;
|
||||
|
||||
: pump-loop ( -- )
|
||||
receive dup synchronous? [
|
||||
>r stop-pump t r> reply-synchronous
|
||||
] [
|
||||
[ [ update-hierarchy ] curry ignore-errors ] [ pump-step ] bi
|
||||
pump-loop
|
||||
] if ;
|
||||
|
||||
: monitor-ready ( error/t -- )
|
||||
monitor tget ready>> fulfill ;
|
||||
|
||||
: pump-thread ( monitor -- )
|
||||
monitor tset
|
||||
[ "" add-child-monitor t monitor-ready ]
|
||||
[ [ self <linked-error> monitor-ready ] keep rethrow ]
|
||||
recover
|
||||
pump-loop ;
|
||||
|
||||
: start-pump-thread ( monitor -- )
|
||||
dup [ pump-thread ] curry
|
||||
"Recursive monitor pump" spawn
|
||||
>>thread drop ;
|
||||
|
||||
: wait-for-ready ( monitor -- )
|
||||
ready>> ?promise ?linked drop ;
|
||||
|
||||
: <recursive-monitor> ( path mailbox -- monitor )
|
||||
>r (normalize-path) r>
|
||||
recursive-monitor construct-monitor
|
||||
H{ } clone >>children
|
||||
<promise> >>ready
|
||||
dup start-pump-thread
|
||||
dup wait-for-ready ;
|
||||
|
|
@ -1,5 +1,5 @@
|
|||
USING: io io.buffers io.backend help.markup help.syntax kernel
|
||||
byte-arrays sbufs words continuations byte-vectors ;
|
||||
byte-arrays sbufs words continuations byte-vectors classes ;
|
||||
IN: io.nonblocking
|
||||
|
||||
ARTICLE: "io.nonblocking" "Non-blocking I/O implementation"
|
||||
|
|
@ -36,10 +36,10 @@ HELP: port
|
|||
$nl
|
||||
"Ports have the following slots:"
|
||||
{ $list
|
||||
{ { $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-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" }
|
||||
{ { $snippet "handle" } " - a native handle identifying the underlying native resource used by the port" }
|
||||
{ { $snippet "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" }
|
||||
{ { $snippet "type" } " - a symbol identifying the port's intended purpose" }
|
||||
{ { $snippet "eof" } " - a flag indicating if the port has reached the end of file while reading" }
|
||||
} } ;
|
||||
|
||||
HELP: input-port
|
||||
|
|
@ -53,12 +53,12 @@ HELP: init-handle
|
|||
{ $contract "Prepares a native handle for use by the port; called by " { $link <port> } "." } ;
|
||||
|
||||
HELP: <port>
|
||||
{ $values { "handle" "a native handle identifying an I/O resource" } { "buffer" "a " { $link buffer } " or " { $link f } } { "type" symbol } { "port" "a new " { $link port } } }
|
||||
{ $description "Creates a new " { $link port } " using the specified native handle and I/O buffer." }
|
||||
{ $values { "handle" "a native handle identifying an I/O resource" } { "class" class } { "port" "a new " { $link port } } }
|
||||
{ $description "Creates a new " { $link port } " with no buffer." }
|
||||
$low-level-note ;
|
||||
|
||||
HELP: <buffered-port>
|
||||
{ $values { "handle" "a native handle identifying an I/O resource" } { "type" symbol } { "port" "a new " { $link port } } }
|
||||
{ $values { "handle" "a native handle identifying an I/O resource" } { "class" class } { "port" "a new " { $link port } } }
|
||||
{ $description "Creates a new " { $link port } " using the specified native handle and a default-sized I/O buffer." }
|
||||
$low-level-note ;
|
||||
|
||||
|
|
@ -93,5 +93,5 @@ HELP: unless-eof
|
|||
{ $description "If the port has reached end of file, outputs " { $link f } ", otherwise applies the quotation to the port." } ;
|
||||
|
||||
HELP: can-write?
|
||||
{ $values { "len" "a positive integer" } { "writer" output-port } { "?" "a boolean" } }
|
||||
{ $values { "len" "a positive integer" } { "buffer" buffer } { "?" "a boolean" } }
|
||||
{ $description "Tests if the port's output buffer can accomodate " { $snippet "len" } " bytes. If the buffer is empty, this always outputs " { $link t } ", since in that case the buffer will be grown automatically." } ;
|
||||
|
|
|
|||
|
|
@ -1,46 +1,39 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: io.nonblocking
|
||||
USING: math kernel io sequences io.buffers io.timeouts generic
|
||||
byte-vectors system io.streams.duplex io.encodings
|
||||
io.backend continuations debugger classes byte-arrays namespaces
|
||||
splitting dlists assocs io.encodings.binary ;
|
||||
splitting dlists assocs io.encodings.binary accessors ;
|
||||
IN: io.nonblocking
|
||||
|
||||
SYMBOL: default-buffer-size
|
||||
64 1024 * default-buffer-size set-global
|
||||
|
||||
! Common delegate of native stream readers and writers
|
||||
TUPLE: port
|
||||
handle
|
||||
error
|
||||
timeout
|
||||
type eof? ;
|
||||
TUPLE: port handle buffer error timeout closed eof ;
|
||||
|
||||
M: port timeout port-timeout ;
|
||||
M: port timeout timeout>> ;
|
||||
|
||||
M: port set-timeout set-port-timeout ;
|
||||
|
||||
SYMBOL: closed
|
||||
|
||||
PREDICATE: input-port < port port-type input-port eq? ;
|
||||
PREDICATE: output-port < port port-type output-port eq? ;
|
||||
M: port set-timeout (>>timeout) ;
|
||||
|
||||
GENERIC: init-handle ( handle -- )
|
||||
|
||||
GENERIC: close-handle ( handle -- )
|
||||
|
||||
: <port> ( handle buffer type -- port )
|
||||
pick init-handle {
|
||||
set-port-handle
|
||||
set-delegate
|
||||
set-port-type
|
||||
} port construct ;
|
||||
: <port> ( handle class -- port )
|
||||
construct-empty
|
||||
swap dup init-handle >>handle ; inline
|
||||
|
||||
: <buffered-port> ( handle type -- port )
|
||||
default-buffer-size get <buffer> swap <port> ;
|
||||
: <buffered-port> ( handle class -- port )
|
||||
<port>
|
||||
default-buffer-size get <buffer> >>buffer ; inline
|
||||
|
||||
TUPLE: input-port < port ;
|
||||
|
||||
: <reader> ( handle -- input-port )
|
||||
input-port <buffered-port> ;
|
||||
|
||||
TUPLE: output-port < port ;
|
||||
|
||||
: <writer> ( handle -- output-port )
|
||||
output-port <buffered-port> ;
|
||||
|
||||
|
|
@ -48,7 +41,10 @@ GENERIC: close-handle ( handle -- )
|
|||
swap <reader> [ swap <writer> ] [ ] [ dispose drop ] cleanup ;
|
||||
|
||||
: pending-error ( port -- )
|
||||
dup port-error f rot set-port-error [ throw ] when* ;
|
||||
[ f ] change-error drop [ throw ] when* ;
|
||||
|
||||
: check-closed ( port -- port )
|
||||
dup closed>> [ "Port closed" throw ] when ;
|
||||
|
||||
HOOK: cancel-io io-backend ( port -- )
|
||||
|
||||
|
|
@ -59,21 +55,22 @@ M: port timed-out cancel-io ;
|
|||
GENERIC: (wait-to-read) ( port -- )
|
||||
|
||||
: wait-to-read ( count port -- )
|
||||
tuck buffer-length > [ (wait-to-read) ] [ drop ] if ;
|
||||
tuck buffer>> buffer-length > [ (wait-to-read) ] [ drop ] if ;
|
||||
|
||||
: wait-to-read1 ( port -- )
|
||||
1 swap wait-to-read ;
|
||||
|
||||
: unless-eof ( port quot -- value )
|
||||
>r dup buffer-empty? over port-eof? and
|
||||
[ f swap set-port-eof? f ] r> if ; inline
|
||||
>r dup buffer>> buffer-empty? over eof>> and
|
||||
[ f >>eof drop f ] r> if ; inline
|
||||
|
||||
M: input-port stream-read1
|
||||
dup wait-to-read1 [ buffer-pop ] unless-eof ;
|
||||
check-closed
|
||||
dup wait-to-read1 [ buffer>> buffer-pop ] unless-eof ;
|
||||
|
||||
: read-step ( count port -- byte-array/f )
|
||||
[ wait-to-read ] 2keep
|
||||
[ dupd buffer-read ] unless-eof nip ;
|
||||
[ dupd buffer>> buffer-read ] unless-eof nip ;
|
||||
|
||||
: read-loop ( count port accum -- )
|
||||
pick over length - dup 0 > [
|
||||
|
|
@ -87,6 +84,7 @@ M: input-port stream-read1
|
|||
] if ;
|
||||
|
||||
M: input-port stream-read
|
||||
check-closed
|
||||
>r 0 max >fixnum r>
|
||||
2dup read-step dup [
|
||||
pick over length > [
|
||||
|
|
@ -94,72 +92,75 @@ M: input-port stream-read
|
|||
[ push-all ] keep
|
||||
[ read-loop ] keep
|
||||
B{ } like
|
||||
] [
|
||||
2nip
|
||||
] if
|
||||
] [
|
||||
2nip
|
||||
] if ;
|
||||
] [ 2nip ] if
|
||||
] [ 2nip ] if ;
|
||||
|
||||
M: input-port stream-read-partial ( max stream -- byte-array/f )
|
||||
check-closed
|
||||
>r 0 max >fixnum r> read-step ;
|
||||
|
||||
: can-write? ( len writer -- ? )
|
||||
: can-write? ( len buffer -- ? )
|
||||
[ buffer-fill + ] keep buffer-capacity <= ;
|
||||
|
||||
: wait-to-write ( len port -- )
|
||||
tuck can-write? [ drop ] [ stream-flush ] if ;
|
||||
tuck buffer>> can-write? [ drop ] [ stream-flush ] if ;
|
||||
|
||||
M: output-port stream-write1
|
||||
1 over wait-to-write byte>buffer ;
|
||||
check-closed
|
||||
1 over wait-to-write
|
||||
buffer>> byte>buffer ;
|
||||
|
||||
M: output-port stream-write
|
||||
over length over buffer-size > [
|
||||
[ buffer-size <groups> ] keep
|
||||
[ stream-write ] curry each
|
||||
check-closed
|
||||
over length over buffer>> buffer-size > [
|
||||
[ buffer>> buffer-size <groups> ]
|
||||
[ [ stream-write ] curry ] bi
|
||||
each
|
||||
] [
|
||||
over length over wait-to-write >buffer
|
||||
[ >r length r> wait-to-write ]
|
||||
[ buffer>> >buffer ] 2bi
|
||||
] if ;
|
||||
|
||||
GENERIC: port-flush ( port -- )
|
||||
|
||||
M: output-port stream-flush ( port -- )
|
||||
dup port-flush pending-error ;
|
||||
check-closed
|
||||
[ port-flush ] [ pending-error ] bi ;
|
||||
|
||||
: close-port ( port type -- )
|
||||
output-port eq? [ dup port-flush ] when
|
||||
GENERIC: close-port ( port -- )
|
||||
|
||||
M: output-port close-port
|
||||
[ port-flush ] [ call-next-method ] bi ;
|
||||
|
||||
M: port close-port
|
||||
dup cancel-io
|
||||
dup port-handle close-handle
|
||||
dup delegate [ buffer-free ] when*
|
||||
f swap set-delegate ;
|
||||
dup handle>> close-handle
|
||||
[ [ buffer-free ] when* f ] change-buffer drop ;
|
||||
|
||||
M: port dispose
|
||||
dup port-type closed eq?
|
||||
[ drop ]
|
||||
[ dup port-type >r closed over set-port-type r> close-port ]
|
||||
if ;
|
||||
dup closed>> [ drop ] [ t >>closed close-port ] if ;
|
||||
|
||||
TUPLE: server-port addr client client-addr encoding ;
|
||||
TUPLE: server-port < port addr client client-addr encoding ;
|
||||
|
||||
: <server-port> ( handle addr encoding -- server )
|
||||
rot f server-port <port>
|
||||
{ set-server-port-addr set-server-port-encoding set-delegate }
|
||||
server-port construct ;
|
||||
rot server-port <port>
|
||||
swap >>encoding
|
||||
swap >>addr ;
|
||||
|
||||
: check-server-port ( port -- )
|
||||
port-type server-port assert= ;
|
||||
: check-server-port ( port -- port )
|
||||
dup server-port? [ "Not a server port" throw ] unless ; inline
|
||||
|
||||
TUPLE: datagram-port addr packet packet-addr ;
|
||||
TUPLE: datagram-port < port addr packet packet-addr ;
|
||||
|
||||
: <datagram-port> ( handle addr -- datagram )
|
||||
>r f datagram-port <port> r>
|
||||
{ set-delegate set-datagram-port-addr }
|
||||
datagram-port construct ;
|
||||
swap datagram-port <port>
|
||||
swap >>addr ;
|
||||
|
||||
: check-datagram-port ( port -- )
|
||||
port-type datagram-port assert= ;
|
||||
: check-datagram-port ( port -- port )
|
||||
check-closed
|
||||
dup datagram-port? [ "Not a datagram port" throw ] unless ; inline
|
||||
|
||||
: check-datagram-send ( packet addrspec port -- )
|
||||
dup check-datagram-port
|
||||
datagram-port-addr [ class ] bi@ assert=
|
||||
class byte-array assert= ;
|
||||
: check-datagram-send ( packet addrspec port -- packet addrspec port )
|
||||
check-datagram-port
|
||||
2dup addr>> [ class ] bi@ assert=
|
||||
pick class byte-array assert= ;
|
||||
|
|
|
|||
|
|
@ -12,17 +12,17 @@ SYMBOL: servers
|
|||
|
||||
LOG: accepted-connection NOTICE
|
||||
|
||||
: with-client ( client quot -- )
|
||||
: with-client ( client addrspec quot -- )
|
||||
[
|
||||
over client-stream-addr accepted-connection
|
||||
swap accepted-connection
|
||||
with-stream*
|
||||
] curry with-disposal ; inline
|
||||
] 2curry with-disposal ; inline
|
||||
|
||||
\ with-client DEBUG add-error-logging
|
||||
|
||||
: accept-loop ( server quot -- )
|
||||
[
|
||||
>r accept r> [ with-client ] 2curry "Client" spawn drop
|
||||
>r accept r> [ with-client ] 3curry "Client" spawn drop
|
||||
] 2keep accept-loop ; inline
|
||||
|
||||
: server-loop ( addrspec encoding quot -- )
|
||||
|
|
|
|||
|
|
@ -90,7 +90,7 @@ M: inet6 parse-sockaddr
|
|||
{ [ dup AF_INET = ] [ T{ inet4 } ] }
|
||||
{ [ dup AF_INET6 = ] [ T{ inet6 } ] }
|
||||
{ [ dup AF_UNIX = ] [ T{ local } ] }
|
||||
{ [ t ] [ f ] }
|
||||
[ f ]
|
||||
} cond nip ;
|
||||
|
||||
M: f parse-sockaddr nip ;
|
||||
|
|
|
|||
|
|
@ -17,8 +17,6 @@ ARTICLE: "network-connection" "Connection-oriented networking"
|
|||
"Connection-oriented network servers are implemented by first opening a server socket, then waiting for connections:"
|
||||
{ $subsection <server> }
|
||||
{ $subsection accept }
|
||||
"The stream returned by " { $link accept } " holds the address specifier of the remote client:"
|
||||
{ $subsection client-stream-addr }
|
||||
"Server sockets are closed by calling " { $link dispose } "."
|
||||
$nl
|
||||
"Address specifiers have the following interpretation with connection-oriented networking words:"
|
||||
|
|
@ -118,10 +116,8 @@ HELP: <server>
|
|||
{ $errors "Throws an error if the address is already in use, or if it if the system forbids access." } ;
|
||||
|
||||
HELP: accept
|
||||
{ $values { "server" "a handle" } { "client" "a bidirectional stream" } }
|
||||
{ $description "Waits for a connection to a server socket created by " { $link <server> } ", and outputs a bidirectional stream when the connection has been established. The encoding of this stream is the one that was passed to the server constructor."
|
||||
$nl
|
||||
"The returned client stream responds to the " { $link client-stream-addr } " word with the address of the incoming connection." }
|
||||
{ $values { "server" "a handle" } { "client" "a bidirectional stream" } { "addrspec" "an address specifier" } }
|
||||
{ $description "Waits for a connection to a server socket created by " { $link <server> } ", and outputs a bidirectional stream when the connection has been established. The encoding of this stream is the one that was passed to the server constructor." }
|
||||
{ $errors "Throws an error if the server socket is closed or otherwise is unavailable." } ;
|
||||
|
||||
HELP: <datagram>
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2007, 2008 Slava Pestov, Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: generic kernel io.backend namespaces continuations
|
||||
sequences arrays io.encodings io.nonblocking ;
|
||||
sequences arrays io.encodings io.nonblocking accessors ;
|
||||
IN: io.sockets
|
||||
|
||||
TUPLE: local path ;
|
||||
|
|
@ -21,20 +21,14 @@ TUPLE: inet host port ;
|
|||
|
||||
C: <inet> inet
|
||||
|
||||
TUPLE: client-stream addr ;
|
||||
HOOK: ((client)) io-backend ( addrspec -- client-in client-out )
|
||||
|
||||
: <client-stream> ( addrspec delegate -- stream )
|
||||
{ set-client-stream-addr set-delegate }
|
||||
client-stream construct ;
|
||||
|
||||
HOOK: (client) io-backend ( addrspec -- client-in client-out )
|
||||
|
||||
GENERIC: client* ( addrspec -- client-in client-out )
|
||||
M: array client* [ (client) 2array ] attempt-all first2 ;
|
||||
M: object client* (client) ;
|
||||
GENERIC: (client) ( addrspec -- client-in client-out )
|
||||
M: array (client) [ ((client)) 2array ] attempt-all first2 ;
|
||||
M: object (client) ((client)) ;
|
||||
|
||||
: <client> ( addrspec encoding -- stream )
|
||||
>r client* r> <encoder-duplex> ;
|
||||
>r (client) r> <encoder-duplex> ;
|
||||
|
||||
HOOK: (server) io-backend ( addrspec -- handle )
|
||||
|
||||
|
|
@ -43,10 +37,9 @@ HOOK: (server) io-backend ( addrspec -- handle )
|
|||
|
||||
HOOK: (accept) io-backend ( server -- addrspec handle )
|
||||
|
||||
: accept ( server -- client )
|
||||
[ (accept) dup <reader&writer> ] keep
|
||||
server-port-encoding <encoder-duplex>
|
||||
<client-stream> ;
|
||||
: accept ( server -- client addrspec )
|
||||
[ (accept) dup <reader&writer> ] [ encoding>> ] bi
|
||||
<encoder-duplex> swap ;
|
||||
|
||||
HOOK: <datagram> io-backend ( addrspec -- datagram )
|
||||
|
||||
|
|
@ -58,7 +51,8 @@ HOOK: resolve-host io-backend ( host serv passive? -- seq )
|
|||
|
||||
HOOK: host-name io-backend ( -- string )
|
||||
|
||||
M: inet client*
|
||||
dup inet-host swap inet-port f resolve-host
|
||||
dup empty? [ "Host name lookup failed" throw ] when
|
||||
client* ;
|
||||
M: inet (client)
|
||||
[ host>> ] [ port>> ] bi f resolve-host
|
||||
[ empty? [ "Host name lookup failed" throw ] when ]
|
||||
[ (client) ]
|
||||
bi ;
|
||||
|
|
|
|||
|
|
@ -18,13 +18,13 @@ HELP: with-timeout
|
|||
{ $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."
|
||||
"Streams, processes and monitors 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 timeout }
|
||||
{ $subsection set-timeout }
|
||||
"The I/O timeout protocol can be implemented by any class wishing to support timeouts on blocking operations."
|
||||
{ $subsection timed-out }
|
||||
"A combinator to be used in operations which can time out:"
|
||||
{ $subsection with-timeout }
|
||||
{ $see-also "stream-protocol" "io.launcher" } ;
|
||||
{ $see-also "stream-protocol" "io.launcher" "io.monitors" } ;
|
||||
|
||||
ABOUT: "io.timeouts"
|
||||
|
|
|
|||
|
|
@ -14,18 +14,13 @@ TUPLE: io-task port callbacks ;
|
|||
: io-task-fd port>> handle>> ;
|
||||
|
||||
: <io-task> ( port continuation/f class -- task )
|
||||
>r [ 1vector ] [ V{ } clone ] if* io-task construct-boa
|
||||
r> construct-delegate ; inline
|
||||
construct-empty
|
||||
swap [ 1vector ] [ V{ } clone ] if* >>callbacks
|
||||
swap >>port ; inline
|
||||
|
||||
TUPLE: input-task ;
|
||||
TUPLE: input-task < io-task ;
|
||||
|
||||
: <input-task> ( port continuation class -- task )
|
||||
>r input-task <io-task> r> construct-delegate ; inline
|
||||
|
||||
TUPLE: output-task ;
|
||||
|
||||
: <output-task> ( port continuation class -- task )
|
||||
>r output-task <io-task> r> construct-delegate ; inline
|
||||
TUPLE: output-task < io-task ;
|
||||
|
||||
GENERIC: do-io-task ( task -- ? )
|
||||
GENERIC: io-task-container ( mx task -- hashtable )
|
||||
|
|
@ -37,9 +32,10 @@ M: input-task io-task-container drop reads>> ;
|
|||
|
||||
M: output-task io-task-container drop writes>> ;
|
||||
|
||||
: <mx> ( -- mx ) f H{ } clone H{ } clone mx construct-boa ;
|
||||
|
||||
: construct-mx ( class -- obj ) <mx> swap construct-delegate ;
|
||||
: construct-mx ( class -- obj )
|
||||
construct-empty
|
||||
H{ } clone >>reads
|
||||
H{ } clone >>writes ; inline
|
||||
|
||||
GENERIC: register-io-task ( task mx -- )
|
||||
GENERIC: unregister-io-task ( task mx -- )
|
||||
|
|
@ -123,16 +119,18 @@ M: unix cancel-io ( port -- )
|
|||
|
||||
! Readers
|
||||
: reader-eof ( reader -- )
|
||||
dup buffer-empty? [ t >>eof? ] when drop ;
|
||||
dup buffer>> buffer-empty? [ t >>eof ] when drop ;
|
||||
|
||||
: (refill) ( port -- n )
|
||||
[ handle>> ] [ buffer-end ] [ buffer-capacity ] tri read ;
|
||||
[ handle>> ]
|
||||
[ buffer>> buffer-end ]
|
||||
[ buffer>> buffer-capacity ] tri read ;
|
||||
|
||||
: refill ( port -- ? )
|
||||
#! Return f if there is a recoverable error
|
||||
dup buffer-empty? [
|
||||
dup buffer>> buffer-empty? [
|
||||
dup (refill) dup 0 >= [
|
||||
swap n>buffer t
|
||||
swap buffer>> n>buffer t
|
||||
] [
|
||||
drop defer-error
|
||||
] if
|
||||
|
|
@ -140,10 +138,10 @@ M: unix cancel-io ( port -- )
|
|||
drop t
|
||||
] if ;
|
||||
|
||||
TUPLE: read-task ;
|
||||
TUPLE: read-task < input-task ;
|
||||
|
||||
: <read-task> ( port continuation -- task )
|
||||
read-task <input-task> ;
|
||||
read-task <io-task> ;
|
||||
|
||||
M: read-task do-io-task
|
||||
io-task-port dup refill
|
||||
|
|
@ -155,28 +153,33 @@ M: input-port (wait-to-read)
|
|||
|
||||
! Writers
|
||||
: write-step ( port -- ? )
|
||||
dup [ handle>> ] [ buffer@ ] [ buffer-length ] tri write
|
||||
dup 0 >= [ swap buffer-consume f ] [ drop defer-error ] if ;
|
||||
dup
|
||||
[ handle>> ]
|
||||
[ buffer>> buffer@ ]
|
||||
[ buffer>> buffer-length ] tri
|
||||
write dup 0 >=
|
||||
[ swap buffer>> buffer-consume f ]
|
||||
[ drop defer-error ] if ;
|
||||
|
||||
TUPLE: write-task ;
|
||||
TUPLE: write-task < output-task ;
|
||||
|
||||
: <write-task> ( port continuation -- task )
|
||||
write-task <output-task> ;
|
||||
write-task <io-task> ;
|
||||
|
||||
M: write-task do-io-task
|
||||
io-task-port dup [ buffer-empty? ] [ port-error ] bi or
|
||||
[ 0 swap buffer-reset t ] [ write-step ] if ;
|
||||
io-task-port dup [ buffer>> buffer-empty? ] [ port-error ] bi or
|
||||
[ 0 swap buffer>> buffer-reset t ] [ write-step ] if ;
|
||||
|
||||
: add-write-io-task ( port continuation -- )
|
||||
over port-handle mx get-global mx-writes at*
|
||||
over handle>> mx get-global writes>> at*
|
||||
[ io-task-callbacks push drop ]
|
||||
[ drop <write-task> add-io-task ] if ;
|
||||
|
||||
: (wait-to-write) ( port -- )
|
||||
[ add-write-io-task ] with-port-continuation drop ;
|
||||
|
||||
M: port port-flush ( port -- )
|
||||
dup buffer-empty? [ drop ] [ (wait-to-write) ] if ;
|
||||
M: output-port port-flush ( port -- )
|
||||
dup buffer>> buffer-empty? [ drop ] [ (wait-to-write) ] if ;
|
||||
|
||||
M: unix io-multiplex ( ms/f -- )
|
||||
mx get-global wait-for-events ;
|
||||
|
|
@ -187,13 +190,12 @@ M: unix (init-stdio) ( -- )
|
|||
2 <writer> ;
|
||||
|
||||
! mx io-task for embedding an fd-based mx inside another mx
|
||||
TUPLE: mx-port mx ;
|
||||
TUPLE: mx-port < port mx ;
|
||||
|
||||
: <mx-port> ( mx -- port )
|
||||
dup fd>> f mx-port <port>
|
||||
{ set-mx-port-mx set-delegate } mx-port construct ;
|
||||
dup fd>> mx-port <port> swap >>mx ;
|
||||
|
||||
TUPLE: mx-task ;
|
||||
TUPLE: mx-task < io-task ;
|
||||
|
||||
: <mx-task> ( port -- task )
|
||||
f mx-task <io-task> ;
|
||||
|
|
@ -203,3 +205,6 @@ M: mx-task do-io-task
|
|||
|
||||
: multiplexer-error ( n -- )
|
||||
0 < [ err_no ignorable-error? [ (io-error) ] unless ] when ;
|
||||
|
||||
: ?flag ( n mask symbol -- n )
|
||||
pick rot bitand 0 > [ , ] [ drop ] if ;
|
||||
|
|
|
|||
|
|
@ -1,8 +1,18 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: io.unix.bsd
|
||||
USING: io.backend io.unix.backend io.unix.select
|
||||
namespaces system ;
|
||||
USING: namespaces system kernel accessors assocs continuations
|
||||
unix
|
||||
io.backend io.unix.backend io.unix.select io.unix.kqueue io.monitors ;
|
||||
|
||||
M: bsd init-io ( -- )
|
||||
<select-mx> mx set-global ;
|
||||
<select-mx> mx set-global
|
||||
<kqueue-mx> kqueue-mx set-global
|
||||
kqueue-mx get-global <mx-port> <mx-task>
|
||||
dup io-task-fd
|
||||
[ mx get-global reads>> set-at ]
|
||||
[ mx get-global writes>> set-at ] 2bi ;
|
||||
|
||||
M: bsd (monitor) ( path recursive? mailbox -- )
|
||||
swap [ "Recursive kqueue monitors not supported" throw ] when
|
||||
<vnode-monitor> ;
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ bit-arrays sequences assocs unix unix.linux.epoll math
|
|||
namespaces structs ;
|
||||
IN: io.unix.epoll
|
||||
|
||||
TUPLE: epoll-mx events ;
|
||||
TUPLE: epoll-mx < mx events ;
|
||||
|
||||
: max-events ( -- n )
|
||||
#! We read up to 256 events at a time. This is an arbitrary
|
||||
|
|
@ -33,12 +33,10 @@ M: output-task io-task-events drop EPOLLOUT ;
|
|||
epoll_ctl io-error ;
|
||||
|
||||
M: epoll-mx register-io-task ( task mx -- )
|
||||
2dup EPOLL_CTL_ADD do-epoll-ctl
|
||||
delegate register-io-task ;
|
||||
[ EPOLL_CTL_ADD do-epoll-ctl ] [ call-next-method ] 2bi ;
|
||||
|
||||
M: epoll-mx unregister-io-task ( task mx -- )
|
||||
2dup delegate unregister-io-task
|
||||
EPOLL_CTL_DEL do-epoll-ctl ;
|
||||
[ call-next-method ] [ EPOLL_CTL_DEL do-epoll-ctl ] 2bi ;
|
||||
|
||||
: wait-event ( mx timeout -- n )
|
||||
>r { mx-fd epoll-mx-events } get-slots max-events
|
||||
|
|
|
|||
|
|
@ -72,20 +72,20 @@ M: unix delete-directory ( path -- )
|
|||
M: unix copy-file ( from to -- )
|
||||
[ normalize-path ] bi@
|
||||
[ (copy-file) ]
|
||||
[ swap file-info file-info-permissions chmod io-error ]
|
||||
[ swap file-info permissions>> chmod io-error ]
|
||||
2bi ;
|
||||
|
||||
: stat>type ( stat -- type )
|
||||
stat-st_mode {
|
||||
{ [ dup S_ISREG ] [ +regular-file+ ] }
|
||||
{ [ dup S_ISDIR ] [ +directory+ ] }
|
||||
{ [ dup S_ISCHR ] [ +character-device+ ] }
|
||||
{ [ dup S_ISBLK ] [ +block-device+ ] }
|
||||
{ [ dup S_ISFIFO ] [ +fifo+ ] }
|
||||
{ [ dup S_ISLNK ] [ +symbolic-link+ ] }
|
||||
{ [ dup S_ISSOCK ] [ +socket+ ] }
|
||||
{ [ t ] [ +unknown+ ] }
|
||||
} cond nip ;
|
||||
stat-st_mode S_IFMT bitand {
|
||||
{ S_IFREG [ +regular-file+ ] }
|
||||
{ S_IFDIR [ +directory+ ] }
|
||||
{ S_IFCHR [ +character-device+ ] }
|
||||
{ S_IFBLK [ +block-device+ ] }
|
||||
{ S_IFIFO [ +fifo+ ] }
|
||||
{ S_IFLNK [ +symbolic-link+ ] }
|
||||
{ S_IFSOCK [ +socket+ ] }
|
||||
[ drop +unknown+ ]
|
||||
} case ;
|
||||
|
||||
: stat>file-info ( stat -- info )
|
||||
{
|
||||
|
|
|
|||
|
|
@ -1,12 +1,14 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types kernel io.nonblocking io.unix.backend
|
||||
sequences assocs unix unix.time unix.kqueue unix.process math namespaces
|
||||
combinators threads vectors io.launcher
|
||||
io.unix.launcher ;
|
||||
USING: alien.c-types kernel math math.bitfields namespaces
|
||||
locals accessors combinators threads vectors hashtables
|
||||
sequences assocs continuations
|
||||
unix unix.time unix.kqueue unix.process
|
||||
io.nonblocking io.unix.backend io.launcher io.unix.launcher
|
||||
io.monitors ;
|
||||
IN: io.unix.kqueue
|
||||
|
||||
TUPLE: kqueue-mx events ;
|
||||
TUPLE: kqueue-mx < mx events monitors ;
|
||||
|
||||
: max-events ( -- n )
|
||||
#! We read up to 256 events at a time. This is an arbitrary
|
||||
|
|
@ -15,8 +17,9 @@ TUPLE: kqueue-mx events ;
|
|||
|
||||
: <kqueue-mx> ( -- mx )
|
||||
kqueue-mx construct-mx
|
||||
kqueue dup io-error over set-mx-fd
|
||||
max-events "kevent" <c-array> over set-kqueue-mx-events ;
|
||||
H{ } clone >>monitors
|
||||
kqueue dup io-error >>fd
|
||||
max-events "kevent" <c-array> >>events ;
|
||||
|
||||
GENERIC: io-task-filter ( task -- n )
|
||||
|
||||
|
|
@ -24,52 +27,78 @@ M: input-task io-task-filter drop EVFILT_READ ;
|
|||
|
||||
M: output-task io-task-filter drop EVFILT_WRITE ;
|
||||
|
||||
GENERIC: io-task-fflags ( task -- n )
|
||||
|
||||
M: io-task io-task-fflags drop 0 ;
|
||||
|
||||
: make-kevent ( task flags -- event )
|
||||
"kevent" <c-object>
|
||||
tuck set-kevent-flags
|
||||
over io-task-fd over set-kevent-ident
|
||||
over io-task-fflags over set-kevent-fflags
|
||||
swap io-task-filter over set-kevent-filter ;
|
||||
|
||||
: register-kevent ( kevent mx -- )
|
||||
mx-fd swap 1 f 0 f kevent
|
||||
fd>> swap 1 f 0 f kevent
|
||||
0 < [ err_no ESRCH = [ (io-error) ] unless ] when ;
|
||||
|
||||
M: kqueue-mx register-io-task ( task mx -- )
|
||||
over EV_ADD make-kevent over register-kevent
|
||||
delegate register-io-task ;
|
||||
[ >r EV_ADD make-kevent r> register-kevent ]
|
||||
[ call-next-method ]
|
||||
2bi ;
|
||||
|
||||
M: kqueue-mx unregister-io-task ( task mx -- )
|
||||
2dup delegate unregister-io-task
|
||||
swap EV_DELETE make-kevent swap register-kevent ;
|
||||
[ call-next-method ]
|
||||
[ >r EV_DELETE make-kevent r> register-kevent ]
|
||||
2bi ;
|
||||
|
||||
: wait-kevent ( mx timespec -- n )
|
||||
>r dup mx-fd f 0 roll kqueue-mx-events max-events r> kevent
|
||||
>r [ fd>> f 0 ] keep events>> max-events r> kevent
|
||||
dup multiplexer-error ;
|
||||
|
||||
: kevent-read-task ( mx fd -- )
|
||||
over mx-reads at handle-io-task ;
|
||||
:: kevent-read-task ( mx fd kevent -- )
|
||||
mx fd mx reads>> at handle-io-task ;
|
||||
|
||||
: kevent-write-task ( mx fd -- )
|
||||
over mx-reads at handle-io-task ;
|
||||
:: kevent-write-task ( mx fd kevent -- )
|
||||
mx fd mx writes>> at handle-io-task ;
|
||||
|
||||
: kevent-proc-task ( pid -- )
|
||||
dup wait-for-pid swap find-process
|
||||
:: kevent-proc-task ( mx pid kevent -- )
|
||||
pid wait-for-pid
|
||||
pid find-process
|
||||
dup [ swap notify-exit ] [ 2drop ] if ;
|
||||
|
||||
: parse-action ( mask -- changed )
|
||||
[
|
||||
NOTE_DELETE +remove-file+ ?flag
|
||||
NOTE_WRITE +modify-file+ ?flag
|
||||
NOTE_EXTEND +modify-file+ ?flag
|
||||
NOTE_ATTRIB +modify-file+ ?flag
|
||||
NOTE_RENAME +rename-file+ ?flag
|
||||
NOTE_REVOKE +remove-file+ ?flag
|
||||
drop
|
||||
] { } make prune ;
|
||||
|
||||
:: kevent-vnode-task ( mx kevent fd -- )
|
||||
""
|
||||
kevent kevent-fflags parse-action
|
||||
fd mx monitors>> at queue-change ;
|
||||
|
||||
: handle-kevent ( mx kevent -- )
|
||||
dup kevent-ident swap kevent-filter {
|
||||
[ ] [ kevent-ident ] [ kevent-filter ] tri {
|
||||
{ [ dup EVFILT_READ = ] [ drop kevent-read-task ] }
|
||||
{ [ dup EVFILT_WRITE = ] [ drop kevent-write-task ] }
|
||||
{ [ dup EVFILT_PROC = ] [ drop kevent-proc-task drop ] }
|
||||
{ [ dup EVFILT_PROC = ] [ drop kevent-proc-task ] }
|
||||
{ [ dup EVFILT_VNODE = ] [ drop kevent-vnode-task ] }
|
||||
} cond ;
|
||||
|
||||
: handle-kevents ( mx n -- )
|
||||
[ over kqueue-mx-events kevent-nth handle-kevent ] with each ;
|
||||
[ over events>> kevent-nth handle-kevent ] with each ;
|
||||
|
||||
M: kqueue-mx wait-for-events ( ms mx -- )
|
||||
swap dup [ make-timespec ] when
|
||||
dupd wait-kevent handle-kevents ;
|
||||
|
||||
! Procs
|
||||
: make-proc-kevent ( pid -- kevent )
|
||||
"kevent" <c-object>
|
||||
tuck set-kevent-ident
|
||||
|
|
@ -77,5 +106,44 @@ M: kqueue-mx wait-for-events ( ms mx -- )
|
|||
EVFILT_PROC over set-kevent-filter
|
||||
NOTE_EXIT over set-kevent-fflags ;
|
||||
|
||||
: add-pid-task ( pid mx -- )
|
||||
: register-pid-task ( pid mx -- )
|
||||
swap make-proc-kevent swap register-kevent ;
|
||||
|
||||
! VNodes
|
||||
TUPLE: vnode-monitor < monitor fd ;
|
||||
|
||||
: vnode-fflags ( -- n )
|
||||
{
|
||||
NOTE_DELETE
|
||||
NOTE_WRITE
|
||||
NOTE_EXTEND
|
||||
NOTE_ATTRIB
|
||||
NOTE_LINK
|
||||
NOTE_RENAME
|
||||
NOTE_REVOKE
|
||||
} flags ;
|
||||
|
||||
: make-vnode-kevent ( fd flags -- kevent )
|
||||
"kevent" <c-object>
|
||||
tuck set-kevent-flags
|
||||
tuck set-kevent-ident
|
||||
EVFILT_VNODE over set-kevent-filter
|
||||
vnode-fflags over set-kevent-fflags ;
|
||||
|
||||
: register-monitor ( monitor mx -- )
|
||||
>r dup fd>> r>
|
||||
[ >r EV_ADD EV_CLEAR bitor make-vnode-kevent r> register-kevent drop ]
|
||||
[ monitors>> set-at ] 3bi ;
|
||||
|
||||
: unregister-monitor ( monitor mx -- )
|
||||
>r fd>> r>
|
||||
[ monitors>> delete-at ]
|
||||
[ >r EV_DELETE make-vnode-kevent r> register-kevent ] 2bi ;
|
||||
|
||||
: <vnode-monitor> ( path mailbox -- monitor )
|
||||
>r [ O_RDONLY 0 open dup io-error ] keep r>
|
||||
vnode-monitor construct-monitor swap >>fd
|
||||
[ dup kqueue-mx get register-monitor ] [ ] [ fd>> close ] cleanup ;
|
||||
|
||||
M: vnode-monitor dispose
|
||||
[ kqueue-mx get unregister-monitor ] [ fd>> close ] bi ;
|
||||
|
|
|
|||
|
|
@ -55,7 +55,7 @@ USE: unix
|
|||
{ [ pick string? ] [ redirect-file ] }
|
||||
{ [ pick +closed+ eq? ] [ redirect-closed ] }
|
||||
{ [ pick +inherit+ eq? ] [ redirect-closed ] }
|
||||
{ [ t ] [ redirect-stream ] }
|
||||
[ redirect-stream ]
|
||||
} cond ;
|
||||
|
||||
: ?closed dup +closed+ eq? [ drop "/dev/null" ] when ;
|
||||
|
|
|
|||
|
|
@ -1,125 +1,10 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel io.backend io.monitors io.monitors.private
|
||||
io.files io.buffers io.nonblocking io.timeouts io.unix.backend
|
||||
io.unix.select io.unix.launcher unix.linux.inotify assocs
|
||||
namespaces threads continuations init math alien.c-types alien
|
||||
vocabs.loader accessors system ;
|
||||
USING: kernel io.backend io.monitors io.unix.backend
|
||||
io.unix.select io.unix.linux.monitors system namespaces ;
|
||||
IN: io.unix.linux
|
||||
|
||||
TUPLE: linux-monitor ;
|
||||
|
||||
: <linux-monitor> ( wd -- monitor )
|
||||
linux-monitor construct-simple-monitor ;
|
||||
|
||||
TUPLE: inotify watches ;
|
||||
|
||||
: watches ( -- assoc ) inotify get-global watches>> ;
|
||||
|
||||
: wd>monitor ( wd -- monitor ) watches at ;
|
||||
|
||||
: <inotify> ( -- port/f )
|
||||
H{ } clone
|
||||
inotify_init dup 0 < [ 2drop f ] [
|
||||
inotify <buffered-port>
|
||||
{ set-inotify-watches set-delegate } inotify construct
|
||||
] if ;
|
||||
|
||||
: inotify-fd inotify get-global handle>> ;
|
||||
|
||||
: (add-watch) ( path mask -- wd )
|
||||
inotify-fd -rot inotify_add_watch dup io-error ;
|
||||
|
||||
: check-existing ( wd -- )
|
||||
watches key? [
|
||||
"Cannot open multiple monitors for the same file" throw
|
||||
] when ;
|
||||
|
||||
: add-watch ( path mask -- monitor )
|
||||
(add-watch) dup check-existing
|
||||
[ <linux-monitor> dup ] keep watches set-at ;
|
||||
|
||||
: remove-watch ( monitor -- )
|
||||
dup simple-monitor-handle watches delete-at
|
||||
simple-monitor-handle inotify-fd swap inotify_rm_watch io-error ;
|
||||
|
||||
: check-inotify
|
||||
inotify get [
|
||||
"inotify is not supported by this Linux release" throw
|
||||
] unless ;
|
||||
|
||||
M: linux <monitor> ( path recursive? -- monitor )
|
||||
check-inotify
|
||||
drop IN_CHANGE_EVENTS add-watch ;
|
||||
|
||||
M: linux-monitor dispose ( monitor -- )
|
||||
dup delegate dispose remove-watch ;
|
||||
|
||||
: ?flag ( n mask symbol -- n )
|
||||
pick rot bitand 0 > [ , ] [ drop ] if ;
|
||||
|
||||
: parse-action ( mask -- changed )
|
||||
[
|
||||
IN_CREATE +add-file+ ?flag
|
||||
IN_DELETE +remove-file+ ?flag
|
||||
IN_DELETE_SELF +remove-file+ ?flag
|
||||
IN_MODIFY +modify-file+ ?flag
|
||||
IN_ATTRIB +modify-file+ ?flag
|
||||
IN_MOVED_FROM +rename-file+ ?flag
|
||||
IN_MOVED_TO +rename-file+ ?flag
|
||||
IN_MOVE_SELF +rename-file+ ?flag
|
||||
drop
|
||||
] { } make ;
|
||||
|
||||
: parse-file-notify ( buffer -- changed path )
|
||||
{ inotify-event-name inotify-event-mask } get-slots
|
||||
parse-action swap alien>char-string ;
|
||||
|
||||
: events-exhausted? ( i buffer -- ? )
|
||||
fill>> >= ;
|
||||
|
||||
: inotify-event@ ( i buffer -- alien )
|
||||
ptr>> <displaced-alien> ;
|
||||
|
||||
: next-event ( i buffer -- i buffer )
|
||||
2dup inotify-event@
|
||||
inotify-event-len "inotify-event" heap-size +
|
||||
swap >r + r> ;
|
||||
|
||||
: parse-file-notifications ( i buffer -- )
|
||||
2dup events-exhausted? [ 2drop ] [
|
||||
2dup inotify-event@ dup inotify-event-wd wd>monitor [
|
||||
monitor-queue [
|
||||
parse-file-notify changed-file
|
||||
] bind
|
||||
] keep notify-callback
|
||||
next-event parse-file-notifications
|
||||
] if ;
|
||||
|
||||
: read-notifications ( port -- )
|
||||
dup refill drop
|
||||
0 over parse-file-notifications
|
||||
0 swap buffer-reset ;
|
||||
|
||||
TUPLE: inotify-task ;
|
||||
|
||||
: <inotify-task> ( port -- task )
|
||||
f inotify-task <input-task> ;
|
||||
|
||||
: init-inotify ( mx -- )
|
||||
<inotify> dup [
|
||||
dup inotify set-global
|
||||
<inotify-task> swap register-io-task
|
||||
] [
|
||||
2drop
|
||||
] if ;
|
||||
|
||||
M: inotify-task do-io-task ( task -- )
|
||||
io-task-port read-notifications f ;
|
||||
|
||||
M: linux init-io ( -- )
|
||||
<select-mx>
|
||||
[ mx set-global ]
|
||||
[ init-inotify ] bi ;
|
||||
<select-mx> mx set-global ;
|
||||
|
||||
linux set-io-backend
|
||||
|
|
|
|||
|
|
@ -0,0 +1,126 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel io.backend io.monitors io.monitors.recursive
|
||||
io.files io.buffers io.monitors io.nonblocking io.timeouts
|
||||
io.unix.backend io.unix.select unix.linux.inotify assocs
|
||||
namespaces threads continuations init math math.bitfields
|
||||
alien.c-types alien vocabs.loader accessors system hashtables ;
|
||||
IN: io.unix.linux.monitors
|
||||
|
||||
TUPLE: linux-monitor < monitor wd ;
|
||||
|
||||
: <linux-monitor> ( wd path mailbox -- monitor )
|
||||
linux-monitor construct-monitor
|
||||
swap >>wd ;
|
||||
|
||||
SYMBOL: watches
|
||||
|
||||
SYMBOL: inotify
|
||||
|
||||
: wd>monitor ( wd -- monitor ) watches get at ;
|
||||
|
||||
: <inotify> ( -- port/f )
|
||||
inotify_init dup 0 < [ drop f ] [ <reader> ] if ;
|
||||
|
||||
: inotify-fd inotify get handle>> ;
|
||||
|
||||
: check-existing ( wd -- )
|
||||
watches get key? [
|
||||
"Cannot open multiple monitors for the same file" throw
|
||||
] when ;
|
||||
|
||||
: (add-watch) ( path mask -- wd )
|
||||
inotify-fd -rot inotify_add_watch dup io-error dup check-existing ;
|
||||
|
||||
: add-watch ( path mask mailbox -- monitor )
|
||||
>r
|
||||
>r (normalize-path) r>
|
||||
[ (add-watch) ] [ drop ] 2bi r>
|
||||
<linux-monitor> [ ] [ ] [ wd>> ] tri watches get set-at ;
|
||||
|
||||
: check-inotify
|
||||
inotify get [
|
||||
"Calling <monitor> outside with-monitors" throw
|
||||
] unless ;
|
||||
|
||||
M: linux (monitor) ( path recursive? mailbox -- monitor )
|
||||
swap [
|
||||
<recursive-monitor>
|
||||
] [
|
||||
check-inotify
|
||||
IN_CHANGE_EVENTS swap add-watch
|
||||
] if ;
|
||||
|
||||
M: linux-monitor dispose ( monitor -- )
|
||||
[ wd>> watches get delete-at ]
|
||||
[ wd>> inotify-fd swap inotify_rm_watch io-error ] bi ;
|
||||
|
||||
: ignore-flags? ( mask -- ? )
|
||||
{
|
||||
IN_DELETE_SELF
|
||||
IN_MOVE_SELF
|
||||
IN_UNMOUNT
|
||||
IN_Q_OVERFLOW
|
||||
IN_IGNORED
|
||||
} flags bitand 0 > ;
|
||||
|
||||
: parse-action ( mask -- changed )
|
||||
[
|
||||
IN_CREATE +add-file+ ?flag
|
||||
IN_DELETE +remove-file+ ?flag
|
||||
IN_MODIFY +modify-file+ ?flag
|
||||
IN_ATTRIB +modify-file+ ?flag
|
||||
IN_MOVED_FROM +rename-file-old+ ?flag
|
||||
IN_MOVED_TO +rename-file-new+ ?flag
|
||||
drop
|
||||
] { } make prune ;
|
||||
|
||||
: parse-file-notify ( buffer -- path changed )
|
||||
dup inotify-event-mask ignore-flags? [
|
||||
drop f f
|
||||
] [
|
||||
[ inotify-event-name alien>char-string ]
|
||||
[ inotify-event-mask parse-action ] bi
|
||||
] if ;
|
||||
|
||||
: events-exhausted? ( i buffer -- ? )
|
||||
fill>> >= ;
|
||||
|
||||
: inotify-event@ ( i buffer -- alien )
|
||||
ptr>> <displaced-alien> ;
|
||||
|
||||
: next-event ( i buffer -- i buffer )
|
||||
2dup inotify-event@
|
||||
inotify-event-len "inotify-event" heap-size +
|
||||
swap >r + r> ;
|
||||
|
||||
: parse-file-notifications ( i buffer -- )
|
||||
2dup events-exhausted? [ 2drop ] [
|
||||
2dup inotify-event@ dup inotify-event-wd wd>monitor
|
||||
>r parse-file-notify r> queue-change
|
||||
next-event parse-file-notifications
|
||||
] if ;
|
||||
|
||||
: inotify-read-loop ( port -- )
|
||||
dup wait-to-read1
|
||||
0 over buffer>> parse-file-notifications
|
||||
0 over buffer>> buffer-reset
|
||||
inotify-read-loop ;
|
||||
|
||||
: inotify-read-thread ( port -- )
|
||||
[ inotify-read-loop ] curry ignore-errors ;
|
||||
|
||||
M: linux init-monitors
|
||||
H{ } clone watches set
|
||||
<inotify> [
|
||||
[ inotify set ]
|
||||
[
|
||||
[ inotify-read-thread ] curry
|
||||
"Linux monitor thread" spawn drop
|
||||
] bi
|
||||
] [
|
||||
"Linux kernel version is too old" throw
|
||||
] if* ;
|
||||
|
||||
M: linux dispose-monitors
|
||||
inotify get dispose ;
|
||||
|
|
@ -1,23 +1,23 @@
|
|||
USING: io.unix.bsd io.backend io.monitors io.monitors.private
|
||||
continuations kernel core-foundation.fsevents sequences
|
||||
namespaces arrays system ;
|
||||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io.unix.bsd io.backend io.monitors core-foundation.fsevents
|
||||
continuations kernel sequences namespaces arrays system locals
|
||||
accessors ;
|
||||
IN: io.unix.macosx
|
||||
|
||||
macosx set-io-backend
|
||||
|
||||
TUPLE: macosx-monitor ;
|
||||
TUPLE: macosx-monitor < monitor handle ;
|
||||
|
||||
: enqueue-notifications ( triples monitor -- )
|
||||
tuck monitor-queue
|
||||
[ [ first { +modify-file+ } swap changed-file ] each ] bind
|
||||
notify-callback ;
|
||||
[
|
||||
>r first { +modify-file+ } r> queue-change
|
||||
] curry each ;
|
||||
|
||||
M: macosx <monitor>
|
||||
drop
|
||||
f macosx-monitor construct-simple-monitor
|
||||
M:: macosx (monitor) ( path recursive? mailbox -- monitor )
|
||||
path mailbox macosx-monitor construct-monitor
|
||||
dup [ enqueue-notifications ] curry
|
||||
rot 1array 0 0 <event-stream>
|
||||
over set-simple-monitor-handle ;
|
||||
path 1array 0 0 <event-stream> >>handle ;
|
||||
|
||||
M: macosx-monitor dispose
|
||||
dup simple-monitor-handle dispose delegate dispose ;
|
||||
handle>> dispose ;
|
||||
|
||||
macosx set-io-backend
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ bit-arrays sequences assocs unix math namespaces structs
|
|||
accessors ;
|
||||
IN: io.unix.select
|
||||
|
||||
TUPLE: select-mx read-fdset write-fdset ;
|
||||
TUPLE: select-mx < mx read-fdset write-fdset ;
|
||||
|
||||
! Factor's bit-arrays are an array of bytes, OS X expects
|
||||
! FD_SET to be an array of cells, so we have to account for
|
||||
|
|
@ -15,8 +15,8 @@ TUPLE: select-mx read-fdset write-fdset ;
|
|||
|
||||
: <select-mx> ( -- mx )
|
||||
select-mx construct-mx
|
||||
FD_SETSIZE 8 * <bit-array> >>read-fdset
|
||||
FD_SETSIZE 8 * <bit-array> >>write-fdset ;
|
||||
FD_SETSIZE 8 * <bit-array> >>read-fdset
|
||||
FD_SETSIZE 8 * <bit-array> >>write-fdset ;
|
||||
|
||||
: clear-nth ( n seq -- ? )
|
||||
[ nth ] [ f -rot set-nth ] 2bi ;
|
||||
|
|
@ -29,7 +29,6 @@ TUPLE: select-mx read-fdset write-fdset ;
|
|||
[ handle-fd ] 2curry assoc-each ;
|
||||
|
||||
: init-fdset ( tasks fdset -- )
|
||||
! dup clear-bits
|
||||
[ >r drop t swap munge r> set-nth ] curry assoc-each ;
|
||||
|
||||
: read-fdset/tasks
|
||||
|
|
@ -45,9 +44,9 @@ TUPLE: select-mx read-fdset write-fdset ;
|
|||
[ reads>> max-fd ] [ writes>> max-fd ] bi max 1+ ;
|
||||
|
||||
: init-fdsets ( mx -- nfds read write except )
|
||||
[ num-fds ] keep
|
||||
[ read-fdset/tasks tuck init-fdset ] keep
|
||||
write-fdset/tasks tuck init-fdset
|
||||
[ num-fds ]
|
||||
[ read-fdset/tasks tuck init-fdset ]
|
||||
[ write-fdset/tasks tuck init-fdset ] tri
|
||||
f ;
|
||||
|
||||
M: select-mx wait-for-events ( ms mx -- )
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ USING: alien alien.c-types generic io kernel math namespaces
|
|||
io.nonblocking parser threads unix sequences
|
||||
byte-arrays io.sockets io.binary io.unix.backend
|
||||
io.streams.duplex io.sockets.impl math.parser continuations libc
|
||||
combinators io.backend io.files io.files.private system ;
|
||||
combinators io.backend io.files io.files.private system accessors ;
|
||||
IN: io.unix.sockets
|
||||
|
||||
: pending-init-error ( port -- )
|
||||
|
|
@ -30,10 +30,10 @@ M: unix addrinfo-error ( n -- )
|
|||
: init-client-socket ( fd -- )
|
||||
SOL_SOCKET SO_OOBINLINE sockopt ;
|
||||
|
||||
TUPLE: connect-task ;
|
||||
TUPLE: connect-task < output-task ;
|
||||
|
||||
: <connect-task> ( port continuation -- task )
|
||||
connect-task <output-task> ;
|
||||
connect-task <io-task> ;
|
||||
|
||||
M: connect-task do-io-task
|
||||
io-task-port dup port-handle f 0 write
|
||||
|
|
@ -42,7 +42,7 @@ M: connect-task do-io-task
|
|||
: wait-to-connect ( port -- )
|
||||
[ <connect-task> add-io-task ] with-port-continuation drop ;
|
||||
|
||||
M: unix (client) ( addrspec -- client-in client-out )
|
||||
M: unix ((client)) ( addrspec -- client-in client-out )
|
||||
dup make-sockaddr/size >r >r
|
||||
protocol-family SOCK_STREAM socket-fd
|
||||
dup r> r> connect
|
||||
|
|
@ -61,10 +61,10 @@ USE: unix
|
|||
: init-server-socket ( fd -- )
|
||||
SOL_SOCKET SO_REUSEADDR sockopt ;
|
||||
|
||||
TUPLE: accept-task ;
|
||||
TUPLE: accept-task < input-task ;
|
||||
|
||||
: <accept-task> ( port continuation -- task )
|
||||
accept-task <input-task> ;
|
||||
accept-task <io-task> ;
|
||||
|
||||
: accept-sockaddr ( port -- fd sockaddr )
|
||||
dup port-handle swap server-port-addr sockaddr-type
|
||||
|
|
@ -97,11 +97,10 @@ M: unix (server) ( addrspec -- handle )
|
|||
|
||||
M: unix (accept) ( server -- addrspec handle )
|
||||
#! Wait for a client connection.
|
||||
dup check-server-port
|
||||
dup wait-to-accept
|
||||
dup pending-error
|
||||
dup server-port-client-addr
|
||||
swap server-port-client ;
|
||||
check-server-port
|
||||
[ wait-to-accept ]
|
||||
[ pending-error ]
|
||||
[ [ client-addr>> ] [ client>> ] bi ] tri ;
|
||||
|
||||
! Datagram sockets - UDP and Unix domain
|
||||
M: unix <datagram>
|
||||
|
|
@ -128,10 +127,10 @@ packet-size <byte-array> receive-buffer set-global
|
|||
rot head
|
||||
] if ;
|
||||
|
||||
TUPLE: receive-task ;
|
||||
TUPLE: receive-task < input-task ;
|
||||
|
||||
: <receive-task> ( stream continuation -- task )
|
||||
receive-task <input-task> ;
|
||||
receive-task <io-task> ;
|
||||
|
||||
M: receive-task do-io-task
|
||||
io-task-port
|
||||
|
|
@ -148,19 +147,18 @@ M: receive-task do-io-task
|
|||
[ <receive-task> add-io-task ] with-port-continuation drop ;
|
||||
|
||||
M: unix receive ( datagram -- packet addrspec )
|
||||
dup check-datagram-port
|
||||
dup wait-receive
|
||||
dup pending-error
|
||||
dup datagram-port-packet
|
||||
swap datagram-port-packet-addr ;
|
||||
check-datagram-port
|
||||
[ wait-receive ]
|
||||
[ pending-error ]
|
||||
[ [ packet>> ] [ packet-addr>> ] bi ] tri ;
|
||||
|
||||
: do-send ( socket data sockaddr len -- n )
|
||||
>r >r dup length 0 r> r> sendto ;
|
||||
|
||||
TUPLE: send-task packet sockaddr len ;
|
||||
TUPLE: send-task < output-task packet sockaddr len ;
|
||||
|
||||
: <send-task> ( packet sockaddr len stream continuation -- task )
|
||||
send-task <output-task> [
|
||||
send-task <io-task> [
|
||||
{
|
||||
set-send-task-packet
|
||||
set-send-task-sockaddr
|
||||
|
|
@ -180,7 +178,7 @@ M: send-task do-io-task
|
|||
2drop 2drop ;
|
||||
|
||||
M: unix send ( packet addrspec datagram -- )
|
||||
3dup check-datagram-send
|
||||
check-datagram-send
|
||||
[ >r make-sockaddr/size r> wait-send ] keep
|
||||
pending-error ;
|
||||
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ IN: io.unix.tests
|
|||
|
||||
socket-server <local>
|
||||
ascii <server> [
|
||||
accept [
|
||||
accept drop [
|
||||
"Hello world" print flush
|
||||
readln "XYZ" = "FOO" "BAR" ? print flush
|
||||
] with-stream
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@ continuations destructors io io.backend io.nonblocking
|
|||
io.windows libc kernel math namespaces sequences
|
||||
threads classes.tuple.lib windows windows.errors
|
||||
windows.kernel32 strings splitting io.files qualified ascii
|
||||
combinators.lib system ;
|
||||
combinators.lib system accessors ;
|
||||
QUALIFIED: windows.winsock
|
||||
IN: io.windows.nt.backend
|
||||
|
||||
|
|
@ -38,15 +38,15 @@ M: winnt add-completion ( handle -- )
|
|||
zero? [
|
||||
GetLastError {
|
||||
{ [ dup expected-io-error? ] [ 2drop t ] }
|
||||
{ [ dup eof? ] [ drop t swap set-port-eof? f ] }
|
||||
{ [ t ] [ (win32-error-string) throw ] }
|
||||
{ [ dup eof? ] [ drop t >>eof drop f ] }
|
||||
[ (win32-error-string) throw ]
|
||||
} cond
|
||||
] [
|
||||
drop t
|
||||
] if ;
|
||||
|
||||
: get-overlapped-result ( overlapped port -- bytes-transferred )
|
||||
dup port-handle win32-file-handle rot 0 <uint>
|
||||
dup handle>> handle>> rot 0 <uint>
|
||||
[ 0 GetOverlappedResult overlapped-error? drop ] keep *uint ;
|
||||
|
||||
: save-callback ( overlapped port -- )
|
||||
|
|
@ -75,11 +75,11 @@ M: winnt add-completion ( handle -- )
|
|||
] [
|
||||
dup eof? [
|
||||
drop lookup-callback
|
||||
dup io-callback-port t swap set-port-eof?
|
||||
dup port>> t >>eof drop
|
||||
] [
|
||||
(win32-error-string) swap lookup-callback
|
||||
[ io-callback-port set-port-error ] keep
|
||||
] if io-callback-thread resume f
|
||||
[ port>> set-port-error ] keep
|
||||
] if thread>> resume f
|
||||
] if
|
||||
] [
|
||||
lookup-callback
|
||||
|
|
@ -90,7 +90,7 @@ M: winnt add-completion ( handle -- )
|
|||
handle-overlapped [ 0 drain-overlapped ] unless ;
|
||||
|
||||
M: winnt cancel-io
|
||||
port-handle win32-file-handle CancelIo drop ;
|
||||
handle>> handle>> CancelIo drop ;
|
||||
|
||||
M: winnt io-multiplex ( ms -- )
|
||||
drain-overlapped ;
|
||||
|
|
|
|||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue