steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge commit 'origin/master'

db4
Chris Double 2008-04-14 10:41:31 +12:00
parent 688cbfaafa d44c0ffcc9
commit 40924f7b4a
261 changed files with 3506 additions and 2351 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
core/alien/alien-docs.factor
View File

@ -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: << } "." } ;

4
core/alien/compiler/compiler.factor
View File

@ -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 -- )

2
core/alien/syntax/syntax.factor
View File

@ -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 ;

1
core/bit-vectors/summary.txt Normal file
View File

@ -0,0 +1 @@
Growable bit arrays

1
core/bit-vectors/tags.txt Normal file
View File

@ -0,0 +1 @@
collections

1
core/byte-vectors/summary.txt Normal file
View File

@ -0,0 +1 @@
Growable byte arrays

1
core/byte-vectors/tags.txt Normal file
View File

@ -0,0 +1 @@
collections

14
core/classes/algebra/algebra.factor
View File

@ -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 )

2
core/classes/mixin/mixin.factor
View File

@ -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*

10
core/combinators/combinators-docs.factor
View File

@ -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

232
core/combinators/combinators-tests.factor
View File

@ -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

30
core/combinators/combinators.factor
View File

@ -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? [

7
core/command-line/command-line-docs.factor
View File

@ -7,9 +7,10 @@ ARTICLE: "runtime-cli-args" "Command line switches for the VM"
{ { $snippet "-i=" { $emphasis "image" } } { "Specifies the image file to use; see " { $link "images" } } }
{ { $snippet "-datastack=" { $emphasis "n" } } "Data stack size, kilobytes" }
{ { $snippet "-retainstack=" { $emphasis "n" } } "Retain stack size, kilobytes" }
{ { $snippet "-generations=" { $emphasis "n" } } "Number of generations, must be >= 2" }
{ { $snippet "-young=" { $emphasis "n" } } { "Size of " { $snippet { $emphasis "n" } "-1" } " youngest generations, megabytes" } }
{ { $snippet "-aging=" { $emphasis "n" } } "Size of tenured and semi-spaces, megabytes" }
{ { $snippet "-generations=" { $emphasis "n" } } "Number of generations, must equal 1, 2 or 3" }
{ { $snippet "-young=" { $emphasis "n" } } { "Size of youngest generation (0), megabytes" } }
{ { $snippet "-aging=" { $emphasis "n" } } "Size of aging generation (1), megabytes" }
{ { $snippet "-tenured=" { $emphasis "n" } } "Size of oldest generation (2), megabytes" }
{ { $snippet "-codeheap=" { $emphasis "n" } } "Code heap size, megabytes" }
{ { $snippet "-securegc" } "If specified, unused portions of the data heap will be zeroed out after every garbage collection" }
}

2
core/compiler/compiler.factor
View File

@ -20,7 +20,7 @@ IN: compiler
: finish-compile ( word effect dependencies -- )
>r dupd save-effect r>
over compiled-unxref
over crossref? [ compiled-xref ] [ 2drop ] if ;
over compiled-crossref? [ compiled-xref ] [ 2drop ] if ;
: compile-succeeded ( word -- effect dependencies )
[

4
core/compiler/tests/simple.factor
View File

@ -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

4
core/compiler/units/units.factor
View File

@ -66,7 +66,7 @@ GENERIC: definitions-changed ( assoc obj -- )
: compile ( words -- )
recompile-hook get call
dup [ drop crossref? ] assoc-contains?
dup [ drop compiled-crossref? ] assoc-contains?
modify-code-heap ;
SYMBOL: outdated-tuples
@ -82,7 +82,7 @@ SYMBOL: update-tuples-hook
: finish-compilation-unit ( -- )
call-recompile-hook
call-update-tuples-hook
dup [ drop crossref? ] assoc-contains? modify-code-heap
dup [ drop compiled-crossref? ] assoc-contains? modify-code-heap
updated-definitions notify-definition-observers ;
: with-compilation-unit ( quot -- )

6
core/continuations/continuations-docs.factor
View File

@ -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

3
core/cpu/x86/32/32.factor
View File

@ -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 ;

2
core/cpu/x86/assembler/assembler.factor
View File

@ -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

2
core/debugger/debugger.factor
View File

@ -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

2
core/dlists/dlists.factor
View File

@ -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 ? )

2
core/effects/effects.factor
View File

@ -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 )

1
core/float-vectors/summary.txt Normal file
View File

@ -0,0 +1 @@
Growable float arrays

1
core/float-vectors/tags.txt Normal file
View File

@ -0,0 +1 @@
collections

4
core/generator/fixup/fixup.factor
View File

@ -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

2
core/generator/generator.factor
View File

@ -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 -- )

6
core/generator/registers/registers.factor
View File

@ -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 )

2
core/generic/math/math.factor
View File

@ -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 )

2
core/generic/standard/engines/predicate/predicate.factor
View File

@ -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' )

18
core/generic/standard/engines/tuple/tuple.factor
View File

@ -63,14 +63,14 @@ M: trivial-tuple-dispatch-engine engine>quot
] "" make ;
PREDICATE: tuple-dispatch-engine-word < word
"tuple-dispatch-engine" word-prop ;
"tuple-dispatch-generic" word-prop generic? ;
M: tuple-dispatch-engine-word stack-effect
"tuple-dispatch-generic" word-prop
[ extra-values ] [ stack-effect clone ] bi
[ length + ] change-in ;
[ extra-values ] [ stack-effect ] bi
dup [ clone [ length + ] change-in ] [ 2drop f ] if ;
M: tuple-dispatch-engine-word crossref?
M: tuple-dispatch-engine-word compiled-crossref?
drop t ;
: remember-engine ( word -- )
@ -78,12 +78,10 @@ M: tuple-dispatch-engine-word crossref?
: <tuple-dispatch-engine-word> ( engine -- word )
tuple-dispatch-engine-word-name f <word>
{
[ t "tuple-dispatch-engine" set-word-prop ]
[ generic get "tuple-dispatch-generic" set-word-prop ]
[ remember-engine ]
[ ]
} cleave ;
[ generic get "tuple-dispatch-generic" set-word-prop ]
[ remember-engine ]
[ ]
tri ;
: define-tuple-dispatch-engine-word ( engine quot -- word )
>r <tuple-dispatch-engine-word> dup r> define ;

13
core/generic/standard/standard-tests.factor
View File

@ -2,7 +2,8 @@ IN: generic.standard.tests
USING: tools.test math math.functions math.constants
generic.standard strings sequences arrays kernel accessors
words float-arrays byte-arrays bit-arrays parser namespaces
quotations inference vectors growable ;
quotations inference vectors growable hashtables sbufs
prettyprint ;
GENERIC: lo-tag-test
@ -268,3 +269,13 @@ M: growable call-next-hooker call-next-method "growable " prepend ;
[ "vector growable sequence" ] [
V{ } my-var [ call-next-hooker ] with-variable
] unit-test
GENERIC: no-stack-effect-decl
M: hashtable no-stack-effect-decl ;
M: vector no-stack-effect-decl ;
M: sbuf no-stack-effect-decl ;
[ ] [ \ no-stack-effect-decl see ] unit-test
[ ] [ \ no-stack-effect-decl word-def . ] unit-test

