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

Merge branch 'master' of git://factorcode.org/git/factor

db4
Daniel Ehrenberg 2008-05-20 16:58:31 -05:00
parent 1ef44694cd 98dc245420
commit c4fb27f538
301 changed files with 5639 additions and 3227 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
core/alien/c-types/c-types-docs.factor
View File

@ -1,7 +1,7 @@
IN: alien.c-types
USING: alien help.syntax help.markup libc kernel.private
byte-arrays math strings hashtables alien.syntax
bit-arrays float-arrays debugger ;
bit-arrays float-arrays debugger destructors ;
HELP: <c-type>
{ $values { "type" hashtable } }
@ -222,6 +222,9 @@ $nl
{ $subsection realloc }
"You must always free pointers returned by any of the above words when the block of memory is no longer in use:"
{ $subsection free }
"Utilities for automatically freeing memory in conjunction with " { $link with-destructors } ":"
{ $subsection &free }
{ $subsection |free }
"You can unsafely copy a range of bytes from one memory location to another:"
{ $subsection memcpy }
"You can copy a range of bytes from memory into a byte array:"

2
core/alien/c-types/c-types.factor
View File

@ -382,4 +382,6 @@ M: long-long-type box-return ( type -- )
"double" define-primitive-type
os winnt? cpu x86.64? and "longlong" "long" ? "ptrdiff_t" typedef
"ulong" "size_t" typedef
] with-compilation-unit

11
core/bootstrap/primitives.factor
View File

@ -5,8 +5,9 @@ hashtables.private io kernel math namespaces parser sequences
strings vectors words quotations assocs layouts classes
classes.builtin classes.tuple classes.tuple.private
kernel.private vocabs vocabs.loader source-files definitions
slots.deprecated classes.union compiler.units
bootstrap.image.private io.files accessors combinators ;
slots.deprecated classes.union classes.intersection
compiler.units bootstrap.image.private io.files accessors
combinators ;
IN: bootstrap.primitives
"Creating primitives and basic runtime structures..." print flush
@ -127,7 +128,7 @@ bootstrapping? on
: register-builtin ( class -- )
[ dup lookup-type-number "type" set-word-prop ]
[ dup "type" word-prop builtins get set-nth ]
[ f f builtin-class define-class ]
[ f f f builtin-class define-class ]
tri ;
: define-builtin-slots ( symbol slotspec -- )
@ -160,7 +161,7 @@ bootstrapping? on
! Catch-all class for providing a default method.
"object" "kernel" create
[ f builtins get [ ] filter union-class define-class ]
[ f f { } intersection-class define-class ]
[ [ drop t ] "predicate" set-word-prop ]
bi
@ -172,7 +173,7 @@ builtins get num-tags get tail define-union-class
! Empty class with no instances
"null" "kernel" create
[ f { } union-class define-class ]
[ f { } f union-class define-class ]
[ [ drop f ] "predicate" set-word-prop ]
bi

2
core/bootstrap/stage2.factor
View File

@ -23,7 +23,7 @@ SYMBOL: bootstrap-time
: load-components ( -- )
"include" "exclude"
[ get-global " " split [ empty? not ] filter ] bi@
[ get-global " " split harvest ] bi@
diff
[ "bootstrap." prepend require ] each ;

1
core/bootstrap/syntax.factor
View File

@ -46,6 +46,7 @@ IN: bootstrap.syntax
"TUPLE:"
"T{"
"UNION:"
"INTERSECTION:"
"USE:"
"USING:"
"V{"

7
core/boxes/boxes-docs.factor
View File

@ -2,7 +2,7 @@ USING: help.markup help.syntax kernel ;
IN: boxes
HELP: box
{ $class-description "A data type holding a single value in the " { $link box-value } " slot. The " { $link box-full? } " slot indicates if the value is set." } ;
{ $class-description "A data type holding a single value in the " { $snippet "value" } " slot. The " { $snippet "occupied" } " slot indicates if the value is set." } ;
HELP: <box>
{ $values { "box" box } }
@ -27,12 +27,11 @@ ARTICLE: "boxes" "Boxes"
{ $subsection box }
"Creating an empty box:"
{ $subsection <box> }
"Testing if a box is full:"
{ $subsection box-full? }
"Storing a value and removing a value from a box:"
{ $subsection >box }
{ $subsection box> }
"Safely removing a value:"
{ $subsection ?box } ;
{ $subsection ?box }
"Testing if a box is full can be done by reading the " { $snippet "occupied" } " slot." ;
ABOUT: "boxes"

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

@ -1,17 +1,17 @@
IN: boxes.tests
USING: boxes namespaces tools.test ;
USING: boxes namespaces tools.test accessors ;
[ ] [ <box> "b" set ] unit-test
[ ] [ 3 "b" get >box ] unit-test
[ t ] [ "b" get box-full? ] unit-test
[ t ] [ "b" get occupied>> ] unit-test
[ 4 "b" >box ] must-fail
[ 3 ] [ "b" get box> ] unit-test
[ f ] [ "b" get box-full? ] unit-test
[ f ] [ "b" get occupied>> ] unit-test
[ "b" get box> ] must-fail
@ -21,4 +21,4 @@ USING: boxes namespaces tools.test ;
[ 12 t ] [ "b" get ?box ] unit-test
[ f ] [ "b" get box-full? ] unit-test
[ f ] [ "b" get occupied>> ] unit-test

20
core/boxes/boxes.factor
View File

@ -1,24 +1,26 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel ;
USING: kernel accessors ;
IN: boxes
TUPLE: box value full? ;
TUPLE: box value occupied ;
: <box> ( -- box ) box new ;
ERROR: box-full box ;
: >box ( value box -- )
dup box-full? [ "Box already has a value" throw ] when
t over set-box-full?
set-box-value ;
dup occupied>>
[ box-full ] [ t >>occupied (>>value) ] if ;
ERROR: box-empty box ;
: box> ( box -- value )
dup box-full? [ "Box empty" throw ] unless
dup box-value f pick set-box-value
f rot set-box-full? ;
dup occupied>>
[ [ f ] change-value f >>occupied drop ] [ box-empty ] if ;
: ?box ( box -- value/f ? )
dup box-full? [ box> t ] [ drop f f ] if ;
dup occupied>> [ box> t ] [ drop f f ] if ;
: if-box? ( box quot -- )
>r ?box r> [ drop ] if ; inline

3
core/byte-arrays/byte-arrays-docs.factor
View File

@ -26,5 +26,6 @@ HELP: <byte-array> ( n -- byte-array )
HELP: >byte-array
{ $values { "seq" "a sequence" } { "byte-array" byte-array } }
{ $description "Outputs a freshly-allocated byte array whose elements have the same boolean values as a given sequence." }
{ $description
"Outputs a freshly-allocated byte array whose elements have the same signed byte values as a given sequence." }
{ $errors "Throws an error if the sequence contains elements other than integers." } ;

5
core/checksums/checksums-docs.factor
View File

@ -49,4 +49,7 @@ $nl
{ $vocab-subsection "MD5 checksum" "checksums.md5" }
{ $vocab-subsection "SHA1 checksum" "checksums.sha1" }
{ $vocab-subsection "SHA2 checksum" "checksums.sha2" }
{ $vocab-subsection "Adler-32 checksum" "checksums.adler-32" } ;
{ $vocab-subsection "Adler-32 checksum" "checksums.adler-32" }
{ $vocab-subsection "OpenSSL checksums" "checksums.openssl" } ;
ABOUT: "checksums"

43
core/classes/algebra/algebra-tests.factor
View File

@ -1,10 +1,16 @@
IN: classes.algebra.tests
USING: alien arrays definitions generic assocs hashtables io
kernel math namespaces parser prettyprint sequences strings
tools.test vectors words quotations classes classes.algebra
classes.private classes.union classes.mixin classes.predicate
vectors definitions source-files compiler.units growable
random inference effects kernel.private sbufs math.order ;
IN: classes.algebra.tests
\ class< must-infer
\ class-and must-infer
\ class-or must-infer
\ flatten-class must-infer
\ flatten-builtin-class must-infer
: class= [ class<= ] [ swap class<= ] 2bi and ;
@ -261,3 +267,38 @@ TUPLE: xg < xb ;
TUPLE: xh < xb ;
[ t ] [ { xa xb xc xd xe xf xg xh } sort-classes dup sort-classes = ] unit-test
INTERSECTION: generic-class generic class ;
[ t ] [ generic-class generic class<= ] unit-test
[ t ] [ generic-class \ class class<= ] unit-test
! Later
[
[ t ] [ \ class generic class-and generic-class class<= ] unit-test
[ t ] [ \ class generic class-and generic-class swap class<= ] unit-test
] drop
[ t ] [ \ word generic-class classes-intersect? ] unit-test
[ f ] [ number generic-class classes-intersect? ] unit-test
[ H{ { word word } } ] [
generic-class flatten-class
] unit-test
INTERSECTION: empty-intersection ;
[ t ] [ object empty-intersection class<= ] unit-test
[ t ] [ empty-intersection object class<= ] unit-test
[ t ] [ \ f class-not empty-intersection class<= ] unit-test
[ f ] [ empty-intersection \ f class-not class<= ] unit-test
[ t ] [ \ number empty-intersection class<= ] unit-test
[ t ] [ empty-intersection class-not null class<= ] unit-test
[ t ] [ null empty-intersection class-not class<= ] unit-test
[ t ] [ \ f class-not \ f class-or empty-intersection class<= ] unit-test
[ t ] [ empty-intersection \ f class-not \ f class-or class<= ] unit-test
[ t ] [ object \ f class-not \ f class-or class<= ] unit-test
[ ] [ object flatten-builtin-class drop ] unit-test

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