10
core/generic/standard/standard.factor
View File

@ -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 ;

4
core/graphs/graphs-docs.factor
View File

@ -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" } ;

1
core/heaps/tags.txt Normal file
View File

@ -0,0 +1 @@
collections

4
core/inference/backend/backend.factor
View File

@ -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 ;

6
core/io/encodings/utf8/utf8.factor
View File

@ -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

34
core/io/files/files-docs.factor
View File

@ -39,11 +39,19 @@ ARTICLE: "symbolic-links" "Symbolic links"
"Not all operating systems support symbolic links."
{ $see-also link-info } ;
ARTICLE: "directories" "Directories"
"Current directory:"
ARTICLE: "current-directory" "Current working directory"
"File system I/O operations use the value of a variable to resolve relative pathnames:"
{ $subsection current-directory }
"This variable can be changed with a pair of words:"
{ $subsection set-current-directory }
{ $subsection with-directory }
"This variable is independent of the operating system notion of ``current working directory''. While all Factor I/O operations use the variable and not the operating system's value, care must be taken when making FFI calls which expect a pathname. The first option is to resolve relative paths:"
{ $subsection (normalize-path) }
"The second is to change the working directory of the current process:"
{ $subsection cd }
{ $subsection cwd } ;
ARTICLE: "directories" "Directories"
"Home directory:"
{ $subsection home }
"Directory listing:"
@ -51,7 +59,8 @@ ARTICLE: "directories" "Directories"
{ $subsection directory* }
"Creating directories:"
{ $subsection make-directory }
{ $subsection make-directories } ;
{ $subsection make-directories }
{ $subsection "current-directory" } ;
ARTICLE: "file-types" "File Types"
"Platform-independent types:"
@ -112,8 +121,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"
@ -243,11 +251,21 @@ HELP: cd
{ cd cwd current-directory set-current-directory with-directory } related-words
HELP: current-directory
{ $description "A variable holding the current directory. Words that use the filesystem do so in relation to this variable. On startup, an init hook sets this word to the directory from which Factor was run." } ;
{ $description "A variable holding the current directory as an absolute path. Words that use the filesystem do so in relation to this variable."
$nl
"This variable should never be set directly; instead, use " { $link set-current-directory } " or " { $link with-directory } ". This preserves the invariant that the value of this variable is an absolute path." } ;
HELP: set-current-directory
{ $values { "path" "a pathname string" } }
{ $description "Changes the " { $link current-directory } " variable."
$nl
"If " { $snippet "path" } " is relative, it is first resolved relative to the current directory. If " { $snippet "path" } " is absolute, it becomes the new current directory." } ;
HELP: with-directory
{ $values { "path" "a pathname string" } { "quot" quotation } }
{ $description "Changes the " { $link current-directory } " variable for the duration of a quotation's execution. Words that use the file-system should call " { $link normalize-path } " in order to obtain a path relative to the current directory." } ;
{ $description "Calls the quotation in a new dynamic scope with the " { $link current-directory } " variable rebound."
$nl
"If " { $snippet "path" } " is relative, it is first resolved relative to the current directory. If " { $snippet "path" } " is absolute, it becomes the new current directory." } ;
HELP: append-path
{ $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } }
@ -301,7 +319,7 @@ HELP: directory*
HELP: resource-path
{ $values { "path" "a pathname string" } { "newpath" "a pathname string" } }
{ $description "Resolve a path relative to the Factor source code location. This first checks if the " { $link resource-path } " variable is set to a path, and if not, uses the parent directory of the current image." } ;
{ $description "Resolve a path relative to the Factor source code location." } ;
HELP: pathname
{ $class-description "Class of pathname presentations. Path name presentations can be created by calling " { $link <pathname> } ". Instances can be passed to " { $link write-object } " to output a clickable pathname." } ;

27
core/io/files/files.factor
View File

@ -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 ;

7
core/io/streams/duplex/duplex-docs.factor
View File

@ -4,8 +4,7 @@ IN: io.streams.duplex
ARTICLE: "io.streams.duplex" "Duplex streams"
"Duplex streams combine an input stream and an output stream into a bidirectional stream."
{ $subsection duplex-stream }
{ $subsection <duplex-stream> }
{ $subsection check-closed } ;
{ $subsection <duplex-stream> } ;
ABOUT: "io.streams.duplex"
@ -16,7 +15,5 @@ HELP: <duplex-stream>
{ $values { "in" "an input stream" } { "out" "an output stream" } { "stream" " a duplex stream" } }
{ $description "Creates a duplex stream. Writing to a duplex stream will write to " { $snippet "out" } ", and reading from a duplex stream will read from " { $snippet "in" } ". Closing a duplex stream closes both the input and output streams." } ;
HELP: check-closed
{ $values { "stream" "a duplex stream" } }
{ $description "Throws a " { $link check-closed } " error if the stream has already been closed." }
HELP: stream-closed-twice
{ $error-description "This error is thrown when performing an I/O operation on a " { $link duplex-stream } " which has been closed with " { $link dispose } "." } ;

56
core/io/streams/duplex/duplex.factor
View File

@ -1,75 +1,77 @@
! Copyright (C) 2005 Slava Pestov.
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel continuations io accessors ;
IN: io.streams.duplex
USING: kernel continuations io ;
! We ensure that the stream can only be closed once, to preserve
! integrity of duplex I/O ports.
TUPLE: duplex-stream in out closed? ;
TUPLE: duplex-stream in out closed ;
: <duplex-stream> ( in out -- stream )
f duplex-stream construct-boa ;
ERROR: stream-closed-twice ;
: check-closed ( stream -- )
duplex-stream-closed? [ stream-closed-twice ] when ;
<PRIVATE
: duplex-stream-in+ ( duplex -- stream )
dup check-closed duplex-stream-in ;
: check-closed ( stream -- stream )
dup closed>> [ stream-closed-twice ] when ; inline
: duplex-stream-out+ ( duplex -- stream )
dup check-closed duplex-stream-out ;
: in ( duplex -- stream ) check-closed in>> ;
: out ( duplex -- stream ) check-closed out>> ;
PRIVATE>
M: duplex-stream stream-flush
duplex-stream-out+ stream-flush ;
out stream-flush ;
M: duplex-stream stream-readln
duplex-stream-in+ stream-readln ;
in stream-readln ;
M: duplex-stream stream-read1
duplex-stream-in+ stream-read1 ;
in stream-read1 ;
M: duplex-stream stream-read-until
duplex-stream-in+ stream-read-until ;
in stream-read-until ;
M: duplex-stream stream-read-partial
duplex-stream-in+ stream-read-partial ;
in stream-read-partial ;
M: duplex-stream stream-read
duplex-stream-in+ stream-read ;
in stream-read ;
M: duplex-stream stream-write1
duplex-stream-out+ stream-write1 ;
out stream-write1 ;
M: duplex-stream stream-write
duplex-stream-out+ stream-write ;
out stream-write ;
M: duplex-stream stream-nl
duplex-stream-out+ stream-nl ;
out stream-nl ;
M: duplex-stream stream-format
duplex-stream-out+ stream-format ;
out stream-format ;
M: duplex-stream make-span-stream
duplex-stream-out+ make-span-stream ;
out make-span-stream ;
M: duplex-stream make-block-stream
duplex-stream-out+ make-block-stream ;
out make-block-stream ;
M: duplex-stream make-cell-stream
duplex-stream-out+ make-cell-stream ;
out make-cell-stream ;
M: duplex-stream stream-write-table
duplex-stream-out+ stream-write-table ;
out stream-write-table ;
M: duplex-stream dispose
#! The output stream is closed first, in case both streams
#! are attached to the same file descriptor, the output
#! buffer needs to be flushed before we close the fd.
dup duplex-stream-closed? [
t over set-duplex-stream-closed?
[ dup duplex-stream-out dispose ]
[ dup duplex-stream-in dispose ] [ ] cleanup
dup closed>> [
t >>closed
[ dup out>> dispose ]
[ dup in>> dispose ] [ ] cleanup
] unless drop ;

6
core/math/intervals/intervals.factor
View File

@ -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 -- ? )

2
core/math/math.factor
View File

@ -62,6 +62,8 @@ M: object zero? drop f ;
: neg ( x -- -x ) 0 swap - ; foldable
: recip ( x -- y ) 1 swap / ; foldable
: ?1+ [ 1+ ] [ 0 ] if* ; inline
: /f ( x y -- z ) >r >float r> >float float/f ; inline
: max ( x y -- z ) [ > ] most ; foldable

10
core/math/parser/parser.factor
View File

@ -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 ;

14
core/optimizer/control/control-tests.factor
View File

@ -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?

2
core/optimizer/control/control.factor
View File

@ -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 ;

8
core/optimizer/inlining/inlining.factor
View File

@ -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 ;

2
core/optimizer/pattern-match/pattern-match.factor
View File

@ -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 -- ? )

2
core/optimizer/specializers/specializers.factor
View File

@ -57,7 +57,7 @@ IN: optimizer.specializers
[ dup "specializer" word-prop ]
[ "specializer" word-prop specialize-quot ]
}
{ [ t ] [ drop ] }
[ drop ]
} cond ;
: specialized-length ( specializer -- n )

12
core/parser/parser-docs.factor
View File

@ -358,6 +358,18 @@ HELP: scan-word
{ $errors "Throws an error if the token does not name a word, and does not parse as a number." }
$parsing-note ;
HELP: invalid-slot-name
{ $values { "name" string } }
{ $description "Throws an " { $link invalid-slot-name } " error." }
{ $error-description "Thrown by " { $link POSTPONE: TUPLE: } " and " { $link POSTPONE: ERROR: } " if a suspect token appears as a slot name." }
{ $notes "The suspect tokens are chosen so that the following code raises this parse error, instead of silently greating a tuple with garbage slots:"
{ $code
"TUPLE: my-mistaken-tuple slot-a slot-b"
""
": some-word ( a b c -- ) ... ;"
}
} ;
HELP: unexpected
{ $values { "want" "a " { $link word } " or " { $link f } } { "got" word } }
{ $description "Throws an " { $link unexpected } " error." }

32
core/parser/parser.factor
View File

@ -184,6 +184,9 @@ M: parse-error summary
M: parse-error compute-restarts
error>> compute-restarts ;
M: parse-error error-help
error>> error-help ;
SYMBOL: use
SYMBOL: in
@ -298,12 +301,35 @@ M: no-word-error summary
] "" make note.
] with each ;
ERROR: invalid-slot-name name ;
M: invalid-slot-name summary
drop
"Invalid slot name" ;
: (parse-tuple-slots) ( -- )
#! This isn't meant to enforce any kind of policy, just
#! to check for mistakes of this form:
#!
#! TUPLE: blahblah foo bing
#!
#! : ...
scan {
{ [ dup not ] [ unexpected-eof ] }
{ [ dup { ":" "(" "<" } member? ] [ invalid-slot-name ] }
{ [ dup ";" = ] [ drop ] }
[ , (parse-tuple-slots) ]
} cond ;
: parse-tuple-slots ( -- seq )
[ (parse-tuple-slots) ] { } make ;
: parse-tuple-definition ( -- class superclass slots )
CREATE-CLASS
scan {
{ ";" [ tuple f ] }
{ "<" [ scan-word ";" parse-tokens ] }
[ >r tuple ";" parse-tokens r> prefix ]
{ "<" [ scan-word parse-tuple-slots ] }
[ >r tuple parse-tuple-slots r> prefix ]
} case 3dup check-slot-shadowing ;
ERROR: staging-violation word ;
@ -324,7 +350,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 )

2
core/prettyprint/prettyprint.factor
View File

@ -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 ;

1
core/sequences/sequences-docs.factor
View File

@ -233,6 +233,7 @@ $nl
{ $subsection "sequences-split" }
{ $subsection "sequences-destructive" }
{ $subsection "sequences-stacks" }
{ $subsection "sequences-sorting" }
"For inner loops:"
{ $subsection "sequences-unsafe" } ;

30
core/strings/strings-tests.factor
View File

@ -1,5 +1,6 @@
USING: continuations kernel math namespaces strings sbufs
tools.test sequences vectors arrays ;
USING: continuations kernel math namespaces strings
strings.private sbufs tools.test sequences vectors arrays memory
prettyprint io.streams.null ;
IN: strings.tests
[ CHAR: b ] [ 1 >bignum "abc" nth ] unit-test
@ -90,3 +91,28 @@ unit-test
"\udeadbe" clone
CHAR: \u123456 over clone set-first
] unit-test
! Regressions
[ ] [
[
4 [
100 [ drop "obdurak" ] map
gc
dup [
1234 0 rot set-string-nth
] each
1000 [
1000 f <array> drop
] times
.
] times
] with-null-stream
] unit-test
[ t ] [
10000 [
drop
300 100 CHAR: \u123456
[ <string> clone resize-string first ] keep =
] all?
] unit-test

2
core/syntax/syntax.factor
View File

@ -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

2
core/system/system-docs.factor
View File

@ -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." } ;

8
core/system/system-tests.factor
View File

@ -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

60
core/threads/threads.factor
View File

@ -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 ;

2
core/words/words-docs.factor
View File

@ -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." } ;

21
core/words/words.factor
View File

@ -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,15 @@ 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: compiled-crossref? ( word -- ? )
M: word compiled-crossref? crossref? ;
GENERIC# (quot-uses) 1 ( obj assoc -- )
@ -98,7 +101,7 @@ SYMBOL: compiled-crossref
compiled-crossref global [ H{ } assoc-like ] change-at
: compiled-xref ( word dependencies -- )
[ drop crossref? ] assoc-subset
[ drop compiled-crossref? ] assoc-subset
2dup "compiled-uses" set-word-prop
compiled-crossref get add-vertex* ;
@ -191,7 +194,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 ;

1
extra/arrays/lib/tags.txt Normal file
View File

@ -0,0 +1 @@
collections

7
extra/bootstrap/random/random.factor
View File

@ -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-system-random
<mersenne-twister> random-generator set-global
] "generator.random" add-init-hook