@ -37,7 +37,7 @@ TUPLE: anonymous-union members ;
C: <anonymous-union> anonymous-union
TUPLE: anonymous-intersection members ;
TUPLE: anonymous-intersection participants ;
C: <anonymous-intersection> anonymous-intersection
@ -48,57 +48,83 @@ C: <anonymous-complement> anonymous-complement
: superclass<= ( first second -- ? )
>r superclass r> class<= ;
: left-union-class<= ( first second -- ? )
>r members r> [ class<= ] curry all? ;
: right-union-class<= ( first second -- ? )
members [ class<= ] with contains? ;
: left-anonymous-union< ( first second -- ? )
: left-anonymous-union<= ( first second -- ? )
>r members>> r> [ class<= ] curry all? ;
: right-anonymous-union< ( first second -- ? )
: right-anonymous-union<= ( first second -- ? )
members>> [ class<= ] with contains? ;
: left-anonymous-intersection< ( first second -- ? )
>r members>> r> [ class<= ] curry contains? ;
: left-anonymous-intersection<= ( first second -- ? )
>r participants>> r> [ class<= ] curry contains? ;
: right-anonymous-intersection< ( first second -- ? )
members>> [ class<= ] with all? ;
: right-anonymous-intersection<= ( first second -- ? )
participants>> [ class<= ] with all? ;
: anonymous-complement< ( first second -- ? )
: anonymous-complement<= ( first second -- ? )
[ class>> ] bi@ swap class<= ;
: (class<=) ( first second -- -1/0/1 )
: normalize-class ( class -- class' )
{
{ [ 2dup eq? ] [ 2drop t ] }
{ [ dup object eq? ] [ 2drop t ] }
{ [ over null eq? ] [ 2drop t ] }
{ [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement< ] }
{ [ over anonymous-union? ] [ left-anonymous-union< ] }
{ [ over anonymous-intersection? ] [ left-anonymous-intersection< ] }
{ [ over members ] [ left-union-class<= ] }
{ [ dup anonymous-union? ] [ right-anonymous-union< ] }
{ [ dup anonymous-intersection? ] [ right-anonymous-intersection< ] }
{ [ over anonymous-complement? ] [ 2drop f ] }
{ [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }
{ [ dup members ] [ right-union-class<= ] }
{ [ over superclass ] [ superclass<= ] }
[ 2drop f ]
{ [ dup members ] [ members <anonymous-union> ] }
{ [ dup participants ] [ participants <anonymous-intersection> ] }
[ ]
} cond ;
: normalize-complement ( class -- class' )
class>> normalize-class {
{ [ dup anonymous-union? ] [
members>>
[ class-not normalize-class ] map
<anonymous-intersection>
] }
{ [ dup anonymous-intersection? ] [
participants>>
[ class-not normalize-class ] map
<anonymous-union>
] }
} cond ;
: left-anonymous-complement<= ( first second -- ? )
>r normalize-complement r> class<= ;
PREDICATE: nontrivial-anonymous-complement < anonymous-complement
class>> {
[ anonymous-union? ]
[ anonymous-intersection? ]
[ members ]
[ participants ]
} cleave or or or ;
PREDICATE: empty-union < anonymous-union members>> empty? ;
PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;
: (class<=) ( first second -- -1/0/1 )
2dup eq? [ 2drop t ] [
[ normalize-class ] bi@ {
{ [ dup empty-intersection? ] [ 2drop t ] }
{ [ over empty-union? ] [ 2drop t ] }
{ [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement<= ] }
{ [ over anonymous-union? ] [ left-anonymous-union<= ] }
{ [ over anonymous-intersection? ] [ left-anonymous-intersection<= ] }
{ [ over nontrivial-anonymous-complement? ] [ left-anonymous-complement<= ] }
{ [ dup anonymous-union? ] [ right-anonymous-union<= ] }
{ [ dup anonymous-intersection? ] [ right-anonymous-intersection<= ] }
{ [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }
{ [ over superclass ] [ superclass<= ] }
[ 2drop f ]
} cond
] if ;
: anonymous-union-intersect? ( first second -- ? )
members>> [ classes-intersect? ] with contains? ;
: anonymous-intersection-intersect? ( first second -- ? )
members>> [ classes-intersect? ] with all? ;
participants>> [ classes-intersect? ] with all? ;
: anonymous-complement-intersect? ( first second -- ? )
class>> class<= not ;
: union-class-intersect? ( first second -- ? )
members [ classes-intersect? ] with contains? ;
: tuple-class-intersect? ( first second -- ? )
{
{ [ over tuple eq? ] [ 2drop t ] }
@ -115,61 +141,57 @@ C: <anonymous-complement> anonymous-complement
} cond ;
: (classes-intersect?) ( first second -- ? )
{
normalize-class {
{ [ dup anonymous-union? ] [ anonymous-union-intersect? ] }
{ [ dup anonymous-intersection? ] [ anonymous-intersection-intersect? ] }
{ [ dup anonymous-complement? ] [ anonymous-complement-intersect? ] }
{ [ dup tuple-class? ] [ tuple-class-intersect? ] }
{ [ dup builtin-class? ] [ builtin-class-intersect? ] }
{ [ dup superclass ] [ superclass classes-intersect? ] }
{ [ dup members ] [ union-class-intersect? ] }
} cond ;
: left-union-and ( first second -- class )
>r members r> [ class-and ] curry map <anonymous-union> ;
: right-union-and ( first second -- class )
members [ class-and ] with map <anonymous-union> ;
: left-anonymous-union-and ( first second -- class )
>r members>> r> [ class-and ] curry map <anonymous-union> ;
: right-anonymous-union-and ( first second -- class )
: anonymous-union-and ( first second -- class )
members>> [ class-and ] with map <anonymous-union> ;
: left-anonymous-intersection-and ( first second -- class )
>r members>> r> suffix <anonymous-intersection> ;
: right-anonymous-intersection-and ( first second -- class )
members>> swap suffix <anonymous-intersection> ;
: anonymous-intersection-and ( first second -- class )
participants>> swap suffix <anonymous-intersection> ;
: (class-and) ( first second -- class )
{
{ [ 2dup class<= ] [ drop ] }
{ [ 2dup swap class<= ] [ nip ] }
{ [ 2dup classes-intersect? not ] [ 2drop null ] }
{ [ dup members ] [ right-union-and ] }
{ [ dup anonymous-union? ] [ right-anonymous-union-and ] }
{ [ dup anonymous-intersection? ] [ right-anonymous-intersection-and ] }
{ [ over members ] [ left-union-and ] }
{ [ over anonymous-union? ] [ left-anonymous-union-and ] }
{ [ over anonymous-intersection? ] [ left-anonymous-intersection-and ] }
[ 2array <anonymous-intersection> ]
[
[ normalize-class ] bi@ {
{ [ dup anonymous-union? ] [ anonymous-union-and ] }
{ [ dup anonymous-intersection? ] [ anonymous-intersection-and ] }
{ [ over anonymous-union? ] [ swap anonymous-union-and ] }
{ [ over anonymous-intersection? ] [ swap anonymous-intersection-and ] }
[ 2array <anonymous-intersection> ]
} cond
]
} cond ;
: left-anonymous-union-or ( first second -- class )
>r members>> r> suffix <anonymous-union> ;
: right-anonymous-union-or ( first second -- class )
: anonymous-union-or ( first second -- class )
members>> swap suffix <anonymous-union> ;
: ((class-or)) ( first second -- class )
[ normalize-class ] bi@ {
{ [ dup anonymous-union? ] [ anonymous-union-or ] }
{ [ over anonymous-union? ] [ swap anonymous-union-or ] }
[ 2array <anonymous-union> ]
} cond ;
: anonymous-complement-or ( first second -- class )
2dup class>> swap class<= [ 2drop object ] [ ((class-or)) ] if ;
: (class-or) ( first second -- class )
{
{ [ 2dup class<= ] [ nip ] }
{ [ 2dup swap class<= ] [ drop ] }
{ [ dup anonymous-union? ] [ right-anonymous-union-or ] }
{ [ over anonymous-union? ] [ left-anonymous-union-or ] }
[ 2array <anonymous-union> ]
{ [ dup anonymous-complement? ] [ anonymous-complement-or ] }
{ [ over anonymous-complement? ] [ swap anonymous-complement-or ] }
[ ((class-or)) ]
} cond ;
: (class-not) ( class -- complement )
@ -203,11 +225,23 @@ C: <anonymous-complement> anonymous-complement
tuck [ class<= ] with all? [ peek ] [ drop f ] if
] if ;
DEFER: (flatten-class)
DEFER: flatten-builtin-class
: flatten-intersection-class ( class -- )
participants [ flatten-builtin-class ] map
dup empty? [
drop builtins get [ (flatten-class) ] each
] [
unclip [ assoc-intersect ] reduce [ swap set ] assoc-each
] if ;
: (flatten-class) ( class -- )
{
{ [ dup tuple-class? ] [ dup set ] }
{ [ dup builtin-class? ] [ dup set ] }
{ [ dup members ] [ members [ (flatten-class) ] each ] }
{ [ dup participants ] [ flatten-intersection-class ] }
{ [ dup superclass ] [ superclass (flatten-class) ] }
[ drop ]
} cond ;

7
core/classes/classes-docs.factor
View File

@ -40,6 +40,7 @@ $nl
"There are several sorts of classes:"
{ $subsection "builtin-classes" }
{ $subsection "unions" }
{ $subsection "intersections" }
{ $subsection "mixins" }
{ $subsection "predicates" }
{ $subsection "singletons" }
@ -86,7 +87,11 @@ HELP: members
{ $values { "class" class } { "seq" "a sequence of union members, or " { $link f } } }
{ $description "If " { $snippet "class" } " is a union class, outputs a sequence of its member classes, otherwise outputs " { $link f } "." } ;
HELP: participants
{ $values { "class" class } { "seq" "a sequence of intersection participants, or " { $link f } } }
{ $description "If " { $snippet "class" } " is an intersection class, outputs a sequence of its participant classes, otherwise outputs " { $link f } "." } ;
HELP: define-class
{ $values { "word" word } { "members" "a sequence of class words" } { "superclass" class } { "metaclass" class } }
{ $values { "word" word } { "superclass" class } { "members" "a sequence of class words" } { "participants" "a sequence of class words" } { "metaclass" class } }
{ $description "Sets a property indicating this word is a class word, thus making it an instance of " { $link class } ", and registers it with " { $link update-map } "." }
$low-level-note ;

25
core/classes/classes.factor
View File

@ -57,6 +57,10 @@ PREDICATE: predicate < word "predicating" word-prop >boolean ;
#! Output f for non-classes to work with algebra code
dup class? [ "members" word-prop ] [ drop f ] if ;
: participants ( class -- seq )
#! Output f for non-classes to work with algebra code
dup class? [ "participants" word-prop ] [ drop f ] if ;
GENERIC: rank-class ( class -- n )
GENERIC: reset-class ( class -- )
@ -67,7 +71,12 @@ M: word reset-class drop ;
! update-map
: class-uses ( class -- seq )
[ members ] [ superclass ] bi [ suffix ] when* ;
[
[ members % ]
[ participants % ]
[ superclass [ , ] when* ]
tri
] { } make ;
: class-usages ( class -- assoc )
[ update-map get at ] closure ;
@ -78,12 +87,14 @@ M: word reset-class drop ;
: update-map- ( class -- )
dup class-uses update-map get remove-vertex ;
: make-class-props ( superclass members metaclass -- assoc )
: make-class-props ( superclass members participants metaclass -- assoc )
[
[ dup [ bootstrap-word ] when "superclass" set ]
[ [ bootstrap-word ] map "members" set ]
[ "metaclass" set ]
tri*
{
[ dup [ bootstrap-word ] when "superclass" set ]
[ [ bootstrap-word ] map "members" set ]
[ [ bootstrap-word ] map "participants" set ]
[ "metaclass" set ]
} spread
] H{ } make-assoc ;
: (define-class) ( word props -- )
@ -112,7 +123,7 @@ GENERIC: update-methods ( assoc -- )
[ update-methods ]
bi ;
: define-class ( word superclass members metaclass -- )
: define-class ( word superclass members participants metaclass -- )
#! If it was already a class, update methods after.
reset-caches
make-class-props

28
core/classes/intersection/intersection-docs.factor Normal file
View File

@ -0,0 +1,28 @@
USING: generic help.markup help.syntax kernel kernel.private
namespaces sequences words arrays layouts help effects math
layouts classes.private classes compiler.units ;
IN: classes.intersection
ARTICLE: "intersections" "Intersection classes"
"An object is an instance of a intersection class if it is an instance of all of its participants."
{ $subsection POSTPONE: INTERSECTION: }
{ $subsection define-intersection-class }
"Intersection classes can be introspected:"
{ $subsection participants }
"The set of intersection classes is a class:"
{ $subsection intersection-class }
{ $subsection intersection-class? }
"Intersection classes are used to associate a method with objects which are simultaneously instances of multiple different classes, as well as to conveniently define predicates." ;
ABOUT: "intersections"
HELP: define-intersection-class
{ $values { "class" class } { "participants" "a sequence of classes" } }
{ $description "Defines a intersection class with specified participants. This is the run time equivalent of " { $link POSTPONE: INTERSECTION: } "." }
{ $notes "This word must be called from inside " { $link with-compilation-unit } "." }
{ $side-effects "class" } ;
{ intersection-class define-intersection-class POSTPONE: INTERSECTION: } related-words
HELP: intersection-class
{ $class-description "The class of intersection classes." } ;

33
core/classes/intersection/intersection.factor Normal file
View File

@ -0,0 +1,33 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: words sequences kernel assocs combinators classes
namespaces arrays math quotations ;
IN: classes.intersection
PREDICATE: intersection-class < class
"metaclass" word-prop intersection-class eq? ;
: intersection-predicate-quot ( members -- quot )
dup empty? [
drop [ drop t ]
] [
unclip "predicate" word-prop swap [
"predicate" word-prop [ dup ] swap [ not ] 3append
[ drop f ]
] { } map>assoc alist>quot
] if ;
: define-intersection-predicate ( class -- )
dup participants intersection-predicate-quot define-predicate ;
M: intersection-class update-class define-intersection-predicate ;
: define-intersection-class ( class participants -- )
[ f f rot intersection-class define-class ]
[ drop update-classes ]
2bi ;
M: intersection-class reset-class
{ "class" "metaclass" "participants" } reset-props ;
M: intersection-class rank-class drop 2 ;

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

@ -14,7 +14,7 @@ PREDICATE: predicate-class < class
] [ ] make ;
: define-predicate-class ( class superclass definition -- )
[ drop f predicate-class define-class ]
[ drop f f predicate-class define-class ]
[ nip "predicate-definition" set-word-prop ]
[
2drop

7
core/classes/singleton/singleton-tests.factor
View File

@ -10,3 +10,10 @@ GENERIC: zammo ( obj -- str )
[ ] [ SINGLETON: omg ] unit-test
[ t ] [ omg singleton-class? ] unit-test
[ "IN: classes.singleton.tests\nSINGLETON: omg\n" ] [ [ omg see ] with-string-writer ] unit-test
SINGLETON: word-and-singleton
: word-and-singleton 3 ;
[ t ] [ \ word-and-singleton word-and-singleton? ] unit-test
[ 3 ] [ word-and-singleton ] unit-test

4
core/classes/tuple/tuple-tests.factor
View File

@ -541,7 +541,7 @@ TUPLE: another-forget-accessors-test ;
] unit-test
! Missing error check
[ "IN: tuples.test USE: words TUPLE: wrong-superclass < word ;" eval ] must-fail
[ "IN: classes.tuple.tests USE: words TUPLE: wrong-superclass < word ;" eval ] must-fail
TUPLE: subclass-forget-test ;
@ -554,3 +554,5 @@ TUPLE: subclass-forget-test-3 < subclass-forget-test-2 ;
[ f ] [ subclass-forget-test-1 tuple-class? ] unit-test
[ f ] [ subclass-forget-test-2 tuple-class? ] unit-test
[ subclass-forget-test-3 new ] must-fail
[ "IN: classes.tuple.tests TUPLE: subclass-forget-test-4 < subclass-forget-test-2 ;" eval ] must-fail

8
core/classes/tuple/tuple.factor
View File

@ -160,7 +160,7 @@ M: tuple-class update-class
tri ;
: define-new-tuple-class ( class superclass slots -- )
[ drop f tuple-class define-class ]
[ drop f f tuple-class define-class ]
[ nip "slot-names" set-word-prop ]
[ 2drop update-classes ]
3tri ;
@ -226,6 +226,12 @@ M: tuple-class reset-class
} reset-props
] bi ;
: reset-tuple-class ( class -- )
[ [ reset-class ] [ update-map- ] bi ] each-subclass ;
M: tuple-class forget*
[ reset-tuple-class ] [ call-next-method ] bi ;
M: tuple-class rank-class drop 0 ;
M: tuple clone

4
core/classes/union/union-docs.factor
View File

@ -4,7 +4,7 @@ layouts classes.private classes compiler.units ;
IN: classes.union
ARTICLE: "unions" "Union classes"
"An object is an instance of a union class if it is an instance of one of its members. Union classes are used to associate the same method with several different classes, as well as to conveniently define predicates."
"An object is an instance of a union class if it is an instance of one of its members."
{ $subsection POSTPONE: UNION: }
{ $subsection define-union-class }
"Union classes can be introspected:"
@ -12,7 +12,7 @@ ARTICLE: "unions" "Union classes"
"The set of union classes is a class:"
{ $subsection union-class }
{ $subsection union-class? }
"Unions are used to define behavior shared between a fixed set of classes."
"Unions are used to define behavior shared between a fixed set of classes, as well as to conveniently define predicates."
{ $see-also "mixins" "tuple-subclassing" } ;
ABOUT: "unions"

3
core/classes/union/union.factor
View File

@ -7,7 +7,6 @@ IN: classes.union
PREDICATE: union-class < class
"metaclass" word-prop union-class eq? ;
! Union classes for dispatch on multiple classes.
: union-predicate-quot ( members -- quot )
dup empty? [
drop [ drop f ]
@ -24,7 +23,7 @@ PREDICATE: union-class < class
M: union-class update-class define-union-predicate ;
: define-union-class ( class members -- )
[ f swap union-class define-class ]
[ f swap f union-class define-class ]
[ drop update-classes ]
2bi ;

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

@ -1,6 +1,6 @@
USING: help.markup help.syntax kernel kernel.private
continuations.private parser vectors arrays namespaces
assocs words quotations io ;
assocs words quotations ;
IN: continuations
ARTICLE: "errors-restartable" "Restartable errors"
@ -28,13 +28,7 @@ $nl
{ $heading "Anti-pattern #3: Dropping and rethrowing" }
"Do not use " { $link recover } " to handle an error by dropping it and throwing a new error. By losing the original error message, you signal to the user that something failed without leaving any indication of what actually went wrong. Either wrap the error in a new error containing additional information, or rethrow the original error. A more subtle form of this is using " { $link throw } " instead of " { $link rethrow } ". The " { $link throw } " word should only be used when throwing new errors, and never when rethrowing errors that have been caught."
{ $heading "Anti-pattern #4: Logging and rethrowing" }
"If you are going to rethrow an error, do not log a message. If you do so, the user will see two log messages for the same error, which will clutter logs without adding any useful information."
{ $heading "Anti-pattern #5: Leaking external resources" }
"Words which create objects corresponding to external resources should always be used with " { $link with-disposal } ". The following code is wrong:"
{ $code
"<external-resource> ... do stuff ... dispose"
}
"The reason being that if " { $snippet "do stuff" } " throws an error, the resource will not be disposed of. The most important case where this can occur is with I/O streams, and the correct solution is to always use " { $link with-input-stream } " and " { $link with-output-stream } "; see " { $link "stdio" } " for details." ;
"If you are going to rethrow an error, do not log a message. If you do so, the user will see two log messages for the same error, which will clutter logs without adding any useful information." ;
ARTICLE: "errors" "Error handling"
"Support for handling exceptional situations such as bad user input, implementation bugs, and input/output errors is provided by a set of words built using continuations."
@ -88,19 +82,6 @@ $nl
ABOUT: "continuations"
HELP: dispose
{ $values { "object" "a disposable object" } }
{ $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
{ $values { "object" "a disposable object" } { "quot" "a quotation with stack effect " { $snippet "( object -- )" } } }
{ $description "Calls the quotation, disposing the object with " { $link dispose } " after the quotation returns or if it throws an error." } ;
HELP: catchstack*
{ $values { "catchstack" "a vector of continuations" } }
{ $description "Outputs the current catchstack." } ;

19
core/continuations/continuations-tests.factor
View File

@ -101,21 +101,6 @@ SYMBOL: error-counter
[ 1 ] [ error-counter get ] unit-test
] with-scope
TUPLE: dispose-error ;
M: dispose-error dispose 3 throw ;
TUPLE: dispose-dummy disposed? ;
M: dispose-dummy dispose t >>disposed? drop ;
T{ dispose-error } "a" set
T{ dispose-dummy } "b" set
[ f ] [ "b" get disposed?>> ] unit-test
[ { "a" "b" } [ get ] map dispose-each ] [ 3 = ] must-fail-with
[ t ] [ "b" get disposed?>> ] unit-test
[ ] [ [ return ] with-return ] unit-test
[ { } [ ] attempt-all ] [ attempt-all-error? ] must-fail-with

22
core/continuations/continuations.factor
View File

@ -139,20 +139,16 @@ SYMBOL: thread-error-hook
over >r compose [ dip rethrow ] curry
recover r> call ; inline
ERROR: attempt-all-error ;
: attempt-all ( seq quot -- obj )
[
[ [ , f ] compose [ , drop t ] recover ] curry all?
] { } make peek swap [ rethrow ] when ; inline
GENERIC: dispose ( object -- )
: dispose-each ( seq -- )
[
[ [ dispose ] curry [ , ] recover ] each
] { } make dup empty? [ drop ] [ peek rethrow ] if ;
: with-disposal ( object quot -- )
over [ dispose ] curry [ ] cleanup ; inline
over empty? [
attempt-all-error
] [
[
[ [ , f ] compose [ , drop t ] recover ] curry all?
] { } make peek swap [ rethrow ] when
] if ; inline
TUPLE: condition error restarts continuation ;

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

@ -184,7 +184,7 @@ stack-params "__stack_value" c-type set-c-type-reg-class >>
: split-struct ( pairs -- seq )
[
[ 8 mod zero? [ t , ] when , ] assoc-each
] { } make { t } split [ empty? not ] filter ;
] { } make { t } split harvest ;
: flatten-large-struct ( type -- )
heap-size cell align

6
core/debugger/debugger.factor
View File

@ -7,7 +7,7 @@ splitting math.parser classes.tuple continuations
continuations.private combinators generic.math
classes.builtin classes compiler.units generic.standard vocabs
threads threads.private init kernel.private libc io.encodings
mirrors accessors math.order ;
mirrors accessors math.order destructors ;
IN: debugger
GENERIC: error. ( error -- )
@ -298,6 +298,10 @@ M: immutable-slot summary drop "Slot is immutable" ;
M: bad-create summary drop "Bad parameters to create" ;
M: attempt-all-error summary drop "Nothing to attempt" ;
M: already-disposed summary drop "Attempting to operate on disposed object" ;
<PRIVATE
: init-debugger ( -- )

0
extra/destructors/authors.txt → core/destructors/authors.txt
View File

71
core/destructors/destructors-docs.factor Executable file
View File

@ -0,0 +1,71 @@
USING: help.markup help.syntax libc kernel continuations io ;
IN: destructors
HELP: dispose
{ $values { "disposable" "a disposable object" } }
{ $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. To help implement this pattern, add a " { $snippet "disposed" } " slot to your object and implement the " { $link dispose* } " method instead." }
{ $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."
$nl
"The default implementation assumes the object has a " { $snippet "disposable" } " slot. If the slot is set to " { $link f } ", it calls " { $link dispose* } " and sets the slot to " { $link f } "." } ;
HELP: dispose*
{ $values { "disposable" "a disposable object" } }
{ $contract "Releases operating system resources associated with a disposable object. Disposable objects include streams, memory mapped files, and so on." }
{ $notes
"This word should not be called directly. It can be implemented on objects with a " { $snippet "disposable" } " slot to ensure that the object is only disposed once."
} ;
HELP: with-disposal
{ $values { "object" "a disposable object" } { "quot" "a quotation with stack effect " { $snippet "( object -- )" } } }
{ $description "Calls the quotation, disposing the object with " { $link dispose } " after the quotation returns or if it throws an error." } ;
HELP: with-destructors
{ $values { "quot" "a quotation" } }
{ $description "Calls a quotation within a new dynamic scope. This quotation may register destructors, on any object, by wrapping the object in a destructor and implementing " { $link dispose } " on that object type. After the quotation finishes, if an error was thrown, all destructors are called and the error is then rethrown. However, if the quotation was successful, only those destructors created with an 'always cleanup' flag will be destroyed." }
{ $notes
"Destructors generalize " { $link with-disposal } ". The following two lines are equivalent, except that the second line establishes a new dynamic scope:"
{ $code
"[ X ] with-disposal"
"[ &dispose X ] with-destructors"
}
}
{ $examples
{ $code "[ 10 malloc &free ] with-destructors" }
} ;
HELP: &dispose
{ $values { "disposable" "a disposable object" } }
{ $description "Marks the object for unconditional disposal at the end of the current " { $link with-destructors } " scope." } ;
HELP: |dispose
{ $values { "disposable" "a disposable object" } }
{ $description "Marks the object for disposal in the event of an error at the end of the current " { $link with-destructors } " scope." } ;
ARTICLE: "destructors-anti-patterns" "Resource disposal anti-patterns"
"Words which create objects corresponding to external resources should always be used with " { $link with-disposal } ". The following code is wrong:"
{ $code
"<external-resource> ... do stuff ... dispose"
}
"The reason being that if " { $snippet "do stuff" } " throws an error, the resource will not be disposed of. The most important case where this can occur is with I/O streams, and the correct solution is to always use " { $link with-input-stream } " and " { $link with-output-stream } "; see " { $link "stdio" } " for details." ;
ARTICLE: "destructors" "Deterministic resource disposal"
"Operating system resources such as streams, memory mapped files, and so on are not managed by Factor's garbage collector and must be released when you are done with them. Failing to release a resource can lead to reduced performance and instability."
$nl
"Disposable object protocol:"
{ $subsection dispose }
{ $subsection dispose* }
"Utility word for scoped disposal:"
{ $subsection with-disposal }
"Utility word for disposing multiple objects:"
{ $subsection dispose-each }
"Utility words for more complex disposal patterns:"
{ $subsection with-destructors }
{ $subsection &dispose }
{ $subsection |dispose }
{ $subsection "destructors-anti-patterns" } ;
ABOUT: "destructors"

24
extra/destructors/destructors-tests.factor → core/destructors/destructors-tests.factor
View File

@ -1,6 +1,24 @@
USING: destructors kernel tools.test continuations ;
USING: destructors kernel tools.test continuations accessors
namespaces sequences ;
IN: destructors.tests
TUPLE: dispose-error ;
M: dispose-error dispose 3 throw ;
TUPLE: dispose-dummy disposed? ;
M: dispose-dummy dispose t >>disposed? drop ;
T{ dispose-error } "a" set
T{ dispose-dummy } "b" set
[ f ] [ "b" get disposed?>> ] unit-test
[ { "a" "b" } [ get ] map dispose-each ] [ 3 = ] must-fail-with
[ t ] [ "b" get disposed?>> ] unit-test
TUPLE: dummy-obj destroyed? ;
: <dummy-obj> dummy-obj new ;
@ -13,10 +31,10 @@ M: dummy-destructor dispose ( obj -- )
dummy-destructor-obj t swap set-dummy-obj-destroyed? ;
: destroy-always
<dummy-destructor> add-always-destructor ;
<dummy-destructor> &dispose drop ;
: destroy-later
<dummy-destructor> add-error-destructor ;
<dummy-destructor> |dispose drop ;
[ t ] [
[

56
core/destructors/destructors.factor Executable file
View File

@ -0,0 +1,56 @@
! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors continuations kernel namespaces
sequences vectors ;
IN: destructors
TUPLE: disposable disposed ;
GENERIC: dispose* ( disposable -- )
ERROR: already-disposed disposable ;
: check-disposed ( disposable -- )
dup disposed>> [ already-disposed ] [ drop ] if ; inline
GENERIC: dispose ( disposable -- )
M: object dispose
dup disposed>> [ drop ] [ t >>disposed dispose* ] if ;
: dispose-each ( seq -- )
[
[ [ dispose ] curry [ , ] recover ] each
] { } make dup empty? [ drop ] [ peek rethrow ] if ;
: with-disposal ( object quot -- )
over [ dispose ] curry [ ] cleanup ; inline
<PRIVATE
SYMBOL: always-destructors
SYMBOL: error-destructors
: do-always-destructors ( -- )
always-destructors get <reversed> dispose-each ;
: do-error-destructors ( -- )
error-destructors get <reversed> dispose-each ;
PRIVATE>
: &dispose ( disposable -- disposable )
dup always-destructors get push ; inline
: |dispose ( disposable -- disposable )
dup error-destructors get push ; inline
: with-destructors ( quot -- )
[
V{ } clone always-destructors set
V{ } clone error-destructors set
[ do-always-destructors ]
[ do-error-destructors ]
cleanup
] with-scope ; inline

0
extra/destructors/summary.txt → core/destructors/summary.txt
View File

25
core/generic/generic.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: words kernel sequences namespaces assocs hashtables
definitions kernel.private classes classes.private
classes.algebra quotations arrays vocabs effects ;
classes.algebra quotations arrays vocabs effects combinators ;
IN: generic
! Method combination protocol
@ -123,12 +123,13 @@ M: method-body definer
M: method-body forget*
dup "forgotten" word-prop [ drop ] [
[
[ "method-class" word-prop ]
[ "method-generic" word-prop ] bi
dup generic? [
[ delete-at* ] with-methods
[ call-next-method ] [ drop ] if
] [ 2drop ] if
[ ]
[ "method-class" word-prop ]
[ "method-generic" word-prop ] tri
3dup method eq? [
[ delete-at ] with-methods
call-next-method
] [ 3drop ] if
]
[ t "forgotten" set-word-prop ] bi
] if ;
@ -146,10 +147,12 @@ M: method-body forget*
[ implementors ] [ [ swap 2array ] curry ] bi map forget-all ;
M: class forget* ( class -- )
[ forget-methods ]
[ update-map- ]
[ call-next-method ]
tri ;
{
[ forget-methods ]
[ update-map- ]
[ reset-class ]
[ call-next-method ]
} cleave ;
M: assoc update-methods ( assoc -- )
implementors* [ make-generic ] each ;

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

@ -261,7 +261,7 @@ TUPLE: cannot-unify-specials ;
: balanced? ( in out -- ? )
[ dup [ length - ] [ 2drop f ] if ] 2map
[ ] filter all-equal? ;
sift all-equal? ;
TUPLE: unbalanced-branches-error quots in out ;
@ -281,7 +281,7 @@ TUPLE: unbalanced-branches-error quots in out ;
2dup balanced? [
over supremum -rot
[ >r dupd r> unify-inputs ] 2map
[ ] filter unify-stacks
sift unify-stacks
rot drop
] [
unbalanced-branches-error

2
core/inference/inference-tests.factor
View File

@ -5,7 +5,7 @@ sequences strings vectors words quotations effects tools.test
continuations generic.standard sorting assocs definitions
prettyprint io inspector classes.tuple classes.union
classes.predicate debugger threads.private io.streams.string
io.timeouts io.thread sequences.private ;
io.timeouts io.thread sequences.private destructors ;
IN: inference.tests
[ ] [ [ 1 ] dataflow [ ] transform-nodes drop ] unit-test

2
core/inference/known-words/known-words.factor
View File

@ -356,7 +356,7 @@ M: object infer-call
\ setenv { object fixnum } { } <effect> set-primitive-effect
\ exists? { string } { object } <effect> set-primitive-effect
\ (exists?) { string } { object } <effect> set-primitive-effect
\ (directory) { string } { array } <effect> set-primitive-effect

4
core/io/binary/binary-docs.factor
View File

@ -6,12 +6,12 @@ ARTICLE: "stream-binary" "Working with binary data"
$nl
"There are two ways to order the bytes making up an integer; " { $emphasis "little endian" } " byte order outputs the least significant byte first, and the most significant byte last, whereas " { $emphasis "big endian" } " is the other way around."
$nl
"Consider the hexadecimal integer "{ $snippet "HEX: cafebabe" } ". Big endian byte order yields the following sequence of bytes:"
"Consider the hexadecimal integer "{ $snippet "HEX: cafebabe" } ". Little endian byte order yields the following sequence of bytes:"
{ $table
{ "Byte:" "1" "2" "3" "4" }
{ "Value:" { $snippet "be" } { $snippet "ba" } { $snippet "fe" } { $snippet "ca" } }
}
"Compare this with little endian byte order:"
"Compare this with big endian byte order:"
{ $table
{ "Byte:" "1" "2" "3" "4" }
{ "Value:" { $snippet "ca" } { $snippet "fe" } { $snippet "ba" } { $snippet "be" } }

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

@ -1,9 +1,9 @@
! Copyright (C) 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel sequences sbufs vectors namespaces growable
strings io classes continuations combinators io.styles
io.streams.plain splitting byte-arrays sequences.private
accessors ;
strings io classes continuations destructors combinators
io.styles io.streams.plain splitting byte-arrays
sequences.private accessors ;
IN: io.encodings
! The encoding descriptor protocol

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

@ -300,8 +300,8 @@ HELP: exists?
{ $description "Tests if the file named by " { $snippet "path" } " exists." } ;
HELP: directory?
{ $values { "path" "a pathname string" } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "path" } " names a directory." } ;
{ $values { "file-info" file-info } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "file-info" } " is a directory." } ;
HELP: (directory)
{ $values { "path" "a pathname string" } { "seq" "a sequence of " { $snippet "{ name dir? }" } " pairs" } }

12
core/io/files/files-tests.factor
View File

@ -1,11 +1,14 @@
IN: io.files.tests
USING: tools.test io.files io.files.private io threads kernel
continuations io.encodings.ascii io.files.unique sequences
strings accessors io.encodings.utf8 math ;
strings accessors io.encodings.utf8 math destructors ;
\ exists? must-infer
\ (exists?) must-infer
[ ] [ "blahblah" temp-file dup exists? [ delete-directory ] [ drop ] if ] unit-test
[ ] [ "blahblah" temp-file make-directory ] unit-test
[ t ] [ "blahblah" temp-file directory? ] unit-test
[ t ] [ "blahblah" temp-file file-info directory? ] unit-test
[ t ] [
[ temp-directory "loldir" append-path delete-directory ] ignore-errors
@ -66,6 +69,9 @@ strings accessors io.encodings.utf8 math ;
[ "awk" ] [ "/usr/libexec/awk///" file-name ] unit-test
[ "" ] [ "" file-name ] unit-test
[ "freetype6.dll" ] [ "resource:freetype6.dll" file-name ] unit-test
[ "freetype6.dll" ] [ "resource:/freetype6.dll" file-name ] unit-test
[ ] [
{ "Hello world." }
"test-foo.txt" temp-file ascii set-file-lines
@ -99,6 +105,8 @@ strings accessors io.encodings.utf8 math ;
[ f ] [ "test-bar.txt" temp-file exists? ] unit-test
[ "test-blah" temp-file delete-tree ] ignore-errors
[ ] [ "test-blah" temp-file make-directory ] unit-test
[ ] [

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

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: io.backend io.files.private io hashtables kernel math
memory namespaces sequences strings assocs arrays definitions
system combinators splitting sbufs continuations io.encodings
io.encodings.binary init accessors math.order ;
system combinators splitting sbufs continuations destructors
io.encodings io.encodings.binary init accessors math.order ;
IN: io.files
HOOK: (file-reader) io-backend ( path -- stream )
@ -142,7 +142,9 @@ PRIVATE>
: file-name ( path -- string )
dup root-directory? [
right-trim-separators
dup last-path-separator [ 1+ tail ] [ drop ] if
dup last-path-separator [ 1+ tail ] [
drop "resource:" ?head [ file-name ] when
] if
] unless ;
! File info
@ -170,11 +172,9 @@ SYMBOL: +socket+
SYMBOL: +unknown+
! File metadata
: exists? ( path -- ? )
normalize-path (exists?) ;
: exists? ( path -- ? ) normalize-path (exists?) ;
: directory? ( path -- ? )
file-info file-info-type +directory+ = ;
: directory? ( file-info -- ? ) type>> +directory+ = ;
<PRIVATE
@ -230,7 +230,7 @@ HOOK: make-directory io-backend ( path -- )
: fixup-directory ( path seq -- newseq )
[
dup string?
[ tuck append-path directory? 2array ] [ nip ] if
[ tuck append-path file-info directory? 2array ] [ nip ] if
] with map
[ first { "." ".." } member? not ] filter ;

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

@ -1,5 +1,5 @@
USING: help.markup help.syntax quotations hashtables kernel
classes strings continuations ;
classes strings continuations destructors ;
IN: io
ARTICLE: "stream-protocol" "Stream protocol"

10
core/io/io-tests.factor
View File

@ -1,6 +1,6 @@
USING: arrays io io.files kernel math parser strings system
tools.test words namespaces io.encodings.8-bit
io.encodings.binary ;
io.encodings.binary sequences ;
IN: io.tests
[ f ] [
@ -47,3 +47,11 @@ IN: io.tests
10 [ 65536 read drop ] times
] with-file-reader
] unit-test
! Test EOF behavior
[ 10 ] [
image binary [
0 read drop
10 read length
] with-file-reader
] unit-test

3
core/io/io.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2003, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: hashtables generic kernel math namespaces sequences
continuations assocs io.styles ;
continuations destructors assocs io.styles ;
IN: io
GENERIC: stream-readln ( stream -- str/f )
@ -39,6 +39,7 @@ SYMBOL: error-stream
: read1 ( -- ch/f ) input-stream get stream-read1 ;
: read ( n -- str/f ) input-stream get stream-read ;
: read-until ( seps -- str/f sep/f ) input-stream get stream-read-until ;
: read-partial ( n -- str/f ) input-stream get stream-read-partial ;
: write1 ( ch -- ) output-stream get stream-write1 ;
: write ( str -- ) output-stream get stream-write ;

34
core/io/streams/c/c.factor
View File

@ -2,37 +2,42 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel kernel.private namespaces io io.encodings
sequences math generic threads.private classes io.backend
io.files continuations byte-arrays ;
io.files continuations destructors byte-arrays accessors ;
IN: io.streams.c
TUPLE: c-writer handle ;
TUPLE: c-writer handle disposed ;
C: <c-writer> c-writer
: <c-writer> ( handle -- stream ) f c-writer boa ;
M: c-writer stream-write1
c-writer-handle fputc ;
dup check-disposed
handle>> fputc ;
M: c-writer stream-write
c-writer-handle fwrite ;
dup check-disposed
handle>> fwrite ;
M: c-writer stream-flush
c-writer-handle fflush ;
dup check-disposed
handle>> fflush ;
M: c-writer dispose
c-writer-handle fclose ;
M: c-writer dispose*
handle>> fclose ;
TUPLE: c-reader handle ;
TUPLE: c-reader handle disposed ;
C: <c-reader> c-reader
: <c-reader> ( handle -- stream ) f c-reader boa ;
M: c-reader stream-read
c-reader-handle fread ;
dup check-disposed
handle>> fread ;
M: c-reader stream-read-partial
stream-read ;
M: c-reader stream-read1
c-reader-handle fgetc ;
dup check-disposed
handle>> fgetc ;
: read-until-loop ( stream delim -- ch )
over stream-read1 dup [
@ -42,11 +47,12 @@ M: c-reader stream-read1
] if ;
M: c-reader stream-read-until
dup check-disposed
[ swap read-until-loop ] B{ } make swap
over empty? over not and [ 2drop f f ] when ;
M: c-reader dispose
c-reader-handle fclose ;
M: c-reader dispose*
handle>> fclose ;
M: object init-io ;

2
core/io/streams/nested/nested.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic assocs kernel namespaces strings
quotations io continuations accessors sequences ;
quotations io continuations destructors accessors sequences ;
IN: io.streams.nested
TUPLE: filter-writer stream ;

4
core/io/streams/string/string.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2003, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io kernel math namespaces sequences sbufs strings
generic splitting growable continuations io.streams.plain
io.encodings math.order ;
generic splitting growable continuations destructors
io.streams.plain io.encodings math.order ;
IN: io.streams.string
M: growable dispose drop ;

29
core/kernel/kernel-docs.factor
View File

@ -148,7 +148,7 @@ $nl
{ $subsection "spread-shuffle-equivalence" } ;
ARTICLE: "apply-combinators" "Apply combinators"
"The apply combinators apply multiple quotations to multiple values. The " { $snippet "@" } " suffix signifies application."
"The apply combinators apply a single quotation to multiple values. The " { $snippet "@" } " suffix signifies application."
$nl
"Two quotations:"
{ $subsection bi@ }
@ -179,6 +179,7 @@ ARTICLE: "compositional-combinators" "Compositional combinators"
{ $subsection with }
{ $subsection compose }
{ $subsection 3compose }
{ $subsection prepose }
"Quotations also implement the sequence protocol, and can be manipulated with sequence words; see " { $link "quotations" } "." ;
ARTICLE: "implementing-combinators" "Implementing combinators"
@ -717,17 +718,21 @@ $nl
HELP: unless*
{ $values { "cond" "a generalized boolean" } { "false" "a quotation " } }
{ $description "Variant of " { $link if* } " with no true quotation."
$nl
{ $description "Variant of " { $link if* } " with no true quotation." }
{ $notes
"The following two lines are equivalent:"
{ $code "X [ Y ] unless*" "X dup [ ] [ drop Y ] if" } } ;
{ $code "X [ Y ] unless*" "X dup [ ] [ drop Y ] if" }
"The following two lines are equivalent, where " { $snippet "L" } " is a literal:"
{ $code "[ L ] unless*" "L or" } } ;
HELP: ?if
{ $values { "default" object } { "cond" "a generalized boolean" } { "true" "a quotation with stack effect " { $snippet "( cond -- )" } } { "false" "a quotation with stack effect " { $snippet "( default -- )" } } }
{ $description "If the condition is " { $link f } ", the " { $snippet "false" } " quotation is called with the " { $snippet "default" } " value on the stack. Otherwise, the " { $snippet "true" } " quotation is called with the condition on the stack."
$nl
{ $description "If the condition is " { $link f } ", the " { $snippet "false" } " quotation is called with the " { $snippet "default" } " value on the stack. Otherwise, the " { $snippet "true" } " quotation is called with the condition on the stack." }
{ $notes
"The following two lines are equivalent:"
{ $code "[ X ] [ Y ] ?if" "dup [ nip X ] [ drop Y ] if" } } ;
{ $code "[ X ] [ Y ] ?if" "dup [ nip X ] [ drop Y ] if" }
"The following two lines are equivalent:"
{ $code "[ ] [ ] ?if" "swap or" } } ;
HELP: die
{ $description "Starts the front-end processor (FEP), which is a low-level debugger which can inspect memory addresses and the like. The FEP is also entered when a critical error occurs." }
@ -835,8 +840,16 @@ HELP: compose ( quot1 quot2 -- compose )
"However, " { $link compose } " runs in constant time, and the optimizing compiler is able to compile code which calls composed quotations."
} ;
HELP: prepose
{ $values { "quot1" callable } { "quot2" callable } { "compose" compose } }
{ $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot2" } " followed by " { $snippet "quot1" } "." }
{ $notes "See " { $link compose } " for details." } ;
{ compose prepose } related-words
HELP: 3compose
{ $values { "quot1" callable } { "quot2" callable } { "quot3" callable } { "curry" curry } }
{ $values { "quot1" callable } { "quot2" callable } { "quot3" callable } { "compose" compose } }
{ $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot1" } ", " { $snippet "quot2" } " and then " { $snippet "quot3" } "." }
{ $notes
"The three quotations must leave the retain stack in the same state on exit as it was on entry, so for example, the following code is not allowed:"

4
core/kernel/kernel.factor
View File

@ -156,10 +156,10 @@ M: callstack clone (clone) ;
: with ( param obj quot -- obj curry )
swapd [ swapd call ] 2curry ; inline
: prepose ( quot1 quot2 -- curry )
: prepose ( quot1 quot2 -- compose )
swap compose ; inline
: 3compose ( quot1 quot2 quot3 -- curry )
: 3compose ( quot1 quot2 quot3 -- compose )
compose compose ; inline
! Booleans

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

@ -1,4 +1,4 @@
USING: help.markup help.syntax alien ;
USING: help.markup help.syntax alien destructors ;
IN: libc
HELP: malloc
@ -36,5 +36,13 @@ HELP: with-malloc
{ $values { "size" "a positive integer" } { "quot" "a quotation with stack effect " { $snippet "( c-ptr -- )" } } }
{ $description "Allocates a zeroed block of " { $snippet "n" } " bytes and passes it to the quotation. When the quotation returns, the block is freed." } ;
HELP: &free
{ $values { "alien" c-ptr } }
{ $description "Marks the block of memory for unconditional deallocation at the end of the current " { $link with-destructors } " scope." } ;
HELP: |free
{ $values { "alien" c-ptr } }
{ $description "Marks the object for deallocation in the event of an error at the end of the current " { $link with-destructors } " scope." } ;
! Defined in alien-docs.factor
ABOUT: "malloc"

11
core/libc/libc-tests.factor Executable file
View File

@ -0,0 +1,11 @@
IN: libc.tests
USING: libc libc.private tools.test namespaces assocs
destructors kernel ;
100 malloc "block" set
[ t ] [ "block" get mallocs get key? ] unit-test
[ ] [ [ "block" get &free drop ] with-destructors ] unit-test
[ f ] [ "block" get mallocs get key? ] unit-test

25
core/libc/libc.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2004, 2005 Mackenzie Straight
! Copyright (C) 2007 Slava Pestov
! Copyright (C) 2007 Doug Coleman
! Copyright (C) 2007, 2008 Slava Pestov
! Copyright (C) 2007, 2008 Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
USING: alien assocs continuations init kernel namespaces ;
USING: alien assocs continuations destructors init kernel
namespaces accessors ;
IN: libc
<PRIVATE
@ -73,3 +74,21 @@ PRIVATE>
: with-malloc ( size quot -- )
swap 1 calloc [ swap keep ] [ free ] [ ] cleanup ; inline
: strlen ( alien -- len )
"size_t" "libc" "strlen" { "char*" } alien-invoke ;
<PRIVATE
! Memory allocations
TUPLE: memory-destructor alien disposed ;
M: memory-destructor dispose* alien>> free ;
PRIVATE>
: &free ( alien -- alien )
dup f memory-destructor boa &dispose drop ; inline
: |free ( alien -- alien )
dup f memory-destructor boa |dispose drop ; inline

25
core/parser/parser-tests.factor
View File

@ -435,3 +435,28 @@ must-fail-with
[ 92 ] [ "CHAR: \\" eval ] unit-test
[ 92 ] [ "CHAR: \\\\" eval ] unit-test
[ ] [
{
"IN: parser.tests"
"USING: math arrays ;"
"GENERIC: change-combination"
"M: integer change-combination 1 ;"
"M: array change-combination 2 ;"
} "\n" join <string-reader> "change-combination-test" parse-stream drop
] unit-test
[ ] [
{
"IN: parser.tests"
"USING: math arrays ;"
"GENERIC# change-combination 1"
"M: integer change-combination 1 ;"
"M: array change-combination 2 ;"
} "\n" join <string-reader> "change-combination-test" parse-stream drop
] unit-test
[ 2 ] [
"change-combination" "parser.tests" lookup
"methods" word-prop assoc-size
] unit-test

4
core/parser/parser.factor
View File

@ -207,7 +207,7 @@ SYMBOL: in
: add-use ( seq -- ) [ use+ ] each ;
: set-use ( seq -- )
[ vocab-words ] map [ ] filter >vector use set ;
[ vocab-words ] V{ } map-as sift use set ;
: check-vocab-string ( name -- name )
dup string?
@ -278,7 +278,7 @@ M: no-word-error summary
dup forward-reference? [
drop
use get
[ at ] with map [ ] filter
[ at ] with map sift
[ forward-reference? not ] find nip
] [
nip

6
core/prettyprint/prettyprint-tests.factor
View File

@ -334,5 +334,11 @@ PREDICATE: predicate-see-test < integer even? ;
[ \ predicate-see-test see ] with-string-writer
] unit-test
INTERSECTION: intersection-see-test sequence number ;
[ "USING: math sequences ;\nIN: prettyprint.tests\nINTERSECTION: intersection-see-test sequence number ;\n" ] [
[ \ intersection-see-test see ] with-string-writer
] unit-test
[ ] [ \ compose see ] unit-test
[ ] [ \ curry see ] unit-test

9
core/prettyprint/prettyprint.factor
View File

@ -7,8 +7,8 @@ vectors words prettyprint.backend prettyprint.sections
prettyprint.config sorting splitting math.parser vocabs
definitions effects classes.builtin classes.tuple io.files
classes continuations hashtables classes.mixin classes.union
classes.predicate classes.singleton combinators quotations
sets ;
classes.intersection classes.predicate classes.singleton
combinators quotations sets ;
: make-pprint ( obj quot -- block in use )
[
@ -238,6 +238,11 @@ M: union-class see-class*
dup pprint-word
members pprint-elements pprint-; block> ;
M: intersection-class see-class*
<colon \ INTERSECTION: pprint-word
dup pprint-word
participants pprint-elements pprint-; block> ;
M: mixin-class see-class*
<block \ MIXIN: pprint-word
dup pprint-word <block

2
core/prettyprint/sections/sections.factor
View File

@ -309,7 +309,7 @@ M: f section-end-group? drop f ;
2dup 1+ swap ?nth next set
swap nth dup split-before dup , split-after
] with each
] { } make { t } split [ empty? not ] filter ;
] { } make { t } split harvest ;
: break-group? ( seq -- ? )
[ first section-fits? ] [ peek section-fits? not ] bi and ;

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

@ -821,8 +821,8 @@ HELP: 3append
HELP: subseq
{ $values { "from" "a non-negative integer" } { "to" "a non-negative integer" } { "seq" sequence } { "subseq" "a new sequence" } }
{ $description "Outputs a new sequence consisting of all elements starting from and including " { $snippet "m" } ", and up to but not including " { $snippet "n" } "." }
{ $errors "Throws an error if " { $snippet "m" } " or " { $snippet "n" } " is out of bounds." } ;
{ $description "Outputs a new sequence consisting of all elements starting from and including " { $snippet "from" } ", and up to but not including " { $snippet "to" } "." }
{ $errors "Throws an error if " { $snippet "from" } " or " { $snippet "to" } " is out of bounds." } ;
HELP: clone-like
{ $values { "seq" sequence } { "exemplar" sequence } { "newseq" "a new sequence" } }

6
core/sequences/sequences.factor
View File

@ -445,6 +445,12 @@ PRIVATE>
: remove ( obj seq -- newseq )
[ = not ] with filter ;
: sift ( seq -- newseq )
[ ] filter ;
: harvest ( seq -- newseq )
[ empty? not ] filter ;
: cache-nth ( i seq quot -- elt )
2over ?nth dup [
>r 3drop r>

2
core/slots/deprecated/deprecated.factor
View File

@ -86,7 +86,7 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ;
{ [ over string? ] [ >r dupd r> short-slot ] }
{ [ over array? ] [ long-slot ] }
} cond
] 2map [ ] filter nip ;
] 2map sift nip ;
: slot-of-reader ( reader specs -- spec/f )
[ slot-spec-reader eq? ] with find nip ;

9
core/syntax/syntax-docs.factor
View File

@ -496,14 +496,17 @@ HELP: M:
HELP: UNION:
{ $syntax "UNION: class members... ;" }
{ $values { "class" "a new class word to define" } { "members" "a list of class words separated by whitespace" } }
{ $description "Defines a union class. An object is an instance of a union class if it is an instance of one of its members." }
{ $notes "Union classes are used to associate the same method with several different classes, as well as to conveniently define predicates." } ;
{ $description "Defines a union class. An object is an instance of a union class if it is an instance of one of its members." } ;
HELP: INTERSECTION:
{ $syntax "INTERSECTION: class participants... ;" }
{ $values { "class" "a new class word to define" } { "participants" "a list of class words separated by whitespace" } }
{ $description "Defines an intersection class. An object is an instance of a union class if it is an instance of all of its participants." } ;
HELP: MIXIN:
{ $syntax "MIXIN: class" }
{ $values { "class" "a new class word to define" } }
{ $description "Defines a mixin class. A mixin is similar to a union class, except it has no members initially, and new members can be added with the " { $link POSTPONE: INSTANCE: } " word." }
{ $notes "Mixins classes are used to mark implementations of a protocol and define default methods." }
{ $examples "The " { $link sequence } " and " { $link assoc } " mixin classes." } ;
HELP: INSTANCE:

12
core/syntax/syntax.factor
View File

@ -5,8 +5,9 @@ definitions generic hashtables kernel math
namespaces parser sequences strings sbufs vectors words
quotations io assocs splitting classes.tuple generic.standard
generic.math classes io.files vocabs float-arrays
classes.union classes.mixin classes.predicate classes.singleton
compiler.units combinators debugger ;
classes.union classes.intersection classes.mixin
classes.predicate classes.singleton compiler.units
combinators debugger ;
IN: bootstrap.syntax
! These words are defined as a top-level form, instead of with
@ -135,6 +136,10 @@ IN: bootstrap.syntax
CREATE-CLASS parse-definition define-union-class
] define-syntax
"INTERSECTION:" [
CREATE-CLASS parse-definition define-intersection-class
] define-syntax
"MIXIN:" [
CREATE-CLASS define-mixin-class
] define-syntax
@ -153,8 +158,7 @@ IN: bootstrap.syntax
] define-syntax
"SINGLETON:" [
scan create-class-in
dup save-location define-singleton-class
CREATE-CLASS define-singleton-class
] define-syntax
"TUPLE:" [

2
core/vocabs/vocabs.factor
View File

@ -76,7 +76,7 @@ SYMBOL: load-vocab-hook ! ( name -- )
: words-named ( str -- seq )
dictionary get values
[ vocab-words at ] with map
[ ] filter ;
sift ;
: child-vocab? ( prefix name -- ? )
2dup = pick empty? or

4
core/words/words.factor
View File

@ -3,7 +3,7 @@
USING: arrays definitions graphs assocs kernel kernel.private
slots.private math namespaces sequences strings vectors sbufs
quotations assocs hashtables sorting words.private vocabs
math.order ;
math.order sets ;
IN: words
: word ( -- word ) \ word get-global ;
@ -121,7 +121,7 @@ SYMBOL: +called+
compiled-crossref get at ;
: compiled-usages ( words -- seq )
[ [ dup ] H{ } map>assoc dup ] keep [
[ unique dup ] keep [
compiled-usage [ nip +inlined+ eq? ] assoc-filter update
] with each keys ;

3
extra/assocs/lib/lib.factor
View File

@ -2,9 +2,6 @@ USING: arrays assocs kernel vectors sequences namespaces
random math.parser ;
IN: assocs.lib
: >set ( seq -- hash )
[ dup ] H{ } map>assoc ;
: ref-at ( table key -- value ) swap at ;
: put-at* ( table key value -- ) swap rot set-at ;

2
extra/bank/bank.factor
View File

@ -1,3 +1,5 @@
! Copyright (C) 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: accessors calendar kernel math math.order money sequences ;
IN: bank

3
extra/benchmark/sockets/sockets.factor
View File

@ -1,6 +1,7 @@
USING: io.sockets io kernel math threads io.encodings.ascii
io.streams.duplex debugger tools.time prettyprint
concurrency.count-downs namespaces arrays continuations ;
concurrency.count-downs namespaces arrays continuations
destructors ;
IN: benchmark.sockets
SYMBOL: counter

9
extra/bootstrap/image/download/download.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: bootstrap.image.download
USING: http.client checksums checksums.md5 splitting assocs
USING: http.client checksums checksums.openssl splitting assocs
kernel io.files bootstrap.image sequences io ;
: url "http://factorcode.org/images/latest/" ;
@ -12,8 +12,11 @@ kernel io.files bootstrap.image sequences io ;
: need-new-image? ( image -- ? )
dup exists?
[ [ md5 checksum-file hex-string ] [ download-checksums at ] bi = not ]
[ drop t ] if ;
[
[ openssl-md5 checksum-file hex-string ]
[ download-checksums at ]
bi = not
] [ drop t ] if ;
: download-image ( arch -- )
boot-image-name dup need-new-image? [

6
extra/bootstrap/image/upload/upload.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: http.client checksums checksums.md5 splitting assocs
USING: checksums checksums.openssl splitting assocs
kernel io.files bootstrap.image sequences io namespaces
io.launcher math io.encodings.ascii ;
IN: bootstrap.image.upload
@ -19,7 +19,9 @@ SYMBOL: upload-images-destination
: compute-checksums ( -- )
checksums ascii [
boot-image-names [
[ write bl ] [ md5 checksum-file hex-string print ] bi
[ write bl ]
[ openssl-md5 checksum-file hex-string print ]
bi
] each
] with-file-writer ;

43
extra/builder/benchmark/benchmark.factor
View File

@ -1,43 +0,0 @@
USING: kernel continuations arrays assocs sequences sorting math
io io.styles prettyprint builder.util ;
IN: builder.benchmark
! : passing-benchmarks ( table -- table )
! [ second first2 number? swap number? and ] filter ;
: passing-benchmarks ( table -- table ) [ second number? ] filter ;
! : simplify-table ( table -- table ) [ first2 second 2array ] map ;
: benchmark-difference ( old-table benchmark-result -- result-diff )
first2 >r
tuck swap at
r>
swap -
2array ;
: compare-tables ( old new -- table )
[ passing-benchmarks ] bi@
[ benchmark-difference ] with map ;
: benchmark-deltas ( -- table )
"../benchmarks" "benchmarks" [ eval-file ] bi@
compare-tables
sort-values ;
: benchmark-deltas. ( deltas -- )
standard-table-style
[
[ [ "Benchmark" write ] with-cell [ "Delta (ms)" write ] with-cell ]
with-row
[ [ swap [ write ] with-cell pprint-cell ] with-row ]
assoc-each
]
tabular-output ;
: show-benchmark-deltas ( -- )
[ benchmark-deltas benchmark-deltas. ]
[ drop "Error generating benchmark deltas" . ]
recover ;

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

@ -41,12 +41,17 @@ DEFER: to-strings
: host-name* ( -- name ) host-name "." split first ;
! : datestamp ( -- string )
! now `{ ,[ dup timestamp-year ]
! ,[ dup timestamp-month ]
! ,[ dup timestamp-day ]
! ,[ dup timestamp-hour ]
! ,[ timestamp-minute ] }
! [ pad-00 ] map "-" join ;
: datestamp ( -- string )
now `{ ,[ dup timestamp-year ]
,[ dup timestamp-month ]
,[ dup timestamp-day ]
,[ dup timestamp-hour ]
,[ timestamp-minute ] }
now
{ year>> month>> day>> hour>> minute>> } <arr>
[ pad-00 ] map "-" join ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

4
extra/bunny/bunny.factor
View File

@ -4,7 +4,7 @@ opengl.glu shuffle http.client vectors namespaces ui.gadgets
ui.gadgets.canvas ui.render ui splitting combinators tools.time
system combinators.lib float-arrays continuations
opengl.demo-support multiline ui.gestures bunny.fixed-pipeline
bunny.cel-shaded bunny.outlined bunny.model accessors ;
bunny.cel-shaded bunny.outlined bunny.model accessors destructors ;
IN: bunny
TUPLE: bunny-gadget model geom draw-seq draw-n ;
@ -33,7 +33,7 @@ M: bunny-gadget graft* ( gadget -- )
[ <bunny-fixed-pipeline> ]
[ <bunny-cel-shaded> ]
[ <bunny-outlined> ] tri 3array
[ ] filter >>draw-seq
sift >>draw-seq
0 >>draw-n
drop ;

5
extra/bunny/cel-shaded/cel-shaded.factor
View File

@ -1,5 +1,6 @@
USING: arrays bunny.model continuations kernel multiline opengl opengl.shaders
opengl.capabilities opengl.gl sequences sequences.lib accessors ;
USING: arrays bunny.model continuations destructors kernel
multiline opengl opengl.shaders opengl.capabilities opengl.gl
sequences sequences.lib accessors ;
IN: bunny.cel-shaded
STRING: vertex-shader-source

2
extra/bunny/fixed-pipeline/fixed-pipeline.factor
View File

@ -1,4 +1,4 @@
USING: alien.c-types continuations kernel
USING: alien.c-types continuations destructors kernel
opengl opengl.gl bunny.model ;
IN: bunny.fixed-pipeline

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

@ -2,11 +2,12 @@ USING: alien alien.c-types arrays sequences math math.vectors
math.matrices math.parser io io.files kernel opengl opengl.gl
opengl.glu io.encodings.ascii opengl.capabilities shuffle
http.client vectors splitting tools.time system combinators
float-arrays continuations namespaces sequences.lib accessors ;
float-arrays continuations destructors namespaces sequences.lib
accessors ;
IN: bunny.model
: numbers ( str -- seq )
" " split [ string>number ] map [ ] filter ;
" " split [ string>number ] map sift ;
: (parse-model) ( vs is -- vs is )
readln [

8
extra/bunny/outlined/outlined.factor
View File

@ -1,7 +1,7 @@
USING: arrays bunny.model bunny.cel-shaded continuations kernel
math multiline opengl opengl.shaders opengl.framebuffers
opengl.gl opengl.capabilities sequences ui.gadgets combinators
accessors ;
USING: arrays bunny.model bunny.cel-shaded continuations
destructors kernel math multiline opengl opengl.shaders
opengl.framebuffers opengl.gl opengl.capabilities sequences
ui.gadgets combinators accessors ;
IN: bunny.outlined
STRING: outlined-pass1-fragment-shader-main-source

36
extra/cairo/cairo.factor Executable file
View File

@ -0,0 +1,36 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: cairo.ffi kernel accessors sequences
namespaces fry continuations destructors ;
IN: cairo
TUPLE: cairo-t alien ;
C: <cairo-t> cairo-t
M: cairo-t dispose ( alien -- ) alien>> cairo_destroy ;
TUPLE: cairo-surface-t alien ;
C: <cairo-surface-t> cairo-surface-t
M: cairo-surface-t dispose ( alien -- ) alien>> cairo_surface_destroy ;
: check-cairo ( cairo_status_t -- )
dup CAIRO_STATUS_SUCCESS = [ drop ]
[ cairo_status_to_string "Cairo error: " prepend throw ] if ;
SYMBOL: cairo
: cr ( -- cairo ) cairo get ;
: (with-cairo) ( cairo-t quot -- )
>r alien>> cairo r> [ cr cairo_status check-cairo ]
compose with-variable ; inline
: with-cairo ( cairo quot -- )
>r <cairo-t> r> [ (with-cairo) ] curry with-disposal ; inline
: (with-surface) ( cairo-surface-t quot -- )
>r alien>> r> [ cairo_surface_status check-cairo ] bi ; inline
: with-surface ( cairo_surface quot -- )
>r <cairo-surface-t> r> [ (with-surface) ] curry with-disposal ; inline
: with-cairo-from-surface ( cairo_surface quot -- )
'[ cairo_create , with-cairo ] with-surface ; inline

1080
extra/cairo/ffi/ffi.factor
View File

File diff suppressed because it is too large Load Diff

73
extra/cairo/gadgets/gadgets.factor Normal file
View File

@ -0,0 +1,73 @@
! Copyright (C) 2008 Matthew Willis.
! See http://factorcode.org/license.txt for BSD license.
USING: cairo cairo.ffi ui.render kernel opengl.gl opengl
math byte-arrays ui.gadgets accessors arrays
namespaces io.backend ;
IN: cairo.gadgets
! We need two kinds of gadgets:
! one performs the cairo ops once and caches the bytes, the other
! performs cairo ops every refresh
TUPLE: cairo-gadget width height quot cache? bytes ;
PREDICATE: cached-cairo < cairo-gadget cache?>> ;
: <cairo-gadget> ( width height quot -- cairo-gadget )
cairo-gadget construct-gadget
swap >>quot
swap >>height
swap >>width ;
: <cached-cairo> ( width height quot -- cairo-gadget )
<cairo-gadget> t >>cache? ;
: width>stride ( width -- stride ) 4 * ;
: copy-cairo ( width height quot -- byte-array )
>r over width>stride
[ * nip <byte-array> dup CAIRO_FORMAT_ARGB32 ]
[ cairo_image_surface_create_for_data ] 3bi
r> with-cairo-from-surface ;
: (cairo>bytes) ( gadget -- byte-array )
[ width>> ] [ height>> ] [ quot>> ] tri copy-cairo ;
GENERIC: cairo>bytes
M: cairo-gadget cairo>bytes ( gadget -- byte-array )
(cairo>bytes) ;
M: cached-cairo cairo>bytes ( gadget -- byte-array )
dup bytes>> [ ] [
dup (cairo>bytes) [ >>bytes drop ] keep
] ?if ;
: cairo>png ( gadget path -- )
>r [ cairo>bytes CAIRO_FORMAT_ARGB32 ] [ width>> ]
[ height>> ] tri over width>stride
cairo_image_surface_create_for_data
r> [ cairo_surface_write_to_png check-cairo ] curry with-surface ;
M: cairo-gadget draw-gadget* ( gadget -- )
origin get [
0 0 glRasterPos2i
1.0 -1.0 glPixelZoom
[ width>> ] [ height>> GL_BGRA GL_UNSIGNED_BYTE ]
[ cairo>bytes ] tri glDrawPixels
] with-translation ;
M: cairo-gadget pref-dim* ( gadget -- rect )
[ width>> ] [ height>> ] bi 2array ;
: copy-surface ( surface -- )
cr swap 0 0 cairo_set_source_surface
cr cairo_paint ;
: <bytes-gadget> ( width height bytes -- cairo-gadget )
>r [ ] <cached-cairo> r> >>bytes ;
: <png-gadget> ( path -- gadget )
normalize-path cairo_image_surface_create_from_png
[ cairo_image_surface_get_width ]
[ cairo_image_surface_get_height 2dup ]
[ [ copy-surface ] curry copy-cairo ] tri
<bytes-gadget> ;

39
extra/cairo/lib/lib.factor
View File

@ -1,39 +0,0 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types cairo.ffi continuations destructors
kernel libc locals math shuffle accessors ;
IN: cairo.lib
TUPLE: cairo-t alien ;
C: <cairo-t> cairo-t
M: cairo-t dispose ( alien -- ) alien>> cairo_destroy ;
: cairo-t-destroy-always ( alien -- ) <cairo-t> add-always-destructor ;
: cairo-t-destroy-later ( alien -- ) <cairo-t> add-error-destructor ;
TUPLE: cairo-surface-t alien ;
C: <cairo-surface-t> cairo-surface-t
M: cairo-surface-t dispose ( alien -- ) alien>> cairo_surface_destroy ;
: cairo-surface-t-destroy-always ( alien -- )
<cairo-surface-t> add-always-destructor ;
: cairo-surface-t-destroy-later ( alien -- )
<cairo-surface-t> add-error-destructor ;
: cairo-surface>array ( surface -- cairo-t byte-array )
[
dup
[ drop CAIRO_FORMAT_ARGB32 ]
[ cairo_image_surface_get_width ]
[ cairo_image_surface_get_height ] tri
over 4 *
2dup * [
malloc dup free-always [
5 -nrot cairo_image_surface_create_for_data
dup cairo-surface-t-destroy-always
cairo_create dup cairo-t-destroy-later
[ swap 0 0 cairo_set_source_surface ] keep
dup cairo_paint
] keep
] keep memory>byte-array
] with-destructors ;

65
extra/cairo/png/png.factor
View File

@ -1,65 +0,0 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel accessors math ui.gadgets ui.render
opengl.gl byte-arrays namespaces opengl cairo.ffi cairo.lib
inspector sequences combinators io.backend ;
IN: cairo.png
TUPLE: png surface width height cairo-t array ;
TUPLE: png-gadget png ;
ERROR: cairo-error string ;
: check-zero ( n -- n )
dup zero? [
"PNG dimension is 0" cairo-error
] when ;
: cairo-png-error ( n -- )
{
{ 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 ]
} case ;
: <png> ( path -- png )
normalize-path
cairo_image_surface_create_from_png
dup cairo_surface_status cairo-png-error
dup [ cairo_image_surface_get_width check-zero ]
[ cairo_image_surface_get_height check-zero ] [ ] tri
cairo-surface>array png boa ;
: write-png ( png path -- )
>r png-surface r>
cairo_surface_write_to_png
zero? [ "write png failed" throw ] unless ;
: <png-gadget> ( path -- gadget )
png-gadget construct-gadget swap
<png> >>png ;
M: png-gadget pref-dim* ( gadget -- )
png>>
[ width>> ] [ height>> ] bi 2array ;
M: png-gadget draw-gadget* ( gadget -- )
origin get [
0 0 glRasterPos2i
1.0 -1.0 glPixelZoom
png>>
[ width>> ]
[ height>> GL_RGBA GL_UNSIGNED_BYTE ]
! [ height>> GL_BGRA GL_UNSIGNED_BYTE ]
[ array>> ] tri
glDrawPixels
] with-translation ;
M: png-gadget graft* ( gadget -- )
drop ;
M: png-gadget ungraft* ( gadget -- )
png>> surface>> cairo_destroy ;
! "resource:misc/icons/Factor_1x16.png" USE: cairo.png <png-gadget> gadget.

147
extra/cairo/samples/samples.factor Normal file
View File

@ -0,0 +1,147 @@
! Copyright (C) 2008 Matthew Willis
! See http://factorcode.org/license.txt for BSD license.
!
! these samples are a subset of the samples on
! http://cairographics.org/samples/
USING: cairo cairo.ffi locals math.constants math
io.backend kernel alien.c-types libc namespaces ;
IN: cairo.samples
:: arc ( -- )
[let | xc [ 128.0 ]
yc [ 128.0 ]
radius [ 100.0 ]
angle1 [ pi 1/4 * ]
angle2 [ pi ] |
cr 10.0 cairo_set_line_width
cr xc yc radius angle1 angle2 cairo_arc
cr cairo_stroke
! draw helping lines
cr 1 0.2 0.2 0.6 cairo_set_source_rgba
cr 6.0 cairo_set_line_width
cr xc yc 10.0 0 2 pi * cairo_arc
cr cairo_fill
cr xc yc radius angle1 angle1 cairo_arc
cr xc yc cairo_line_to
cr xc yc radius angle2 angle2 cairo_arc
cr xc yc cairo_line_to
cr cairo_stroke
] ;
: clip ( -- )
cr 128 128 76.8 0 2 pi * cairo_arc
cr cairo_clip
cr cairo_new_path
cr 0 0 256 256 cairo_rectangle
cr cairo_fill
cr 0 1 0 cairo_set_source_rgb
cr 0 0 cairo_move_to
cr 256 256 cairo_line_to
cr 256 0 cairo_move_to
cr 0 256 cairo_line_to
cr 10 cairo_set_line_width
cr cairo_stroke ;
:: clip-image ( -- )
[let* | png [ "resource:misc/icons/Factor_128x128.png"
normalize-path cairo_image_surface_create_from_png ]
w [ png cairo_image_surface_get_width ]
h [ png cairo_image_surface_get_height ] |
cr 128 128 76.8 0 2 pi * cairo_arc
cr cairo_clip
cr cairo_new_path
cr 192.0 w / 192.0 h / cairo_scale
cr png 32 32 cairo_set_source_surface
cr cairo_paint
png cairo_surface_destroy
] ;
:: dash ( -- )
[let | dashes [ { 50 10 10 10 } >c-double-array ]
ndash [ 4 ] |
cr dashes ndash -50 cairo_set_dash
cr 10 cairo_set_line_width
cr 128.0 25.6 cairo_move_to
cr 230.4 230.4 cairo_line_to
cr -102.4 0 cairo_rel_line_to
cr 51.2 230.4 51.2 128.0 128.0 128.0 cairo_curve_to
cr cairo_stroke
] ;
:: gradient ( -- )
[let | pat [ 0 0 0 256 cairo_pattern_create_linear ]
radial [ 115.2 102.4 25.6 102.4 102.4 128.0
cairo_pattern_create_radial ] |
pat 1 0 0 0 1 cairo_pattern_add_color_stop_rgba
pat 0 1 1 1 1 cairo_pattern_add_color_stop_rgba
cr 0 0 256 256 cairo_rectangle
cr pat cairo_set_source
cr cairo_fill
pat cairo_pattern_destroy
radial 0 1 1 1 1 cairo_pattern_add_color_stop_rgba
radial 1 0 0 0 1 cairo_pattern_add_color_stop_rgba
cr radial cairo_set_source
cr 128.0 128.0 76.8 0 2 pi * cairo_arc
cr cairo_fill
radial cairo_pattern_destroy
] ;
: text ( -- )
cr "Serif" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_BOLD
cairo_select_font_face
cr 50 cairo_set_font_size
cr 10 135 cairo_move_to
cr "Hello" cairo_show_text
cr 70 165 cairo_move_to
cr "factor" cairo_text_path
cr 0.5 0.5 1 cairo_set_source_rgb
cr cairo_fill_preserve
cr 0 0 0 cairo_set_source_rgb
cr 2.56 cairo_set_line_width
cr cairo_stroke
! draw helping lines
cr 1 0.2 0.2 0.6 cairo_set_source_rgba
cr 10 135 5.12 0 2 pi * cairo_arc
cr cairo_close_path
cr 70 165 5.12 0 2 pi * cairo_arc
cr cairo_fill ;
: utf8 ( -- )
cr "Serif" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_NORMAL
cairo_select_font_face
cr 50 cairo_set_font_size
"cairo_text_extents_t" malloc-object
cr B{ 230 151 165 230 156 172 232 170 158 } pick cairo_text_extents
cr over
[ cairo_text_extents_t-width 2 / ]
[ cairo_text_extents_t-x_bearing ] bi +
128 swap - pick
[ cairo_text_extents_t-height 2 / ]
[ cairo_text_extents_t-y_bearing ] bi +
128 swap - cairo_move_to
free
cr B{ 230 151 165 230 156 172 232 170 158 } cairo_show_text
cr 1 0.2 0.2 0.6 cairo_set_source_rgba
cr 6 cairo_set_line_width
cr 128 0 cairo_move_to
cr 0 256 cairo_rel_line_to
cr 0 128 cairo_move_to
cr 256 0 cairo_rel_line_to
cr cairo_stroke ;
USING: quotations cairo.gadgets ui.gadgets.panes sequences ;
: samples ( -- )
{ arc clip clip-image dash gradient text utf8 }
[ 256 256 rot 1quotation <cached-cairo> gadget. ] each ;
MAIN: samples

2
extra/checksums/adler-32/adler-32-docs.factor
View File

@ -2,7 +2,7 @@ USING: help.markup help.syntax ;
IN: checksums.adler-32
HELP: adler-32
{ $description "Adler-32 checksum algorithm." } ;
{ $class-description "Adler-32 checksum algorithm." } ;
ARTICLE: "checksums.adler-32" "Adler-32 checksum"
"The Adler-32 checksum algorithm implements simple and fast checksum. It is used in zlib and rsync."

2
extra/checksums/md5/md5-docs.factor
View File

@ -2,7 +2,7 @@ USING: help.markup help.syntax ;
IN: checksums.md5
HELP: md5
{ $description "MD5 checksum algorithm." } ;
{ $class-description "MD5 checksum algorithm." } ;
ARTICLE: "checksums.md5" "MD5 checksum"
"The MD5 checksum algorithm implements a one-way hash function. While it is widely used, many weaknesses are known and it should not be used in new applications (" { $url "http://www.schneier.com/blog/archives/2005/03/more_hash_funct.html" } ")."

35
extra/checksums/openssl/openssl-docs.factor Normal file
View File

@ -0,0 +1,35 @@
IN: checksums.openssl
USING: help.syntax help.markup ;
HELP: openssl-checksum
{ $class-description "The class of checksum algorithms implemented by OpenSSL. The exact set of algorithms supported depends on how the OpenSSL library was compiled; " { $snippet "md5" } " and " { $snippet "sha1" } " should be universally available." } ;
HELP: <openssl-checksum> ( name -- checksum )
{ $values { "name" "an EVP message digest name" } { "checksum" openssl-checksum } }
{ $description "Creates a new OpenSSL checksum object." } ;
HELP: openssl-md5
{ $description "The OpenSSL MD5 message digest implementation." } ;
HELP: openssl-sha1
{ $description "The OpenSSL SHA1 message digest implementation." } ;
HELP: unknown-digest
{ $error-description "Thrown by checksum words if they are passed an " { $link openssl-checksum } " naming a message digest not supported by OpenSSL." } ;
ARTICLE: "checksums.openssl" "OpenSSL checksums"
"The OpenSSL library provides a large number of efficient checksum (message digest) algorithms which may be used independently of its SSL functionality."
{ $subsection openssl-checksum }
"Constructing a checksum from a known name:"
{ $subsection <openssl-checksum> }
"Two utility words:"
{ $subsection openssl-md5 }
{ $subsection openssl-sha1 }
"An error thrown if the digest name is unrecognized:"
{ $subsection unknown-digest }
"An example where we compute the SHA1 checksum of a string using the OpenSSL implementation of SHA1:"
{ $example "USING: byte-arrays checksums checksums.openssl prettyprint ;" "\"hello world\" >byte-array openssl-sha1 checksum-bytes hex-string ." "\"2aae6c35c94fcfb415dbe95f408b9ce91ee846ed\"" }
"If we use the Factor implementation, we get the same result, just slightly slower:"
{ $example "USING: byte-arrays checksums checksums.sha1 prettyprint ;" "\"hello world\" >byte-array sha1 checksum-bytes hex-string ." "\"2aae6c35c94fcfb415dbe95f408b9ce91ee846ed\"" } ;
ABOUT: "checksums.openssl"

28
extra/checksums/openssl/openssl-tests.factor Normal file
View File

@ -0,0 +1,28 @@
IN: checksums.openssl.tests
USING: byte-arrays checksums.openssl checksums tools.test
accessors kernel system ;
[
B{ 201 238 222 100 92 200 182 188 138 255 129 163 115 88 240 136 }
]
[
"Hello world from the openssl binding" >byte-array
"md5" <openssl-checksum> checksum-bytes
] unit-test
[
B{ 63 113 237 255 181 5 152 241 136 181 43 95 160 105 44 87 49 82 115 0 }
]
[
"Hello world from the openssl binding" >byte-array
"sha1" <openssl-checksum> checksum-bytes
] unit-test
[
"Bad checksum test" >byte-array
"no such checksum" <openssl-checksum>
checksum-bytes
] [ [ unknown-digest? ] [ name>> "no such checksum" = ] bi and ]
must-fail-with
[ ] [ image openssl-sha1 checksum-file drop ] unit-test

63
extra/checksums/openssl/openssl.factor Normal file
View File

@ -0,0 +1,63 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors byte-arrays alien.c-types kernel continuations
destructors sequences io openssl openssl.libcrypto checksums ;
IN: checksums.openssl
ERROR: unknown-digest name ;
TUPLE: openssl-checksum name ;
: openssl-md5 T{ openssl-checksum f "md5" } ;
: openssl-sha1 T{ openssl-checksum f "sha1" } ;
INSTANCE: openssl-checksum checksum
C: <openssl-checksum> openssl-checksum
<PRIVATE
TUPLE: evp-md-context handle ;
: <evp-md-context> ( -- ctx )
"EVP_MD_CTX" <c-object>
dup EVP_MD_CTX_init evp-md-context boa ;
M: evp-md-context dispose
handle>> EVP_MD_CTX_cleanup drop ;
: with-evp-md-context ( quot -- )
maybe-init-ssl >r <evp-md-context> r> with-disposal ; inline
: digest-named ( name -- md )
dup EVP_get_digestbyname
[ ] [ unknown-digest ] ?if ;
: set-digest ( name ctx -- )
handle>> swap digest-named f EVP_DigestInit_ex ssl-error ;
: checksum-loop ( ctx -- )
dup handle>>
4096 read-partial dup [
dup length EVP_DigestUpdate ssl-error
checksum-loop
] [ 3drop ] if ;
: digest-value ( ctx -- value )
handle>>
EVP_MAX_MD_SIZE <byte-array> 0 <int>
[ EVP_DigestFinal_ex ssl-error ] 2keep
*int memory>byte-array ;
PRIVATE>
M: openssl-checksum checksum-stream
name>> swap [
[
[ set-digest ]
[ checksum-loop ]
[ digest-value ]
tri
] with-evp-md-context
] with-input-stream ;

2
extra/checksums/sha1/sha1-docs.factor
View File

@ -2,7 +2,7 @@ USING: help.markup help.syntax ;
IN: checksums.sha1
HELP: sha1
{ $description "SHA1 checksum algorithm." } ;
{ $class-description "SHA1 checksum algorithm." } ;
ARTICLE: "checksums.sha1" "SHA1 checksum"
"The SHA1 checksum algorithm implements a one-way hash function. It is generally considered to be stronger than MD5, however there is a known algorithm for finding collisions more effectively than a brute-force search (" { $url "http://www.schneier.com/blog/archives/2005/02/sha1_broken.html" } ")."

2
extra/checksums/sha2/sha2-docs.factor
View File

@ -2,7 +2,7 @@ USING: help.markup help.syntax ;
IN: checksums.sha2
HELP: sha-256
{ $description "SHA-256 checksum algorithm." } ;
{ $class-description "SHA-256 checksum algorithm." } ;
ARTICLE: "checksums.sha2" "SHA2 checksum"
"The SHA2 checksum algorithm implements a one-way hash function. It is generally considered to be pretty strong."

4
extra/cocoa/application/application-docs.factor
View File

@ -27,8 +27,8 @@ HELP: with-cocoa
{ $description "Sets up an autorelease pool, initializes the " { $snippet "NSApplication" } " singleton, and calls the quotation." } ;
HELP: do-event
{ $values { "app" "an " { $snippet "NSApplication" } } }
{ $description "Processes any pending events in the queue. Does not block." } ;
{ $values { "app" "an " { $snippet "NSApplication" } } { "?" "a boolean" } }
{ $description "Processes a pending event in the queue, if any, returning a boolean indicating if there was one. Does not block." } ;
HELP: add-observer
{ $values { "observer" "an " { $snippet "NSObject" } } { "selector" string } { "name" "an " { $snippet "NSString" } } { "object" "an " { $snippet "NSObject" } } }

14
extra/cocoa/views/views.factor
View File

@ -74,3 +74,17 @@ PRIVATE>
-> locationInWindow f -> convertPoint:fromView:
dup NSPoint-x swap NSPoint-y
r> -> frame NSRect-h swap - 2array ;
USE: opengl.gl
USE: alien.syntax
: NSOpenGLCPSwapInterval 222 ;
LIBRARY: OpenGL
TYPEDEF: int CGLError
TYPEDEF: void* CGLContextObj
TYPEDEF: int CGLContextParameter
FUNCTION: CGLError CGLSetParameter ( CGLContextObj ctx, CGLContextParameter pname, GLint* params ) ;

7
extra/combinators/lib/lib-tests.factor
View File

@ -19,6 +19,13 @@ IN: combinators.lib.tests
[ { 1 2 } { 2 4 } { 3 8 } { 4 16 } { 5 32 } ] [ 1 2 3 4 5 [ dup 2^ 2array ] 5 napply ] unit-test
[ [ dup 2^ 2array ] 5 napply ] must-infer
[ { "xyc" "xyd" } ] [ "x" "y" { "c" "d" } [ 3append ] 2 nwith map ] unit-test
[ { "foo" "xbarx" } ]
[
{ "oof" "bar" } { [ reverse ] [ "x" swap "x" 3append ] } parallel-call
] unit-test
! &&
[ t ] [

16
extra/combinators/lib/lib.factor
View File

@ -4,7 +4,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel combinators fry namespaces quotations hashtables
sequences assocs arrays inference effects math math.ranges
arrays.lib shuffle macros bake continuations ;
arrays.lib shuffle macros continuations locals ;
IN: combinators.lib
@ -20,17 +20,15 @@ MACRO: nslip ( n -- ) dup saver [ call ] rot restorer 3append ;
MACRO: nkeep ( n -- )
[ ] [ 1+ ] [ ] tri
[ [ , ndup ] dip , -nrot , nslip ]
bake ;
'[ [ , ndup ] dip , -nrot , nslip ] ;
: 4keep ( w x y z quot -- w x y z ) 4 nkeep ; inline
MACRO: ncurry ( n -- ) [ curry ] n*quot ;
MACRO: nwith ( quot n -- )
tuck 1+ dup
[ , -nrot [ , nrot , call ] , ncurry ]
bake ;
MACRO:: nwith ( quot n -- )
[let | n' [ n 1+ ] |
[ n' -nrot [ n' nrot quot call ] n ncurry ] ] ;
MACRO: napply ( n -- )
2 [a,b]
@ -110,8 +108,8 @@ MACRO: switch ( quot -- )
! : pcall ( seq quots -- seq ) [ call ] 2map ;
MACRO: parallel-call ( quots -- )
[ [ unclip % r> dup >r push ] bake ] map concat
[ V{ } clone >r % drop r> >array ] bake ;
[ '[ [ unclip @ ] dip [ push ] keep ] ] map concat
'[ V{ } clone @ nip >array ] ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! map-call and friends

2
extra/concurrency/distributed/distributed-tests.factor
View File

@ -13,7 +13,7 @@ concurrency.messaging continuations ;
[ ] [ test-node dup 1array swap (start-node) ] unit-test
[ ] [ yield ] unit-test
[ ] [ 100 sleep ] unit-test
[ ] [
[

12
extra/concurrency/exchangers/exchangers.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel threads boxes ;
USING: kernel threads boxes accessors ;
IN: concurrency.exchangers
! Motivated by
@ -12,10 +12,10 @@ TUPLE: exchanger thread object ;
<box> <box> exchanger boa ;
: exchange ( obj exchanger -- newobj )
dup exchanger-thread box-full? [
dup exchanger-object box>
>r exchanger-thread box> resume-with r>
dup thread>> occupied>> [
dup object>> box>
>r thread>> box> resume-with r>
] [
[ exchanger-object >box ] keep
[ exchanger-thread >box ] curry "exchange" suspend
[ object>> >box ] keep
[ thread>> >box ] curry "exchange" suspend
] if ;

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

@ -1,7 +1,7 @@
IN: concurrency.mailboxes.tests
USING: concurrency.mailboxes concurrency.count-downs vectors
sequences threads tools.test math kernel strings namespaces
continuations calendar ;
continuations calendar destructors ;
[ V{ 1 2 3 } ] [
0 <vector>

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

@ -1,17 +1,13 @@
! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: concurrency.mailboxes
USING: dlists threads sequences continuations
USING: dlists threads sequences continuations destructors
namespaces random math quotations words kernel arrays assocs
init system concurrency.conditions accessors debugger ;
TUPLE: mailbox threads data closed ;
TUPLE: mailbox threads data disposed ;
: check-closed ( mailbox -- )
closed>> [ "Mailbox closed" throw ] when ; inline
M: mailbox dispose
t >>closed threads>> notify-all ;
M: mailbox dispose* threads>> notify-all ;
: <mailbox> ( -- mailbox )
<dlist> <dlist> f mailbox boa ;
@ -27,7 +23,7 @@ M: mailbox dispose
>r threads>> r> "mailbox" wait ;
: block-unless-pred ( mailbox timeout pred -- )
pick check-closed
pick check-disposed
pick data>> over dlist-contains? [
3drop
] [
@ -35,7 +31,7 @@ M: mailbox dispose
] if ; inline
: block-if-empty ( mailbox timeout -- mailbox )
over check-closed
over check-disposed
over mailbox-empty? [
2dup wait-for-mailbox block-if-empty
] [
@ -75,7 +71,7 @@ M: mailbox dispose
f swap mailbox-get-timeout? ; inline
: wait-for-close-timeout ( mailbox timeout -- )
over closed>>
over disposed>>
[ 2drop ] [ 2dup wait-for-mailbox wait-for-close-timeout ] if ;
: wait-for-close ( mailbox -- )

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

@ -3,7 +3,7 @@
USING: alien alien.c-types alien.strings alien.syntax kernel
math sequences namespaces assocs init accessors continuations
combinators core-foundation core-foundation.run-loop
io.encodings.utf8 ;
io.encodings.utf8 destructors ;
IN: core-foundation.fsevents
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
@ -187,7 +187,7 @@ SYMBOL: event-stream-callbacks
dup [ call drop ] [ 3drop ] if
] alien-callback ;
TUPLE: event-stream info handle closed ;
TUPLE: event-stream info handle disposed ;
: <event-stream> ( quot paths latency flags -- event-stream )
>r >r >r
@ -197,13 +197,10 @@ TUPLE: event-stream info handle closed ;
dup enable-event-stream
f event-stream boa ;
M: event-stream dispose
dup closed>> [ drop ] [
t >>closed
{
[ info>> remove-event-source-callback ]
[ handle>> disable-event-stream ]
[ handle>> FSEventStreamInvalidate ]
[ handle>> FSEventStreamRelease ]
} cleave
] if ;
M: event-stream dispose*
{
[ info>> remove-event-source-callback ]
[ handle>> disable-event-stream ]
[ handle>> FSEventStreamInvalidate ]
[ handle>> FSEventStreamRelease ]
} cleave ;

4
extra/db/db.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes continuations kernel math
USING: arrays assocs classes continuations destructors kernel math
namespaces sequences sequences.lib classes.tuple words strings
tools.walker accessors combinators.lib ;
IN: db
@ -25,7 +25,7 @@ GENERIC: make-db* ( seq class -- db )
GENERIC: db-open ( db -- db )
HOOK: db-close db ( handle -- )
: dispose-statements ( seq -- ) [ dispose drop ] assoc-each ;
: dispose-statements ( assoc -- ) values dispose-each ;
: dispose-db ( db -- )
dup db [

4
extra/db/mysql/mysql.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for license.
USING: alien continuations io kernel prettyprint sequences
db db.mysql.ffi ;
USING: alien continuations destructors io kernel prettyprint
sequences db db.mysql.ffi ;
IN: db.mysql
TUPLE: mysql-db handle host user password db port ;

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