7
extra/processing/gallery/bubble-chamber/bubble-chamber-docs.factor → extra/bubble-chamber/bubble-chamber-docs.factor
View File

@ -1,7 +1,12 @@
USING: help.syntax help.markup ;
IN: processing.gallery.bubble-chamber
USING: bubble-chamber.particle.muon
bubble-chamber.particle.quark
bubble-chamber.particle.hadron
bubble-chamber.particle.axion ;
IN: bubble-chamber
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

88
extra/bubble-chamber/bubble-chamber.factor Normal file
View File

@ -0,0 +1,88 @@
USING: kernel namespaces sequences random math math.constants math.libm vars
ui
processing
processing.gadget
bubble-chamber.common
bubble-chamber.particle
bubble-chamber.particle.muon
bubble-chamber.particle.quark
bubble-chamber.particle.hadron
bubble-chamber.particle.axion ;
IN: bubble-chamber
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
VARS: particles muons quarks hadrons axions ;
VAR: boom
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: collide-all ( -- )
2 pi * 1random >collision-theta
particles> [ collide ] each ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: collide-one ( -- )
dim 2 / mouse-x - dim 2 / mouse-y - fatan2 >collision-theta
hadrons> random collide
quarks> random collide
muons> random collide ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: mouse-pressed ( -- )
boom on
1 background ! kludge
11 [ drop collide-one ] each ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: key-released ( -- )
key " " =
[
boom on
1 background
collide-all
]
when ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: bubble-chamber ( -- )
1000 1000 size*
[
1 background
no-stroke
1789 [ drop <muon> ] map >muons
1300 [ drop <quark> ] map >quarks
1000 [ drop <hadron> ] map >hadrons
111 [ drop <axion> ] map >axions
muons> quarks> hadrons> axions> 3append append >particles
collide-one
] setup
[
boom>
[ particles> [ move ] each ]
when
] draw
[ mouse-pressed ] button-down
[ key-released ] key-up ;
: go ( -- ) [ bubble-chamber run ] with-ui ;
MAIN: go

12
extra/bubble-chamber/common/common.factor Normal file
View File

@ -0,0 +1,12 @@
USING: kernel math accessors combinators.cleave vars ;
IN: bubble-chamber.common
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
VAR: collision-theta
: dim ( -- dim ) 1000 ;
: center ( -- point ) dim 2 / dup {2} ; foldable

67
extra/bubble-chamber/particle/axion/axion.factor Normal file
View File

@ -0,0 +1,67 @@
USING: kernel sequences random accessors multi-methods
math math.constants math.ranges math.points combinators.cleave
processing bubble-chamber.common bubble-chamber.particle ;
IN: bubble-chamber.particle.axion
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: axion < particle ;
: <axion> ( -- axion ) axion construct-empty initialize-particle ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
METHOD: collide { axion }
center >>pos
2 pi * 1random >>theta
1.0 6.0 2random >>speed
0.998 1.000 2random >>speed-d
0 >>theta-d
0 >>theta-dd
[ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while
drop ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: dy>alpha ( dy -- alpha ) neg 6 * 30 + 255.0 / ;
: axion-white ( dy -- dy ) dup 1 swap dy>alpha {2} stroke ;
: axion-black ( dy -- dy ) dup 0 swap dy>alpha {2} stroke ;
: axion-point- ( particle dy -- particle ) >r dup pos>> r> v-y point ;
: axion-point+ ( particle dy -- particle ) >r dup pos>> r> v+y point ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
METHOD: move { axion }
{ 0.06 0.59 } stroke
dup pos>> point
1 4 [a,b] [ axion-white axion-point- ] each
1 4 [a,b] [ axion-black axion-point+ ] each
dup vel>> move-by
turn
step-theta
step-theta-d
step-speed-mul
[ ] [ speed-d>> 0.9999 * ] bi >>speed-d
1000 random 996 >
[
dup speed>> neg >>speed
dup speed-d>> neg 2 + >>speed-d
100 random 30 > [ collide ] [ drop ] if
]
[ drop ]
if ;

60
extra/bubble-chamber/particle/hadron/hadron.factor Normal file
View File

@ -0,0 +1,60 @@
USING: kernel random math math.constants math.points accessors multi-methods
processing
processing.color
bubble-chamber.common
bubble-chamber.particle ;
IN: bubble-chamber.particle.hadron
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: hadron < particle ;
: <hadron> ( -- hadron ) hadron construct-empty initialize-particle ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
METHOD: collide { hadron }
center >>pos
2 pi * 1random >>theta
0.5 3.5 2random >>speed
0.996 1.001 2random >>speed-d
0 >>theta-d
0 >>theta-dd
[ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while
0 1 0 <rgb> >>myc
drop ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
METHOD: move { hadron }
{ 1 0.11 } stroke
dup pos>> 1 v-y point
{ 0 0.11 } stroke
dup pos>> 1 v+y point
dup vel>> move-by
turn
step-theta
step-theta-d
step-speed-mul
1000 random 997 >
[
1.0 >>speed-d
0.00001 >>theta-dd
100 random 70 > [ dup collide ] when
]
when
out-of-bounds? [ collide ] [ drop ] if ;

53
extra/bubble-chamber/particle/muon/colors/colors.factor Normal file
View File

@ -0,0 +1,53 @@
USING: kernel sequences math math.constants accessors
processing
processing.color ;
IN: bubble-chamber.particle.muon.colors
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: good-colors ( -- seq )
{
T{ rgba f 0.23 0.14 0.17 1 }
T{ rgba f 0.23 0.14 0.15 1 }
T{ rgba f 0.21 0.14 0.15 1 }
T{ rgba f 0.51 0.39 0.33 1 }
T{ rgba f 0.49 0.33 0.20 1 }
T{ rgba f 0.55 0.45 0.32 1 }
T{ rgba f 0.69 0.63 0.51 1 }
T{ rgba f 0.64 0.39 0.18 1 }
T{ rgba f 0.73 0.42 0.20 1 }
T{ rgba f 0.71 0.45 0.29 1 }
T{ rgba f 0.79 0.45 0.22 1 }
T{ rgba f 0.82 0.56 0.34 1 }
T{ rgba f 0.88 0.72 0.49 1 }
T{ rgba f 0.85 0.69 0.40 1 }
T{ rgba f 0.96 0.92 0.75 1 }
T{ rgba f 0.99 0.98 0.87 1 }
T{ rgba f 0.85 0.82 0.69 1 }
T{ rgba f 0.99 0.98 0.87 1 }
T{ rgba f 0.82 0.82 0.79 1 }
T{ rgba f 0.65 0.69 0.67 1 }
T{ rgba f 0.53 0.60 0.55 1 }
T{ rgba f 0.57 0.53 0.68 1 }
T{ rgba f 0.47 0.42 0.56 1 }
} ;
: anti-colors ( -- seq ) good-colors <reversed> ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: color-fraction ( particle -- particle fraction ) dup theta>> pi + 2 pi * / ;
: set-good-color ( particle -- particle )
color-fraction dup 0 1 between?
[ good-colors at-fraction-of >>myc ]
[ drop ]
if ;
: set-anti-color ( particle -- particle )
color-fraction dup 0 1 between?
[ anti-colors at-fraction-of >>mya ]
[ drop ]
if ;

62
extra/bubble-chamber/particle/muon/muon.factor Normal file
View File

@ -0,0 +1,62 @@
USING: kernel arrays sequences random
math
math.ranges
math.functions
math.vectors
multi-methods accessors
combinators.cleave
processing
bubble-chamber.common
bubble-chamber.particle
bubble-chamber.particle.muon.colors ;
IN: bubble-chamber.particle.muon
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: muon < particle ;
: <muon> ( -- muon ) muon construct-empty initialize-particle ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
METHOD: collide { muon }
center >>pos
2 32 [a,b] random >>speed
0.0001 0.001 2random >>speed-d
collision-theta> -0.1 0.1 2random + >>theta
0 >>theta-d
0 >>theta-dd
[ 0.001 theta-dd-small? ] [ -0.1 0.1 random-theta-dd ] [ ] while
set-good-color
set-anti-color
drop ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
METHOD: move { muon }
dup myc>> 0.16 >>alpha stroke
dup pos>> point
dup mya>> 0.16 >>alpha stroke
dup pos>> first2 >r dim swap - r> 2array point
dup
[ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
move-by
step-theta
step-theta-d
step-speed-sub
out-of-bounds? [ collide ] [ drop ] if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

68
extra/bubble-chamber/particle/particle.factor Normal file
View File

@ -0,0 +1,68 @@
USING: kernel sequences combinators
math math.vectors math.functions multi-methods
accessors combinators.cleave processing processing.color
bubble-chamber.common ;
IN: bubble-chamber.particle
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
GENERIC: collide ( particle -- )
GENERIC: move ( particle -- )
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: particle pos vel speed speed-d theta theta-d theta-dd myc mya ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: initialize-particle ( particle -- particle )
0 0 {2} >>pos
0 0 {2} >>vel
0 >>speed
0 >>speed-d
0 >>theta
0 >>theta-d
0 >>theta-dd
0 0 0 1 <rgba> >>myc
0 0 0 1 <rgba> >>mya ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: move-by ( obj delta -- obj ) over pos>> v+ >>pos ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: theta-dd-small? ( par limit -- par ? ) >r dup theta-dd>> abs r> < ;
: random-theta-dd ( par a b -- par ) 2random >>theta-dd ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: turn ( particle -- particle )
dup
[ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
>>vel ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: step-theta ( p -- p ) [ ] [ theta>> ] [ theta-d>> ] tri + >>theta ;
: step-theta-d ( p -- p ) [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d ;
: step-speed-sub ( p -- p ) [ ] [ speed>> ] [ speed-d>> ] tri - >>speed ;
: step-speed-mul ( p -- p ) [ ] [ speed>> ] [ speed-d>> ] tri * >>speed ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: x ( particle -- x ) pos>> first ;
: y ( particle -- x ) pos>> second ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: out-of-bounds? ( particle -- particle ? )
dup
{ [ x dim neg < ] [ x dim 2 * > ] [ y dim neg < ] [ y dim 2 * > ] } cleave
or or or ;

53
extra/bubble-chamber/particle/quark/quark.factor Normal file
View File

@ -0,0 +1,53 @@
USING: kernel arrays sequences random math accessors multi-methods
processing
bubble-chamber.common
bubble-chamber.particle ;
IN: bubble-chamber.particle.quark
TUPLE: quark < particle ;
: <quark> ( -- quark ) quark construct-empty initialize-particle ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
METHOD: collide { quark }
center >>pos
collision-theta> -0.11 0.11 2random + >>theta
0.5 3.0 2random >>speed
0.996 1.001 2random >>speed-d
0 >>theta-d
0 >>theta-dd
[ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while
drop ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
METHOD: move { quark }
dup myc>> 0.13 >>alpha stroke
dup pos>> point
dup pos>> first2 >r dim swap - r> 2array point
[ ] [ vel>> ] bi move-by
turn
step-theta
step-theta-d
step-speed-mul
1000 random 997 >
[
dup speed>> neg >>speed
2 over speed-d>> - >>speed-d
]
when
out-of-bounds? [ collide ] [ drop ] if ;

46
extra/builder/build/build.factor Normal file
View File

@ -0,0 +1,46 @@
USING: io.files io.launcher io.encodings.utf8 prettyprint
builder.util builder.common builder.child builder.release
builder.report builder.email builder.cleanup ;
IN: builder.build
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: create-build-dir ( -- )
datestamp >stamp
build-dir make-directory ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: enter-build-dir ( -- ) build-dir set-current-directory ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: clone-builds-factor ( -- )
{ "git" "clone" builds/factor } to-strings try-process ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: record-id ( -- )
"factor"
[ git-id "../git-id" utf8 [ . ] with-file-writer ]
with-directory ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: build ( -- )
reset-status
create-build-dir
enter-build-dir
clone-builds-factor
record-id
build-child
release
report
email-report
cleanup ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
MAIN: build

250
extra/builder/builder.factor
View File

@ -1,259 +1,21 @@
USING: kernel namespaces sequences splitting system combinators continuations
parser io io.files io.launcher io.sockets prettyprint threads
bootstrap.image benchmark vars bake smtp builder.util accessors
debugger io.encodings.utf8
calendar
tools.test
USING: kernel debugger io.files threads calendar
builder.common
builder.benchmark
builder.release ;
builder.updates
builder.build ;
IN: builder
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: cd ( path -- ) set-current-directory ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: builds/factor ( -- path ) builds "factor" append-path ;
: build-dir ( -- path ) builds stamp> append-path ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: prepare-build-machine ( -- )
builds make-directory
builds
[
{ "git" "clone" "git://factorcode.org/git/factor.git" } try-process
]
with-directory ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: builds-check ( -- ) builds exists? not [ prepare-build-machine ] when ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: git-clone ( -- desc ) { "git" "clone" "../factor" } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: enter-build-dir ( -- )
datestamp >stamp
builds cd
stamp> make-directory
stamp> cd ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: git-id ( -- id )
{ "git" "show" } utf8 <process-stream>
[ readln ] with-stream " " split second ;
: record-git-id ( -- ) git-id "../git-id" utf8 [ . ] with-file-writer ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: gnu-make ( -- string )
os { freebsd openbsd netbsd } member?
[ "gmake" ]
[ "make" ]
if ;
: do-make-clean ( -- ) { gnu-make "clean" } to-strings try-process ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: make-vm ( -- desc )
<process>
{ gnu-make } to-strings >>command
"../compile-log" >>stdout
+stdout+ >>stderr ;
: do-make-vm ( -- )
make-vm [ "vm compile error" print "../compile-log" cat ] run-or-bail ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: copy-image ( -- )
builds/factor my-boot-image-name append-path ".." copy-file-into
builds/factor my-boot-image-name append-path "." copy-file-into ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: bootstrap-cmd ( -- cmd )
{ "./factor" { "-i=" my-boot-image-name } "-no-user-init" } to-strings ;
: bootstrap ( -- desc )
<process>
bootstrap-cmd >>command
+closed+ >>stdin
"../boot-log" >>stdout
+stdout+ >>stderr
60 minutes >>timeout ;
: do-bootstrap ( -- )
bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail ;
: builder-test-cmd ( -- cmd )
{ "./factor" "-run=builder.test" } to-strings ;
: builder-test ( -- desc )
<process>
builder-test-cmd >>command
+closed+ >>stdin
"../test-log" >>stdout
+stdout+ >>stderr
240 minutes >>timeout ;
: do-builder-test ( -- )
builder-test [ "Test error" print "../test-log" 100 cat-n ] run-or-bail ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: build-status
: (build) ( -- )
builds-check
build-status off
enter-build-dir
"report" utf8
[
"Build machine: " write host-name print
"CPU: " write cpu .
"OS: " write os .
"Build directory: " write current-directory get print
git-clone [ "git clone failed" print ] run-or-bail
"factor"
[
record-git-id
do-make-clean
do-make-vm
copy-image
do-bootstrap
do-builder-test
]
with-directory
"test-log" delete-file
"git id: " write "git-id" eval-file print nl
"Boot time: " write "boot-time" eval-file milli-seconds>time print
"Load time: " write "load-time" eval-file milli-seconds>time print
"Test time: " write "test-time" eval-file milli-seconds>time print nl
"Did not pass load-everything: " print "load-everything-vocabs" cat
"Did not pass test-all: " print "test-all-vocabs" cat
"test-failures" cat
"help-lint results:" print "help-lint" cat
"Benchmarks: " print "benchmarks" eval-file benchmarks.
nl
show-benchmark-deltas
"benchmarks" ".." copy-file-into
maybe-release
]
with-file-writer
build-status on ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: builder-from
SYMBOL: builder-recipients
: tag-subject ( str -- str ) { "builder@" host-name* ": " , } bake to-string ;
: subject ( -- str ) build-status get [ "report" ] [ "error" ] if tag-subject ;
: send-builder-email ( -- )
<email>
builder-from get >>from
builder-recipients get >>to
subject >>subject
"./report" file>string >>body
send-email ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: compress-image ( -- ) { "bzip2" my-boot-image-name } to-strings try-process ;
! : build ( -- )
! [ (build) ] try
! builds cd stamp> cd
! [ send-builder-email ] try
! { "rm" "-rf" "factor" } [ ] run-or-bail
! [ compress-image ] try ;
: build ( -- )
[
(build)
build-dir
[
{ "rm" "-rf" "factor" } try-process
compress-image
]
with-directory
]
try
send-builder-email ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
USE: bootstrap.image.download
: git-pull ( -- desc )
{
"git"
"pull"
"--no-summary"
"git://factorcode.org/git/factor.git"
"master"
} ;
: updates-available? ( -- ? )
git-id
git-pull try-process
git-id
= not ;
: new-image-available? ( -- ? )
my-boot-image-name need-new-image?
[ download-my-image t ]
[ f ]
if ;
: build-loop ( -- )
builds-check
[
builds/factor
[
updates-available? new-image-available? or
[ build ]
when
]
with-directory
builds/factor set-current-directory
new-code-available? [ build ] when
]
try
5 minutes sleep
build-loop ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
MAIN: build-loop
MAIN: build-loop

68
extra/builder/child/child.factor Normal file
View File

@ -0,0 +1,68 @@
USING: namespaces debugger io.files io.launcher accessors bootstrap.image
calendar builder.util builder.common ;
IN: builder.child
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: make-clean ( -- ) { gnu-make "clean" } to-strings try-process ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: make-vm ( -- )
<process>
gnu-make >>command
"../compile-log" >>stdout
+stdout+ >>stderr
try-process ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: builds-factor-image ( -- img ) builds/factor my-boot-image-name append-path ;
: copy-image ( -- )
builds-factor-image ".." copy-file-into
builds-factor-image "." copy-file-into ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: boot-cmd ( -- cmd )
{ "./factor" { "-i=" my-boot-image-name } "-no-user-init" } to-strings ;
: boot ( -- )
<process>
boot-cmd >>command
+closed+ >>stdin
"../boot-log" >>stdout
+stdout+ >>stderr
60 minutes >>timeout
try-process ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: test-cmd ( -- cmd ) { "./factor" "-run=builder.test" } ;
: test ( -- )
<process>
test-cmd >>command
+closed+ >>stdin
"../test-log" >>stdout
+stdout+ >>stderr
240 minutes >>timeout
try-process ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: (build-child) ( -- )
make-clean
make-vm status-vm on
copy-image
boot status-boot on
test status-test on
status on ;
: build-child ( -- )
"factor" set-current-directory
[ (build-child) ] try
".." set-current-directory ;

24
extra/builder/cleanup/cleanup.factor Normal file
View File

@ -0,0 +1,24 @@
USING: kernel namespaces io.files io.launcher bootstrap.image
builder.util builder.common ;
IN: builder.cleanup
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: builder-debug
: compress-image ( -- ) { "bzip2" my-boot-image-name } to-strings try-process ;
: delete-child-factor ( -- )
build-dir [ { "rm" "-rf" "factor" } try-process ] with-directory ;
: cleanup ( -- )
builder-debug get f =
[
"test-log" delete-file
delete-child-factor
compress-image
]
when ;

48
extra/builder/common/common.factor
View File

@ -1,5 +1,7 @@
USING: kernel namespaces io.files sequences vars ;
USING: kernel namespaces sequences splitting
io io.files io.launcher io.encodings.utf8 prettyprint
vars builder.util ;
IN: builder.common
@ -16,3 +18,47 @@ SYMBOL: builds-dir
VAR: stamp
: builds/factor ( -- path ) builds "factor" append-path ;
: build-dir ( -- path ) builds stamp> append-path ;
: create-build-dir ( -- )
datestamp >stamp
build-dir make-directory ;
: enter-build-dir ( -- ) build-dir set-current-directory ;
: clone-builds-factor ( -- )
{ "git" "clone" builds/factor } to-strings try-process ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: prepare-build-machine ( -- )
builds make-directory
builds
[ { "git" "clone" "git://factorcode.org/git/factor.git" } try-process ]
with-directory ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: builds-check ( -- ) builds exists? not [ prepare-build-machine ] when ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: status-vm
SYMBOL: status-boot
SYMBOL: status-test
SYMBOL: status-build
SYMBOL: status-release
SYMBOL: status
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: reset-status ( -- )
{ status-vm status-boot status-test status-build status-release status }
[ off ]
each ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: upload-to-factorcode

22
extra/builder/email/email.factor Normal file
View File

@ -0,0 +1,22 @@
USING: kernel namespaces accessors smtp builder.util builder.common ;
IN: builder.email
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: builder-from
SYMBOL: builder-recipients
: subject-status ( -- str ) status get [ "report" ] [ "error" ] if ;
: subject ( -- str ) { "builder@" host-name* ": " subject-status } to-string ;
: email-report ( -- )
<email>
builder-from get >>from
builder-recipients get >>to
subject >>subject
"report" file>string >>body
send-email ;

58
extra/builder/release/archive/archive.factor Normal file
View File

@ -0,0 +1,58 @@
USING: kernel combinators system sequences io.files io.launcher prettyprint
builder.util
builder.common ;
IN: builder.release.archive
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: base-name ( -- string )
{ "factor" [ os unparse ] cpu- stamp> } to-strings "-" join ;
: extension ( -- extension )
{
{ [ os winnt? ] [ ".zip" ] }
{ [ os macosx? ] [ ".dmg" ] }
{ [ os unix? ] [ ".tar.gz" ] }
}
cond ;
: archive-name ( -- string ) base-name extension append ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: windows-archive-cmd ( -- cmd ) { "zip" "-r" archive-name "factor" } ;
: macosx-archive-cmd ( -- cmd )
{ "hdiutil" "create"
"-srcfolder" "factor"
"-fs" "HFS+"
"-volname" "factor"
archive-name } ;
: unix-archive-cmd ( -- cmd ) { "tar" "-cvzf" archive-name "factor" } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: archive-cmd ( -- cmd )
{
{ [ os windows? ] [ windows-archive-cmd ] }
{ [ os macosx? ] [ macosx-archive-cmd ] }
{ [ os unix? ] [ unix-archive-cmd ] }
}
cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: make-archive ( -- ) archive-cmd to-strings try-process ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: releases ( -- path )
builds "releases" append-path
dup exists? not
[ dup make-directory ]
when ;
: save-archive ( -- ) archive-name releases move-file-into ;

40
extra/builder/release/branch/branch.factor Normal file
View File

@ -0,0 +1,40 @@
USING: kernel system namespaces sequences prettyprint io.files io.launcher
bootstrap.image
builder.util
builder.common ;
IN: builder.release.branch
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: branch-name ( -- string ) "clean-" platform append ;
: refspec ( -- string ) "master:" branch-name append ;
: push-to-clean-branch ( -- )
{ "git" "push" "factorcode.org:/git/factor.git" refspec }
to-strings
try-process ;
: upload-clean-image ( -- )
{
"scp"
my-boot-image-name
"factorcode.org:/var/www/factorcode.org/newsite/images/clean"
}
to-strings
try-process ;
: (update-clean-branch) ( -- )
"factor"
[
push-to-clean-branch
upload-clean-image
]
with-directory ;
: update-clean-branch ( -- )
upload-to-factorcode get
[ (update-clean-branch) ]
when ;

153
extra/builder/release/release.factor
View File

@ -1,144 +1,27 @@
USING: kernel system namespaces sequences splitting combinators
io io.files io.launcher prettyprint
bake combinators.cleave builder.common builder.util ;
USING: kernel debugger system namespaces sequences splitting combinators
io io.files io.launcher prettyprint bootstrap.image
bake combinators.cleave
builder.util
builder.common
builder.release.branch
builder.release.tidy
builder.release.archive
builder.release.upload ;
IN: builder.release
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: releases ( -- path )
builds "releases" append-path
dup exists? not
[ dup make-directory ]
when ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: common-files ( -- seq )
{
"boot.x86.32.image"
"boot.x86.64.image"
"boot.macosx-ppc.image"
"boot.linux-ppc.image"
"vm"
"temp"
"logs"
".git"
".gitignore"
"Makefile"
"unmaintained"
"build-support"
} ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: cpu- ( -- cpu ) cpu unparse "." split "-" join ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: base-name ( -- string )
{ "factor" [ os unparse ] cpu- stamp> } to-strings "-" join ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: extension ( -- extension )
{
{ [ os winnt? ] [ ".zip" ] }
{ [ os macosx? ] [ ".dmg" ] }
{ [ os unix? ] [ ".tar.gz" ] }
}
cond ;
: archive-name ( -- string ) base-name extension append ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: windows-archive-cmd ( -- cmd ) { "zip" "-r" archive-name "factor" } ;
: macosx-archive-cmd ( -- cmd )
{ "hdiutil" "create"
"-srcfolder" "factor"
"-fs" "HFS+"
"-volname" "factor"
archive-name } ;
: unix-archive-cmd ( -- cmd ) { "tar" "-cvzf" archive-name "factor" } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: archive-cmd ( -- cmd )
{
{ [ os windows? ] [ windows-archive-cmd ] }
{ [ os macosx? ] [ macosx-archive-cmd ] }
{ [ os unix? ] [ unix-archive-cmd ] }
}
cond ;
: make-archive ( -- ) archive-cmd to-strings try-process ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: remove-common-files ( -- )
{ "rm" "-rf" common-files } to-strings try-process ;
: remove-factor-app ( -- )
os macosx? not [ { "rm" "-rf" "Factor.app" } try-process ] when ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: upload-to-factorcode
: platform ( -- string ) { [ os unparse ] cpu- } to-strings "-" join ;
: remote-location ( -- dest )
"factorcode.org:/var/www/factorcode.org/newsite/downloads"
platform
append-path ;
: upload ( -- )
{ "scp" archive-name remote-location } to-strings
[ "Error uploading binary to factorcode" print ]
run-or-bail ;
: maybe-upload ( -- )
upload-to-factorcode get
[ upload ]
when ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! : release ( -- )
! "factor"
! [
! remove-factor-app
! remove-common-files
! ]
! with-directory
! make-archive
! archive-name releases move-file-into ;
: release ( -- )
"factor"
[
remove-factor-app
remove-common-files
]
with-directory
: (release) ( -- )
update-clean-branch
tidy
make-archive
maybe-upload
archive-name releases move-file-into ;
upload
save-archive
status-release on ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: clean-build? ( -- ? )
{ "load-everything-vocabs" "test-all-vocabs" } [ eval-file empty? ] all? ;
: release? ( -- ? )
{
"./load-everything-vocabs"
"./test-all-vocabs"
}
[ eval-file empty? ]
all? ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: maybe-release ( -- ) release? [ release ] when ;
: release ( -- ) [ clean-build? [ (release) ] when ] try ;

29
extra/builder/release/tidy/tidy.factor Normal file
View File

@ -0,0 +1,29 @@
USING: kernel system io.files io.launcher builder.util ;
IN: builder.release.tidy
: common-files ( -- seq )
{
"boot.x86.32.image"
"boot.x86.64.image"
"boot.macosx-ppc.image"
"boot.linux-ppc.image"
"vm"
"temp"
"logs"
".git"
".gitignore"
"Makefile"
"unmaintained"
"build-support"
} ;
: remove-common-files ( -- )
{ "rm" "-rf" common-files } to-strings try-process ;
: remove-factor-app ( -- )
os macosx? not [ { "rm" "-rf" "Factor.app" } try-process ] when ;
: tidy ( -- )
"factor" [ remove-factor-app remove-common-files ] with-directory ;

24
extra/builder/release/upload/upload.factor Normal file
View File

@ -0,0 +1,24 @@
USING: kernel namespaces io io.files
builder.util
builder.common
builder.release.archive ;
IN: builder.release.upload
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: remote-location ( -- dest )
"factorcode.org:/var/www/factorcode.org/newsite/downloads"
platform
append-path ;
: (upload) ( -- )
{ "scp" archive-name remote-location } to-strings
[ "Error uploading binary to factorcode" print ]
run-or-bail ;
: upload ( -- )
upload-to-factorcode get
[ (upload) ]
when ;

35
extra/builder/report/report.factor Normal file
View File

@ -0,0 +1,35 @@
USING: kernel namespaces debugger system io io.files io.sockets
io.encodings.utf8 prettyprint benchmark
builder.util builder.common ;
IN: builder.report
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: (report) ( -- )
"Build machine: " write host-name print
"CPU: " write cpu .
"OS: " write os .
"Build directory: " write build-dir print
"git id: " write "git-id" eval-file print nl
status-vm get f = [ "compile-log" cat "vm compile error" throw ] when
status-boot get f = [ "boot-log" cat "Boot error" throw ] when
status-test get f = [ "test-log" 100 cat-n "Test error" throw ] when
"Boot time: " write "boot-time" eval-file milli-seconds>time print
"Load time: " write "load-time" eval-file milli-seconds>time print
"Test time: " write "test-time" eval-file milli-seconds>time print nl
"Did not pass load-everything: " print "load-everything-vocabs" cat
"Did not pass test-all: " print "test-all-vocabs" cat
"test-failures" cat
"help-lint results:" print "help-lint" cat
"Benchmarks: " print "benchmarks" eval-file benchmarks. ;
: report ( -- ) "report" utf8 [ [ (report) ] try ] with-file-writer ;

12
extra/builder/test/test.factor
View File

@ -1,16 +1,4 @@
! USING: kernel namespaces sequences assocs continuations
! vocabs vocabs.loader
! io
! io.files
! prettyprint
! tools.vocabs
! tools.test
! io.encodings.utf8
! combinators.cleave
! help.lint
! bootstrap.stage2 benchmark builder.util ;
USING: kernel namespaces assocs
io.files io.encodings.utf8 prettyprint
help.lint

31
extra/builder/updates/updates.factor Normal file
View File

@ -0,0 +1,31 @@
USING: kernel io.launcher bootstrap.image bootstrap.image.download
builder.util builder.common ;
IN: builder.updates
: git-pull-cmd ( -- cmd )
{
"git"
"pull"
"--no-summary"
"git://factorcode.org/git/factor.git"
"master"
} ;
: updates-available? ( -- ? )
git-id
git-pull-cmd try-process
git-id
= not ;
: new-image-available? ( -- ? )
my-boot-image-name need-new-image?
[ download-my-image t ]
[ f ]
if ;
: new-code-available? ( -- ? )
updates-available?
new-image-available?
or ;

41
extra/builder/util/util.factor
View File

@ -2,6 +2,7 @@
USING: kernel words namespaces classes parser continuations
io io.files io.launcher io.sockets
math math.parser
system
combinators sequences splitting quotations arrays strings tools.time
sequences.deep accessors assocs.lib
io.encodings.utf8
@ -24,11 +25,11 @@ DEFER: to-strings
: to-string ( obj -- str )
dup class
{
{ string [ ] }
{ quotation [ call ] }
{ word [ execute ] }
{ fixnum [ number>string ] }
{ array [ to-strings concat ] }
{ \ string [ ] }
{ \ quotation [ call ] }
{ \ word [ execute ] }
{ \ fixnum [ number>string ] }
{ \ array [ to-strings concat ] }
}
case ;
@ -40,21 +41,6 @@ DEFER: to-strings
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! TUPLE: process* arguments stdin stdout stderr timeout ;
! : <process*> process* construct-empty ;
! : >desc ( process* -- desc )
! H{ } clone
! over arguments>> [ +arguments+ swap put-at ] when*
! over stdin>> [ +stdin+ swap put-at ] when*
! over stdout>> [ +stdout+ swap put-at ] when*
! over stderr>> [ +stderr+ swap put-at ] when*
! over timeout>> [ +timeout+ swap put-at ] when*
! nip ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: host-name* ( -- name ) host-name "." split first ;
: datestamp ( -- string )
@ -109,4 +95,17 @@ USE: prettyprint
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: failsafe ( quot -- ) [ drop ] recover ;
: cpu- ( -- cpu ) cpu unparse "." split "-" join ;
: platform ( -- string ) { [ os unparse ] cpu- } to-strings "-" join ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: gnu-make ( -- string )
os { freebsd openbsd netbsd } member? [ "gmake" ] [ "make" ] if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: git-id ( -- id )
{ "git" "show" } utf8 <process-stream> [ readln ] with-stream
" " split second ;

2
extra/bunny/model/model.factor
View File

@ -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
extra/cairo/png/png.factor
View File

@ -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 )

1
extra/calendar/windows/tags.txt Normal file
View File

@ -0,0 +1 @@
windows

11
extra/calendar/windows/windows.factor
View File

@ -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 ;

19
extra/circular/circular.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2005, 2006 Alex Chapman, Daniel Ehrenberg
! See http;//factorcode.org/license.txt for BSD license
USING: kernel sequences math sequences.private strings ;
USING: kernel sequences math sequences.private strings
accessors ;
IN: circular
! a circular sequence wraps another sequence, but begins at an
@ -11,27 +12,27 @@ TUPLE: circular seq start ;
0 circular construct-boa ;
: circular-wrap ( n circular -- n circular )
[ circular-start + ] keep
[ circular-seq length rem ] keep ; inline
[ start>> + ] keep
[ seq>> length rem ] keep ; inline
M: circular length circular-seq length ;
M: circular length seq>> length ;
M: circular virtual@ circular-wrap circular-seq ;
M: circular virtual@ circular-wrap seq>> ;
M: circular nth virtual@ nth ;
M: circular set-nth virtual@ set-nth ;
M: circular virtual-seq seq>> ;
: change-circular-start ( n circular -- )
#! change start to (start + n) mod length
circular-wrap set-circular-start ;
circular-wrap (>>start) ;
: push-circular ( elt circular -- )
[ set-first ] keep 1 swap change-circular-start ;
[ set-first ] [ 1 swap change-circular-start ] bi ;
: <circular-string> ( n -- circular )
0 <string> <circular> ;
M: circular virtual-seq circular-seq ;
INSTANCE: circular virtual-sequence

9
extra/cocoa/application/application.factor
View File

@ -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: ;

2
extra/cocoa/messages/messages.factor
View File

@ -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) ;

4
extra/concurrency/mailboxes/mailboxes-docs.factor
View File

@ -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"

39
extra/concurrency/mailboxes/mailboxes-tests.factor
View File

@ -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

46
extra/concurrency/mailboxes/mailboxes.factor
View File

@ -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 )

5
extra/concurrency/messaging/messaging-docs.factor
View File

@ -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:"

16
extra/concurrency/messaging/messaging-tests.factor
View File

@ -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

4
extra/core-foundation/core-foundation.factor
View File

@ -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 ( ) ;

28
extra/core-foundation/fsevents/fsevents.factor
View File

@ -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,9 @@ SYMBOL: event-stream-callbacks
[
event-stream-callbacks global
[ [ drop expired? not ] assoc-subset ] change-at
1 \ event-stream-counter set-global
[ [ drop expired? not ] assoc-subset H{ } assoc-like ] change-at
] "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 +182,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 +194,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 ;

38
extra/core-foundation/run-loop/run-loop.factor Normal file
View File

@ -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

Some files were not shown because too many files have changed in this diff Show More