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-03-25 19:43:09 -04:00
parent b8434788bd c106a35b38
commit 514c626e56
41 changed files with 771 additions and 547 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
core/bootstrap/image/image.factor
View File

@ -348,8 +348,10 @@ M: curry '
: emit-global ( -- )
[
{
dictionary source-files
typemap builtins class<map class-map update-map
dictionary source-files builtins
update-map class<-cache class-not-cache
classes-intersect-cache class-and-cache
class-or-cache
} [ dup get swap bootstrap-word set ] each
] H{ } make-assoc
bootstrap-global set

12
core/bootstrap/primitives.factor
View File

@ -31,6 +31,10 @@ crossref off
H{ } clone dictionary set
H{ } clone changed-words set
H{ } clone root-cache set
H{ } clone source-files set
H{ } clone update-map set
num-types get f <array> builtins set
init-caches
! Vocabulary for slot accessors
"accessors" create-vocab drop
@ -93,11 +97,6 @@ call
"vectors.private"
} [ create-vocab drop ] each
H{ } clone source-files set
H{ } clone update-map set
H{ } clone class<map set
H{ } clone class-map set
! Builtin classes
: builtin-predicate-quot ( class -- quot )
[
@ -130,9 +129,6 @@ H{ } clone class-map set
dup define-builtin-predicate
r> define-builtin-slots ;
H{ } clone typemap set
num-types get f <array> builtins set
! Forward definitions
"object" "kernel" create t "class" set-word-prop
"object" "kernel" create union-class "metaclass" set-word-prop

55
core/classes/algebra/algebra-docs.factor Executable file
View File

@ -0,0 +1,55 @@
USING: help.markup help.syntax kernel classes ;
IN: classes.algebra
ARTICLE: "class-operations" "Class operations"
"Set-theoretic operations on classes:"
{ $subsection class< }
{ $subsection class-and }
{ $subsection class-or }
{ $subsection classes-intersect? }
"Topological sort:"
{ $subsection sort-classes }
{ $subsection min-class }
"Low-level implementation detail:"
{ $subsection class-types }
{ $subsection flatten-class }
{ $subsection flatten-builtin-class }
{ $subsection class-types }
{ $subsection class-tags } ;
HELP: flatten-builtin-class
{ $values { "class" class } { "assoc" "an assoc whose keys are classes" } }
{ $description "Outputs a set of tuple classes whose union is the smallest cover of " { $snippet "class" } " intersected with " { $link tuple } "." } ;
HELP: flatten-class
{ $values { "class" class } { "assoc" "an assoc whose keys are classes" } }
{ $description "Outputs a set of builtin and tuple classes whose union is the smallest cover of " { $snippet "class" } "." } ;
HELP: class-types
{ $values { "class" class } { "seq" "an increasing sequence of integers" } }
{ $description "Outputs a sequence of builtin type numbers whose instances can possibly be instances of the given class." } ;
HELP: class<
{ $values { "class1" "a class" } { "class2" "a class" } { "?" "a boolean" } }
{ $description "Tests if all instances of " { $snippet "class1" } " are also instances of " { $snippet "class2" } "." }
{ $notes "Classes are partially ordered. This means that if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class1" } ", then " { $snippet "class1 = class2" } ". Also, if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class3" } ", then " { $snippet "class1 <= class3" } "." } ;
HELP: sort-classes
{ $values { "seq" "a sequence of class" } { "newseq" "a new seqence of classes" } }
{ $description "Outputs a topological sort of a sequence of classes. Larger classes come before their subclasses." } ;
HELP: class-or
{ $values { "class1" class } { "class2" class } { "class" class } }
{ $description "Outputs the smallest anonymous class containing both " { $snippet "class1" } " and " { $snippet "class2" } "." } ;
HELP: class-and
{ $values { "class1" class } { "class2" class } { "class" class } }
{ $description "Outputs the largest anonymous class contained in both " { $snippet "class1" } " and " { $snippet "class2" } "." } ;
HELP: classes-intersect?
{ $values { "class1" class } { "class2" class } { "?" "a boolean" } }
{ $description "Tests if two classes have a non-empty intersection. If the intersection is empty, no object can be an instance of both classes at once." } ;
HELP: min-class
{ $values { "class" class } { "seq" "a sequence of class words" } { "class/f" "a class word or " { $link f } } }
{ $description "If all classes in " { $snippet "seq" } " that intersect " { $snippet "class" } " are subtypes of " { $snippet "class" } ", outputs the last such element of " { $snippet "seq" } ". If any conditions fail to hold, outputs " { $link f } "." } ;

201
core/classes/algebra/algebra-tests.factor Executable file
View File

@ -0,0 +1,201 @@
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 ;
: class= [ class< ] 2keep swap class< and ;
: class-and* >r class-and r> class= ;
: class-or* >r class-or r> class= ;
[ t ] [ object object object class-and* ] unit-test
[ t ] [ fixnum object fixnum class-and* ] unit-test
[ t ] [ object fixnum fixnum class-and* ] unit-test
[ t ] [ fixnum fixnum fixnum class-and* ] unit-test
[ t ] [ fixnum integer fixnum class-and* ] unit-test
[ t ] [ integer fixnum fixnum class-and* ] unit-test
[ t ] [ vector fixnum null class-and* ] unit-test
[ t ] [ number object number class-and* ] unit-test
[ t ] [ object number number class-and* ] unit-test
[ t ] [ slice reversed null class-and* ] unit-test
[ t ] [ general-t \ f null class-and* ] unit-test
[ t ] [ general-t \ f object class-or* ] unit-test
TUPLE: first-one ;
TUPLE: second-one ;
UNION: both first-one union-class ;
[ t ] [ both tuple classes-intersect? ] unit-test
[ t ] [ vector virtual-sequence null class-and* ] unit-test
[ f ] [ vector virtual-sequence classes-intersect? ] unit-test
[ t ] [ number vector class-or sequence classes-intersect? ] unit-test
[ f ] [ number vector class-and sequence classes-intersect? ] unit-test
[ t ] [ \ fixnum \ integer class< ] unit-test
[ t ] [ \ fixnum \ fixnum class< ] unit-test
[ f ] [ \ integer \ fixnum class< ] unit-test
[ t ] [ \ integer \ object class< ] unit-test
[ f ] [ \ integer \ null class< ] unit-test
[ t ] [ \ null \ object class< ] unit-test
[ t ] [ \ generic \ word class< ] unit-test
[ f ] [ \ word \ generic class< ] unit-test
[ f ] [ \ reversed \ slice class< ] unit-test
[ f ] [ \ slice \ reversed class< ] unit-test
PREDICATE: word no-docs "documentation" word-prop not ;
UNION: no-docs-union no-docs integer ;
[ t ] [ no-docs no-docs-union class< ] unit-test
[ f ] [ no-docs-union no-docs class< ] unit-test
TUPLE: a ;
TUPLE: b ;
UNION: c a b ;
[ t ] [ \ c \ tuple class< ] unit-test
[ f ] [ \ tuple \ c class< ] unit-test
[ t ] [ \ tuple-class \ class class< ] unit-test
[ f ] [ \ class \ tuple-class class< ] unit-test
TUPLE: delegate-clone ;
[ t ] [ \ null \ delegate-clone class< ] unit-test
[ f ] [ \ object \ delegate-clone class< ] unit-test
[ f ] [ \ object \ delegate-clone class< ] unit-test
[ t ] [ \ delegate-clone \ tuple class< ] unit-test
[ f ] [ \ tuple \ delegate-clone class< ] unit-test
TUPLE: a1 ;
TUPLE: b1 ;
TUPLE: c1 ;
UNION: x1 a1 b1 ;
UNION: y1 a1 c1 ;
UNION: z1 b1 c1 ;
[ f ] [ z1 x1 y1 class-and class< ] unit-test
[ t ] [ x1 y1 class-and a1 class< ] unit-test
[ f ] [ y1 z1 class-and x1 classes-intersect? ] unit-test
[ f ] [ b1 c1 class-or a1 b1 class-or a1 c1 class-and class-and class< ] unit-test
[ t ] [ a1 b1 class-or a1 c1 class-or class-and a1 class< ] unit-test
[ f ] [ a1 c1 class-or b1 c1 class-or class-and a1 b1 class-or classes-intersect? ] unit-test
[ f ] [ growable hi-tag classes-intersect? ] unit-test
[ t ] [
growable tuple sequence class-and class<
] unit-test
[ t ] [
growable assoc class-and tuple class<
] unit-test
[ t ] [ object \ f \ f class-not class-or class< ] unit-test
[ t ] [ fixnum class-not integer class-and bignum class= ] unit-test
[ f ] [ integer integer class-not classes-intersect? ] unit-test
[ t ] [ array number class-not class< ] unit-test
[ f ] [ bignum number class-not class< ] unit-test
[ vector ] [ vector class-not class-not ] unit-test
[ t ] [ fixnum fixnum bignum class-or class< ] unit-test
[ f ] [ fixnum class-not integer class-and array class< ] unit-test
[ f ] [ fixnum class-not integer class< ] unit-test
[ f ] [ number class-not array class< ] unit-test
[ f ] [ fixnum class-not array class< ] unit-test
[ t ] [ number class-not integer class-not class< ] unit-test
[ t ] [ vector array class-not class-and vector class= ] unit-test
[ f ] [ fixnum class-not number class-and array classes-intersect? ] unit-test
[ f ] [ fixnum class-not integer class< ] unit-test
[ t ] [ null class-not object class= ] unit-test
[ t ] [ object class-not null class= ] unit-test
[ f ] [ object class-not object class= ] unit-test
[ f ] [ null class-not null class= ] unit-test
! Test for hangs?
: random-class classes random ;
: random-op
{
class-and
class-or
class-not
} random ;
10 [
[ ] [
20 [ drop random-op ] map >quotation
[ infer effect-in [ random-class ] times ] keep
call
drop
] unit-test
] times
: random-boolean
{ t f } random ;
: boolean>class
object null ? ;
: random-boolean-op
{
and
or
not
xor
} random ;
: class-xor [ class-or ] 2keep class-and class-not class-and ;
: boolean-op>class-op
{
{ and class-and }
{ or class-or }
{ not class-not }
{ xor class-xor }
} at ;
20 [
[ t ] [
20 [ drop random-boolean-op ] [ ] map-as dup .
[ infer effect-in [ drop random-boolean ] map dup . ] keep
[ >r [ ] each r> call ] 2keep
>r [ boolean>class ] each r> [ boolean-op>class-op ] map call object class=
=
] unit-test
] times

233
core/classes/algebra/algebra.factor Executable file
View File

@ -0,0 +1,233 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel classes combinators accessors sequences arrays
vectors assocs namespaces words sorting layouts math hashtables
;
IN: classes.algebra
: 2cache ( key1 key2 assoc quot -- value )
>r >r 2array r> [ first2 ] r> compose cache ; inline
DEFER: (class<)
: class< ( first second -- ? )
class<-cache get [ (class<) ] 2cache ;
DEFER: (class-not)
: class-not ( class -- complement )
class-not-cache get [ (class-not) ] cache ;
DEFER: (classes-intersect?) ( first second -- ? )
: classes-intersect? ( first second -- ? )
classes-intersect-cache get [ (classes-intersect?) ] 2cache ;
DEFER: (class-and)
: class-and ( first second -- class )
class-and-cache get [ (class-and) ] 2cache ;
DEFER: (class-or)
: class-or ( first second -- class )
class-or-cache get [ (class-or) ] 2cache ;
TUPLE: anonymous-union members ;
C: <anonymous-union> anonymous-union
TUPLE: anonymous-intersection members ;
C: <anonymous-intersection> anonymous-intersection
TUPLE: anonymous-complement class ;
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 -- ? )
>r members>> r> [ class< ] curry all? ;
: right-anonymous-union< ( first second -- ? )
members>> [ class< ] with contains? ;
: left-anonymous-intersection< ( first second -- ? )
>r members>> r> [ class< ] curry contains? ;
: right-anonymous-intersection< ( first second -- ? )
members>> [ class< ] with all? ;
: anonymous-complement< ( first second -- ? )
[ class>> ] 2apply swap class< ;
: (class<) ( first second -- -1/0/1 )
{
{ [ 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 anonymous-complement? ] [ 2drop f ] }
{ [ over members ] [ left-union-class< ] }
{ [ dup anonymous-union? ] [ right-anonymous-union< ] }
{ [ dup anonymous-intersection? ] [ right-anonymous-intersection< ] }
{ [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }
{ [ dup members ] [ right-union-class< ] }
{ [ over superclass ] [ superclass< ] }
{ [ t ] [ 2drop f ] }
} cond ;
: anonymous-union-intersect? ( first second -- ? )
members>> [ classes-intersect? ] with contains? ;
: anonymous-intersection-intersect? ( first second -- ? )
members>> [ 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 ] }
{ [ over builtin-class? ] [ 2drop f ] }
{ [ over tuple-class? ] [ [ class< ] 2keep swap class< or ] }
{ [ t ] [ swap classes-intersect? ] }
} cond ;
: builtin-class-intersect? ( first second -- ? )
{
{ [ 2dup eq? ] [ 2drop t ] }
{ [ over builtin-class? ] [ 2drop f ] }
{ [ t ] [ swap classes-intersect? ] }
} cond ;
: (classes-intersect?) ( first second -- ? )
{
{ [ 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 )
members>> [ class-and ] with map <anonymous-union> ;
: left-anonymous-intersection-and ( first second -- class )
>r members>> r> add <anonymous-intersection> ;
: right-anonymous-intersection-and ( first second -- class )
members>> swap add <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 ] }
{ [ t ] [ 2array <anonymous-intersection> ] }
} cond ;
: left-anonymous-union-or ( first second -- class )
>r members>> r> add <anonymous-union> ;
: right-anonymous-union-or ( first second -- class )
members>> swap add <anonymous-union> ;
: (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 ] }
{ [ t ] [ 2array <anonymous-union> ] }
} cond ;
: (class-not) ( class -- complement )
{
{ [ dup anonymous-complement? ] [ class>> ] }
{ [ dup object eq? ] [ drop null ] }
{ [ dup null eq? ] [ drop object ] }
{ [ t ] [ <anonymous-complement> ] }
} cond ;
: largest-class ( seq -- n elt )
dup [
[ 2dup class< >r swap class< not r> and ]
with subset empty?
] curry find [ "Topological sort failed" throw ] unless* ;
: sort-classes ( seq -- newseq )
>vector
[ dup empty? not ]
[ dup largest-class >r over delete-nth r> ]
[ ] unfold nip ;
: min-class ( class seq -- class/f )
[ dupd classes-intersect? ] subset dup empty? [
2drop f
] [
tuck [ class< ] with all? [ peek ] [ drop f ] if
] if ;
: (flatten-class) ( class -- )
{
{ [ dup tuple-class? ] [ dup set ] }
{ [ dup builtin-class? ] [ dup set ] }
{ [ dup members ] [ members [ (flatten-class) ] each ] }
{ [ dup superclass ] [ superclass (flatten-class) ] }
{ [ t ] [ drop ] }
} cond ;
: flatten-class ( class -- assoc )
[ (flatten-class) ] H{ } make-assoc ;
: class-hashes ( class -- seq )
flatten-class keys [
dup builtin-class?
[ "type" word-prop ] [ hashcode ] if
] map ;
: flatten-builtin-class ( class -- assoc )
flatten-class [
dup tuple class< [ 2drop tuple tuple ] when
] assoc-map ;
: class-types ( class -- seq )
flatten-builtin-class keys
[ "type" word-prop ] map natural-sort ;
: class-tags ( class -- tag/f )
class-types [
dup num-tags get >=
[ drop object tag-number ] when
] map prune ;

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

@ -12,21 +12,6 @@ $nl
{ $subsection builtin-class? }
"See " { $link "type-index" } " for a list of built-in classes." ;
ARTICLE: "class-operations" "Class operations"
"Set-theoretic operations on classes:"
{ $subsection class< }
{ $subsection class-and }
{ $subsection class-or }
{ $subsection classes-intersect? }
"Topological sort:"
{ $subsection sort-classes }
{ $subsection min-class }
"Low-level implementation detail:"
{ $subsection types }
{ $subsection flatten-class }
{ $subsection flatten-builtin-class }
{ $subsection flatten-union-class } ;
ARTICLE: "class-predicates" "Class predicate words"
"With a handful of exceptions, each class has a membership predicate word, named " { $snippet { $emphasis "class" } "?" } " . A quotation calling this predicate is stored in the " { $snippet "\"predicate\"" } " word property."
$nl
@ -93,15 +78,9 @@ HELP: tuple-class
{ $class-description "The class of tuple class words." }
{ $examples { $example "USING: classes prettyprint ;" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ;
HELP: typemap
{ $var-description "Hashtable mapping unions to class words, used to implement " { $link class-and } " and " { $link class-or } "." } ;
HELP: builtins
{ $var-description "Vector mapping type numbers to builtin class words." } ;
HELP: class<map
{ $var-description "Hashtable mapping each class to a set of classes which are contained in that class under the " { $link (class<) } " relation. The " { $link class< } " word uses this hashtable to avoid frequent expensive calls to " { $link (class<) } "." } ;
HELP: update-map
{ $var-description "Hashtable mapping each class to a set of classes defined in terms of this class. The " { $link define-class } " word uses this information to update generic words when classes are redefined." } ;
@ -121,70 +100,13 @@ $low-level-note ;
HELP: superclass
{ $values { "class" class } { "super" class } }
{ $description "Outputs the superclass of a class. All instances of this class are also instances of the superclass." }
{ $notes "If " { $link class< } " yields that one class is a subtype of another, it does not imply that a superclass relation is involved. The superclass relation is a technical implementation detail of predicate and tuple classes." } ;
{ $description "Outputs the superclass of a class. All instances of this class are also instances of the superclass." } ;
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: flatten-union-class
{ $values { "class" class } { "assoc" "an assoc whose keys are classes" } }
{ $description "Outputs the set of classes whose union is equal to " { $snippet "class" } ". Unions are expanded recursively so the output assoc does not contain any union classes. However, it may contain predicate classes whose superclasses are unions." } ;
HELP: flatten-builtin-class
{ $values { "class" class } { "assoc" "an assoc whose keys are classes" } }
{ $description "Outputs a set of tuple classes whose union is the smallest cover of " { $snippet "class" } " intersected with " { $link tuple } "." } ;
HELP: flatten-class
{ $values { "class" class } { "assoc" "an assoc whose keys are classes" } }
{ $description "Outputs a set of builtin and tuple classes whose union is the smallest cover of " { $snippet "class" } "." } ;
HELP: types
{ $values { "class" class } { "seq" "an increasing sequence of integers" } }
{ $description "Outputs a sequence of builtin type numbers whose instances can possibly be instances of the given class." } ;
HELP: class-empty?
{ $values { "class" "a class" } { "?" "a boolean" } }
{ $description "Tests if a class is a union class with no members." }
{ $examples { $example "USING: classes kernel prettyprint ;" "null class-empty? ." "t" } } ;
HELP: (class<)
{ $values { "class1" "a class" } { "class2" "a class" } { "?" "a boolean" } }
{ $description "Performs the calculation for " { $link class< } ". There is never any reason to call this word from user code since " { $link class< } " outputs identical values and caches results for better performance." } ;
HELP: class<
{ $values { "class1" "a class" } { "class2" "a class" } { "?" "a boolean" } }
{ $description "Tests if all instances of " { $snippet "class1" } " are also instances of " { $snippet "class2" } "." }
{ $notes "Classes are partially ordered. This means that if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class1" } ", then " { $snippet "class1 = class2" } ". Also, if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class3" } ", then " { $snippet "class1 <= class3" } "." } ;
HELP: sort-classes
{ $values { "seq" "a sequence of class" } { "newseq" "a new seqence of classes" } }
{ $description "Outputs a topological sort of a sequence of classes. Larger classes come before their subclasses." } ;
HELP: lookup-union
{ $values { "classes" "a hashtable mapping class words to themselves" } { "class" class } }
{ $description "Given a set of classes represented as a hashtable with equal keys and values, looks up a previously-defined union class having those members. If no union is defined, outputs " { $link object } "." } ;
{ class-and class-or lookup-union } related-words
HELP: class-or
{ $values { "class1" class } { "class2" class } { "class" class } }
{ $description "Outputs the smallest known class containing both " { $snippet "class1" } " and " { $snippet "class2" } "." } ;
HELP: class-and
{ $values { "class1" class } { "class2" class } { "class" class } }
{ $description "Outputs the largest known class contained in both " { $snippet "class1" } " and " { $snippet "class2" } ". If the intersection is non-empty but no union class with those exact members is defined, outputs " { $link object } ". If the intersection is empty, outputs " { $link null } "." } ;
HELP: classes-intersect?
{ $values { "class1" class } { "class2" class } { "?" "a boolean" } }
{ $description "Tests if two classes have a non-empty intersection. If the intersection is empty, no object can be an instance of both classes at once." } ;
HELP: min-class
{ $values { "class" class } { "seq" "a sequence of class words" } { "class/f" "a class word or " { $link f } } }
{ $description "If all classes in " { $snippet "seq" } " that intersect " { $snippet "class" } " are subtypes of " { $snippet "class" } ", outputs the last such element of " { $snippet "seq" } ". If any conditions fail to hold, outputs " { $link f } "." } ;
HELP: define-class
{ $values { "word" word } { "members" "a sequence of class words" } { "superclass" class } { "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 typemap } " and " { $link class<map } "." }
{ $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 ;

85
core/classes/classes-tests.factor
View File

@ -2,64 +2,10 @@ USING: alien arrays definitions generic assocs hashtables io
kernel math namespaces parser prettyprint sequences strings
tools.test vectors words quotations classes
classes.private classes.union classes.mixin classes.predicate
vectors definitions source-files compiler.units ;
classes.algebra vectors definitions source-files
compiler.units ;
IN: classes.tests
H{ } "s" set
[ ] [ 1 2 "s" get push-at ] unit-test
[ 1 ] [ 2 "s" get at first ] unit-test
[ ] [ 1 2 "s" get pop-at ] unit-test
[ t ] [ 2 "s" get at empty? ] unit-test
[ object ] [ object object class-and ] unit-test
[ fixnum ] [ fixnum object class-and ] unit-test
[ fixnum ] [ object fixnum class-and ] unit-test
[ fixnum ] [ fixnum fixnum class-and ] unit-test
[ fixnum ] [ fixnum integer class-and ] unit-test
[ fixnum ] [ integer fixnum class-and ] unit-test
[ null ] [ vector fixnum class-and ] unit-test
[ number ] [ number object class-and ] unit-test
[ number ] [ object number class-and ] unit-test
[ null ] [ slice reversed class-and ] unit-test
[ null ] [ general-t \ f class-and ] unit-test
[ object ] [ general-t \ f class-or ] unit-test
TUPLE: first-one ;
TUPLE: second-one ;
UNION: both first-one union-class ;
[ t ] [ both tuple classes-intersect? ] unit-test
[ null ] [ vector virtual-sequence class-and ] unit-test
[ f ] [ vector virtual-sequence classes-intersect? ] unit-test
[ t ] [ \ fixnum \ integer class< ] unit-test
[ t ] [ \ fixnum \ fixnum class< ] unit-test
[ f ] [ \ integer \ fixnum class< ] unit-test
[ t ] [ \ integer \ object class< ] unit-test
[ f ] [ \ integer \ null class< ] unit-test
[ t ] [ \ null \ object class< ] unit-test
[ t ] [ \ generic \ word class< ] unit-test
[ f ] [ \ word \ generic class< ] unit-test
[ f ] [ \ reversed \ slice class< ] unit-test
[ f ] [ \ slice \ reversed class< ] unit-test
PREDICATE: word no-docs "documentation" word-prop not ;
UNION: no-docs-union no-docs integer ;
[ t ] [ no-docs no-docs-union class< ] unit-test
[ f ] [ no-docs-union no-docs class< ] unit-test
TUPLE: a ;
TUPLE: b ;
UNION: c a b ;
[ t ] [ \ c \ tuple class< ] unit-test
[ f ] [ \ tuple \ c class< ] unit-test
! DEFER: bah
! FORGET: bah
UNION: bah fixnum alien ;
@ -76,16 +22,12 @@ M: union-1 generic-update-test drop "union-1" ;
[ t ] [ union-1 number class< ] unit-test
[ "union-1" ] [ 1.0 generic-update-test ] unit-test
[ union-1 ] [ fixnum float class-or ] unit-test
"IN: classes.tests USE: math USE: arrays UNION: union-1 rational array ;" eval
[ t ] [ bignum union-1 class< ] unit-test
[ f ] [ union-1 number class< ] unit-test
[ "union-1" ] [ { 1.0 } generic-update-test ] unit-test
[ object ] [ fixnum float class-or ] unit-test
"IN: classes.tests USE: math PREDICATE: integer union-1 even? ;" eval
[ f ] [ union-1 union-class? ] unit-test
@ -118,6 +60,9 @@ M: assoc-mixin collection-size assoc-size ;
[ 2 ] [ H{ { 1 2 } { 2 3 } } collection-size ] unit-test
! Test mixing in of new classes after the fact
DEFER: mx1
FORGET: mx1
MIXIN: mx1
INSTANCE: integer mx1
@ -131,12 +76,8 @@ INSTANCE: integer mx1
[ t ] [ array mx1 class< ] unit-test
[ f ] [ mx1 number class< ] unit-test
[ mx1 ] [ array integer class-or ] unit-test
[ \ mx1 forget ] with-compilation-unit
[ f ] [ array integer class-or mx1 = ] unit-test
! Empty unions were causing problems
GENERIC: empty-union-test
@ -155,28 +96,12 @@ UNION: redefine-bug-2 redefine-bug-1 quotation ;
[ t ] [ fixnum redefine-bug-2 class< ] unit-test
[ t ] [ quotation redefine-bug-2 class< ] unit-test
[ redefine-bug-2 ] [ fixnum quotation class-or ] unit-test
[ ] [ "IN: classes.tests USE: math UNION: redefine-bug-1 bignum ;" eval ] unit-test
[ t ] [ bignum redefine-bug-1 class< ] unit-test
[ f ] [ fixnum redefine-bug-2 class< ] unit-test
[ t ] [ bignum redefine-bug-2 class< ] unit-test
[ f ] [ fixnum quotation class-or redefine-bug-2 eq? ] unit-test
[ redefine-bug-2 ] [ bignum quotation class-or ] unit-test
! Another issue similar to the above
UNION: forget-class-bug-1 integer ;
UNION: forget-class-bug-2 forget-class-bug-1 dll ;
[
\ forget-class-bug-1 forget
\ forget-class-bug-2 forget
] with-compilation-unit
[ f ] [ forget-class-bug-1 typemap get values [ memq? ] with contains? ] unit-test
[ f ] [ forget-class-bug-2 typemap get values [ memq? ] with contains? ] unit-test
USE: io.streams.string

257
core/classes/classes.factor
View File

@ -1,15 +1,32 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays definitions assocs kernel kernel.private
slots.private namespaces sequences strings words vectors math
quotations combinators sorting effects graphs vocabs ;
IN: classes
USING: arrays definitions assocs kernel
kernel.private slots.private namespaces sequences strings words
vectors math quotations combinators sorting effects graphs ;
SYMBOL: class<-cache
SYMBOL: class-not-cache
SYMBOL: classes-intersect-cache
SYMBOL: class-and-cache
SYMBOL: class-or-cache
: init-caches ( -- )
H{ } clone class<-cache set
H{ } clone class-not-cache set
H{ } clone classes-intersect-cache set
H{ } clone class-and-cache set
H{ } clone class-or-cache set ;
: reset-caches ( -- )
class<-cache get clear-assoc
class-not-cache get clear-assoc
classes-intersect-cache get clear-assoc
class-and-cache get clear-assoc
class-or-cache get clear-assoc ;
PREDICATE: word class ( obj -- ? ) "class" word-prop ;
SYMBOL: typemap
SYMBOL: class-map
SYMBOL: class<map
SYMBOL: update-map
SYMBOL: builtins
@ -19,7 +36,7 @@ PREDICATE: class builtin-class
PREDICATE: class tuple-class
"metaclass" word-prop tuple-class eq? ;
: classes ( -- seq ) class<map get keys ;
: classes ( -- seq ) all-words [ class? ] subset ;
: type>class ( n -- class ) builtins get-global nth ;
@ -37,146 +54,12 @@ PREDICATE: word predicate "predicating" word-prop >boolean ;
r> predicate-effect define-declared ;
: superclass ( class -- super )
"superclass" word-prop ;
#! Output f for non-classes to work with algebra code
dup class? [ "superclass" word-prop ] [ drop f ] if ;
: members ( class -- seq ) "members" word-prop ;
: class-empty? ( class -- ? ) members dup [ empty? ] when ;
: (flatten-union-class) ( class -- )
dup members [
[ (flatten-union-class) ] each
] [
dup set
] ?if ;
: flatten-union-class ( class -- assoc )
[ (flatten-union-class) ] H{ } make-assoc ;
: (flatten-class) ( class -- )
{
{ [ dup tuple-class? ] [ dup set ] }
{ [ dup builtin-class? ] [ dup set ] }
{ [ dup members ] [ members [ (flatten-class) ] each ] }
{ [ dup superclass ] [ superclass (flatten-class) ] }
{ [ t ] [ drop ] }
} cond ;
: flatten-class ( class -- assoc )
[ (flatten-class) ] H{ } make-assoc ;
: class-hashes ( class -- seq )
flatten-class keys [
dup builtin-class?
[ "type" word-prop ] [ hashcode ] if
] map ;
: (flatten-builtin-class) ( class -- )
{
{ [ dup members ] [ members [ (flatten-builtin-class) ] each ] }
{ [ dup superclass ] [ superclass (flatten-builtin-class) ] }
{ [ t ] [ dup set ] }
} cond ;
: flatten-builtin-class ( class -- assoc )
[ (flatten-builtin-class) ] H{ } make-assoc ;
: types ( class -- seq )
flatten-builtin-class keys
[ "type" word-prop ] map natural-sort ;
: class< ( class1 class2 -- ? ) swap class<map get at key? ;
<PRIVATE
DEFER: (class<)
: superclass< ( cls1 cls2 -- ? )
>r superclass r> 2dup and [ (class<) ] [ 2drop f ] if ;
: union-class< ( cls1 cls2 -- ? )
[ flatten-union-class ] 2apply keys
[ nip [ (class<) ] with contains? ] curry assoc-all? ;
: (class<) ( class1 class2 -- ? )
{
{ [ 2dup eq? ] [ 2drop t ] }
{ [ over class-empty? ] [ 2drop t ] }
{ [ 2dup superclass< ] [ 2drop t ] }
{ [ 2dup [ members not ] both? ] [ 2drop f ] }
{ [ t ] [ union-class< ] }
} cond ;
: lookup-union ( classes -- class )
typemap get at dup empty? [ drop object ] [ first ] if ;
: lookup-tuple-union ( classes -- class )
class-map get at dup empty? [ drop object ] [ first ] if ;
! : (class-or) ( class class -- class )
! [ flatten-builtin-class ] 2apply union lookup-union ;
!
! : (class-and) ( class class -- class )
! [ flatten-builtin-class ] 2apply intersect lookup-union ;
: class-or-fixup ( set set -- set )
union
tuple over key?
[ [ drop tuple-class? not ] assoc-subset ] when ;
: (class-or) ( class class -- class )
[ flatten-class ] 2apply class-or-fixup lookup-tuple-union ;
: (class-and) ( class class -- class )
2dup [ tuple swap class< ] either? [
[ flatten-builtin-class ] 2apply
intersect lookup-union
] [
[ flatten-class ] 2apply
intersect lookup-tuple-union
] if ;
: tuple-class-and ( class1 class2 -- class )
dupd eq? [ drop null ] unless ;
: largest-class ( seq -- n elt )
dup [
[ 2dup class< >r swap class< not r> and ]
with subset empty?
] curry find [ "Topological sort failed" throw ] unless* ;
PRIVATE>
: sort-classes ( seq -- newseq )
>vector
[ dup empty? not ]
[ dup largest-class >r over delete-nth r> ]
[ ] unfold nip ;
: class-or ( class1 class2 -- class )
{
{ [ 2dup class< ] [ nip ] }
{ [ 2dup swap class< ] [ drop ] }
{ [ t ] [ (class-or) ] }
} cond ;
: class-and ( class1 class2 -- class )
{
{ [ 2dup class< ] [ drop ] }
{ [ 2dup swap class< ] [ nip ] }
{ [ 2dup [ tuple-class? ] both? ] [ tuple-class-and ] }
{ [ t ] [ (class-and) ] }
} cond ;
: classes-intersect? ( class1 class2 -- ? )
class-and class-empty? not ;
: min-class ( class seq -- class/f )
[ dupd classes-intersect? ] subset dup empty? [
2drop f
] [
tuck [ class< ] with all? [ peek ] [ drop f ] if
] if ;
: members ( class -- seq )
#! Output f for non-classes to work with algebra code
dup class? [ "members" word-prop ] [ drop f ] if ;
GENERIC: reset-class ( class -- )
@ -184,36 +67,9 @@ M: word reset-class drop ;
<PRIVATE
! class<map
: bigger-classes ( class -- seq )
classes [ (class<) ] with subset ;
: bigger-classes+ ( class -- )
[ bigger-classes [ dup ] H{ } map>assoc ] keep
class<map get set-at ;
: bigger-classes- ( class -- )
class<map get delete-at ;
: smaller-classes ( class -- seq )
classes swap [ (class<) ] curry subset ;
: smaller-classes+ ( class -- )
dup smaller-classes class<map get add-vertex ;
: smaller-classes- ( class -- )
dup smaller-classes class<map get remove-vertex ;
: class<map+ ( class -- )
H{ } clone over class<map get set-at
dup smaller-classes+ bigger-classes+ ;
: class<map- ( class -- )
dup smaller-classes- bigger-classes- ;
! update-map
: class-uses ( class -- seq )
[ dup members % superclass [ , ] when* ] { } make ;
dup members swap superclass [ add ] when* ;
: class-usages ( class -- assoc )
[ update-map get at ] closure ;
@ -224,47 +80,6 @@ M: word reset-class drop ;
: update-map- ( class -- )
dup class-uses update-map get remove-vertex ;
! typemap
: push-at ( value key assoc -- )
2dup at* [
2nip push
] [
drop >r >r 1vector r> r> set-at
] if ;
: typemap+ ( class -- )
dup flatten-builtin-class typemap get push-at ;
: pop-at ( value key assoc -- )
at* [ delete ] [ 2drop ] if ;
: typemap- ( class -- )
dup flatten-builtin-class typemap get pop-at ;
! class-map
: class-map+ ( class -- )
dup flatten-class class-map get push-at ;
: class-map- ( class -- )
dup flatten-class class-map get pop-at ;
! Class definition
: cache-class ( class -- )
dup typemap+ dup class-map+ dup class<map+ update-map+ ;
: cache-classes ( assoc -- )
[ drop cache-class ] assoc-each ;
GENERIC: uncache-class ( class -- )
M: class uncache-class
dup update-map- dup class<map- dup class-map- typemap- ;
M: word uncache-class drop ;
: uncache-classes ( assoc -- )
[ drop uncache-class ] assoc-each ;
PRIVATE>
: define-class-props ( members superclass metaclass -- assoc )
@ -293,14 +108,12 @@ GENERIC: update-methods ( assoc -- )
: define-class ( word members superclass metaclass -- )
#! If it was already a class, update methods after.
reset-caches
define-class-props
over class? >r
over class-usages [
uncache-classes
dupd (define-class)
] keep cache-classes r>
[ class-usages dup update-predicates update-methods ]
[ drop ] if ;
over update-map-
dupd (define-class)
dup update-map+
class-usages dup update-predicates update-methods ;
GENERIC: class ( object -- class ) inline

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

@ -1,9 +1,9 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes classes.private combinators
cpu.architecture generator.fixup hashtables kernel layouts math
namespaces quotations sequences system vectors words effects
alien byte-arrays bit-arrays float-arrays ;
USING: arrays assocs classes classes.private classes.algebra
combinators cpu.architecture generator.fixup hashtables kernel
layouts math namespaces quotations sequences system vectors
words effects alien byte-arrays bit-arrays float-arrays ;
IN: generator.registers
SYMBOL: +input+
@ -581,13 +581,14 @@ M: loc lazy-store
2drop t
] if ;
: class-tags ( class -- tag/f )
class-types [
dup num-tags get >=
[ drop object tag-number ] when
] map prune ;
: class-tag ( class -- tag/f )
dup hi-tag class< [
drop object tag-number
] [
flatten-builtin-class keys
dup length 1 = [ first tag-number ] [ drop f ] if
] if ;
class-tags dup length 1 = [ first ] [ drop f ] if ;
: class-matches? ( actual expected -- ? )
{

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

@ -1,6 +1,6 @@
USING: help.markup help.syntax words classes definitions kernel
alien sequences math quotations generic.standard generic.math
combinators ;
USING: help.markup help.syntax words classes classes.algebra
definitions kernel alien sequences math quotations
generic.standard generic.math combinators ;
IN: generic
ARTICLE: "method-order" "Method precedence"

4
core/generic/generic-tests.factor
View File

@ -1,8 +1,8 @@
USING: alien arrays definitions generic generic.standard
generic.math assocs hashtables io kernel math namespaces parser
prettyprint sequences strings tools.test vectors words
quotations classes continuations layouts classes.union sorting
compiler.units ;
quotations classes classes.algebra continuations layouts
classes.union sorting compiler.units ;
IN: generic.tests
GENERIC: foobar ( x -- y )

4
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
quotations arrays vocabs effects ;
classes.algebra quotations arrays vocabs effects ;
IN: generic
! Method combination protocol
@ -138,7 +138,7 @@ M: method-body forget*
M: class forget* ( class -- )
dup forget-methods
dup uncache-class
dup update-map-
forget-word ;
M: assoc update-methods ( assoc -- )

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

@ -1,8 +1,8 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic hashtables kernel kernel.private
math namespaces sequences words quotations layouts combinators
sequences.private classes definitions ;
sequences.private classes classes.algebra definitions ;
IN: generic.math
PREDICATE: class math-class ( object -- ? )
@ -16,8 +16,8 @@ PREDICATE: class math-class ( object -- ? )
: math-precedence ( class -- n )
{
{ [ dup class-empty? ] [ drop { -1 -1 } ] }
{ [ dup math-class? ] [ types last/first ] }
{ [ dup null class< ] [ drop { -1 -1 } ] }
{ [ dup math-class? ] [ class-types last/first ] }
{ [ t ] [ drop { 100 100 } ] }
} cond ;

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

@ -3,7 +3,7 @@
USING: arrays assocs kernel kernel.private slots.private math
namespaces sequences vectors words quotations definitions
hashtables layouts combinators sequences.private generic
classes classes.private ;
classes classes.algebra classes.private ;
IN: generic.standard
TUPLE: standard-combination # ;

11
core/inference/class/class.factor
View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic assocs hashtables inference kernel
math namespaces sequences words parser math.intervals
effects classes inference.dataflow inference.backend
combinators ;
effects classes classes.algebra inference.dataflow
inference.backend combinators ;
IN: inference.class
! Class inference
@ -88,8 +88,11 @@ M: interval-constraint apply-constraint
swap interval-constraint-value intersect-value-interval ;
: set-class-interval ( class value -- )
>r "interval" word-prop dup
[ r> set-value-interval* ] [ r> 2drop ] if ;
over class? [
over "interval" word-prop [
>r "interval" word-prop r> set-value-interval*
] [ 2drop ] if
] [ 2drop ] if ;
: value-class* ( value -- class )
value-classes get at object or ;

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

@ -3,8 +3,8 @@
USING: arrays generic assocs inference inference.class
inference.dataflow inference.backend inference.state io kernel
math namespaces sequences vectors words quotations hashtables
combinators classes generic.math continuations optimizer.def-use
optimizer.backend generic.standard ;
combinators classes classes.algebra generic.math continuations
optimizer.def-use optimizer.backend generic.standard ;
IN: optimizer.control
! ! ! Rudimentary CFA

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

@ -3,10 +3,10 @@
USING: arrays generic assocs inference inference.class
inference.dataflow inference.backend inference.state io kernel
math namespaces sequences vectors words quotations hashtables
combinators classes generic.math continuations optimizer.def-use
optimizer.backend generic.standard optimizer.specializers
optimizer.def-use optimizer.pattern-match generic.standard
optimizer.control kernel.private ;
combinators classes classes.algebra generic.math continuations
optimizer.def-use optimizer.backend generic.standard
optimizer.specializers optimizer.def-use optimizer.pattern-match
generic.standard optimizer.control kernel.private ;
IN: optimizer.inlining
: remember-inlining ( node history -- )
@ -175,7 +175,7 @@ DEFER: (flat-length)
: optimistic-inline? ( #call -- ? )
dup node-param "specializer" word-prop dup [
>r node-input-classes r> specialized-length tail*
[ types length 1 = ] all?
[ class-types length 1 = ] all?
] [
2drop f
] if ;

9
core/optimizer/known-words/known-words.factor
View File

@ -7,8 +7,9 @@ sequences words parser vectors strings sbufs io namespaces
assocs quotations sequences.private io.binary io.crc32
io.streams.string layouts splitting math.intervals
math.floats.private tuples tuples.private classes
optimizer.def-use optimizer.backend optimizer.pattern-match
optimizer.inlining float-arrays sequences.private combinators ;
classes.algebra optimizer.def-use optimizer.backend
optimizer.pattern-match optimizer.inlining float-arrays
sequences.private combinators ;
! the output of <tuple> and <tuple-boa> has the class which is
! its second-to-last input
@ -89,10 +90,10 @@ optimizer.inlining float-arrays sequences.private combinators ;
! type applied to an object of a known type can be folded
: known-type? ( node -- ? )
node-class-first types length 1 number= ;
node-class-first class-types length 1 number= ;
: fold-known-type ( node -- node )
dup node-class-first types inline-literals ;
dup node-class-first class-types inline-literals ;
\ type [
{ [ dup known-type? ] [ fold-known-type ] }

7
core/optimizer/math/math.factor
View File

@ -5,9 +5,10 @@ USING: alien alien.accessors arrays generic hashtables kernel
assocs math math.private kernel.private sequences words parser
inference.class inference.dataflow vectors strings sbufs io
namespaces assocs quotations math.intervals sequences.private
combinators splitting layouts math.parser classes generic.math
optimizer.pattern-match optimizer.backend optimizer.def-use
optimizer.inlining generic.standard system ;
combinators splitting layouts math.parser classes
classes.algebra generic.math optimizer.pattern-match
optimizer.backend optimizer.def-use optimizer.inlining
generic.standard system ;
{ + bignum+ float+ fixnum+fast } {
{ { number 0 } [ drop ] }

5
core/optimizer/optimizer-tests.factor
View File

@ -1,8 +1,9 @@
USING: arrays compiler.units generic hashtables inference kernel
kernel.private math optimizer prettyprint sequences sbufs
strings tools.test vectors words sequences.private quotations
optimizer.backend classes inference.dataflow tuples.private
continuations growable optimizer.inlining namespaces hints ;
optimizer.backend classes classes.algebra inference.dataflow
tuples.private continuations growable optimizer.inlining
namespaces hints ;
IN: optimizer.tests
[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [

2
core/optimizer/pattern-match/pattern-match.factor Normal file → Executable file
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
IN: optimizer.pattern-match
USING: kernel sequences inference namespaces generic
combinators classes inference.dataflow ;
combinators classes classes.algebra inference.dataflow ;
! Funny pattern matching
SYMBOL: @

11
core/tuples/tuples-tests.factor
View File

@ -5,9 +5,6 @@ generic.standard effects tuples tuples.private arrays vectors
strings compiler.units ;
IN: tuples.tests
[ t ] [ \ tuple-class \ class class< ] unit-test
[ f ] [ \ class \ tuple-class class< ] unit-test
TUPLE: rect x y w h ;
: <rect> rect construct-boa ;
@ -90,12 +87,6 @@ TUPLE: delegate-clone ;
[ T{ delegate-clone T{ empty f } } ]
[ T{ delegate-clone T{ empty f } } clone ] unit-test
[ t ] [ \ null \ delegate-clone class< ] unit-test
[ f ] [ \ object \ delegate-clone class< ] unit-test
[ f ] [ \ object \ delegate-clone class< ] unit-test
[ t ] [ \ delegate-clone \ tuple class< ] unit-test
[ f ] [ \ tuple \ delegate-clone class< ] unit-test
! Compiler regression
[ t length ] [ no-method-object t eq? ] must-fail-with
@ -121,7 +112,7 @@ TUPLE: yo-momma ;
[
[ t ] [ \ yo-momma class? ] unit-test
[ ] [ \ yo-momma forget ] unit-test
[ f ] [ \ yo-momma typemap get values memq? ] unit-test
[ f ] [ \ yo-momma update-map get values memq? ] unit-test
[ f ] [ \ yo-momma crossref get at ] unit-test
] with-compilation-unit

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

@ -46,3 +46,8 @@ IN: combinators.lib.tests
[ dup array? ] [ dup vector? ] [ dup float? ]
} || nip
] unit-test
{ 1 1 } [
[ even? ] [ drop 1 ] [ drop 2 ] ifte
] must-infer-as

12
extra/io/launcher/launcher-docs.factor
View File

@ -33,6 +33,17 @@ $nl
{ "a file stream or a socket - the stream is connected to the given Factor stream, which cannot be used again from within Factor and must be closed after the process has been started" }
} ;
ARTICLE: "io.launcher.priority" "Setting process priority"
"The priority of the child process can be set by storing one of the below symbols in the " { $snippet "priority" } " slot of a " { $link process } " tuple:"
{ $list
{ $link +lowest-priority+ }
{ $link +low-priority+ }
{ $link +normal-priority+ }
{ $link +high-priority+ }
{ $link +highest-priority+ }
}
"The default value is " { $link f } ", which denotes that the child process should inherit the current process priority." ;
HELP: +closed+
{ $description "Possible value for the " { $snippet "stdin" } ", " { $snippet "stdout" } ", and " { $snippet "stderr" } " slots of a " { $link process } "." } ;
@ -216,6 +227,7 @@ ARTICLE: "io.launcher" "Operating system processes"
{ $subsection "io.launcher.detached" }
{ $subsection "io.launcher.environment" }
{ $subsection "io.launcher.redirection" }
{ $subsection "io.launcher.priority" }
{ $subsection "io.launcher.timeouts" } ;
ABOUT: "io.launcher"

9
extra/io/launcher/launcher.factor
View File

@ -6,7 +6,6 @@ init threads continuations math io.encodings io.streams.duplex
io.nonblocking accessors ;
IN: io.launcher
TUPLE: process
command
@ -19,6 +18,8 @@ stdin
stdout
stderr
priority
timeout
handle status
@ -32,6 +33,12 @@ SYMBOL: +prepend-environment+
SYMBOL: +replace-environment+
SYMBOL: +append-environment+
SYMBOL: +lowest-priority+
SYMBOL: +low-priority+
SYMBOL: +normal-priority+
SYMBOL: +high-priority+
SYMBOL: +highest-priority+
: <process> ( -- process )
process construct-empty
H{ } clone >>environment

2
extra/io/paths/paths.factor
View File

@ -44,7 +44,7 @@ TUPLE: directory-iterator path bfs queue ;
: find-all-files ( path bfs? quot -- paths )
>r <directory-iterator> r>
pusher >r iterate-directory drop r> ; inline
pusher >r [ f ] compose iterate-directory drop r> ; inline
: recursive-directory ( path bfs? -- paths )
[ ] accumulator >r each-file r> ;

5
extra/io/priority/priority.factor
View File

@ -1,5 +0,0 @@
USING: io.backend kernel ;
IN: io.priority
HOOK: get-priority io-backend ( -- n )
HOOK: set-priority io-backend ( n -- )

19
extra/io/unix/launcher/launcher.factor
View File

@ -16,6 +16,17 @@ USE: unix
: assoc>env ( assoc -- env )
[ "=" swap 3append ] { } assoc>map ;
: setup-priority ( process -- process )
dup priority>> [
H{
{ +lowest-priority+ 20 }
{ +low-priority+ 10 }
{ +normal-priority+ 0 }
{ +high-priority+ -10 }
{ +highest-priority+ -20 }
} at set-priority
] when* ;
: redirect-fd ( oldfd fd -- )
2dup = [ 2drop ] [ dupd dup2 io-error close ] if ;
@ -47,11 +58,15 @@ USE: unix
: setup-redirection ( process -- process )
dup stdin>> ?closed read-flags 0 redirect
dup stdout>> ?closed write-flags 1 redirect
dup stderr>> dup +stdout+ eq?
[ drop 1 2 dup2 io-error ] [ ?closed write-flags 2 redirect ] if ;
dup stderr>> dup +stdout+ eq? [
drop 1 2 dup2 io-error
] [
?closed write-flags 2 redirect
] if ;
: spawn-process ( process -- * )
[
setup-priority
setup-redirection
dup pass-environment? [
dup get-environment set-os-envs

21
extra/io/unix/priority/priority.factor
View File

@ -1,21 +0,0 @@
USING: alien.syntax kernel io.priority io.unix.backend
unix ;
IN: io.unix.priority
: PRIO_PROCESS 0 ; inline
: PRIO_PGRP 1 ; inline
: PRIO_USER 2 ; inline
: PRIO_MIN -20 ; inline
: PRIO_MAX 20 ; inline
! which/who = 0 for current process
FUNCTION: int getpriority ( int which, int who ) ;
FUNCTION: int setpriority ( int which, int who, int prio ) ;
M: unix-io get-priority ( -- n )
clear_err_no
0 0 getpriority dup -1 = [ check-errno ] when ;
M: unix-io set-priority ( n -- )
0 0 rot setpriority io-error ;

4
extra/io/unix/unix.factor
View File

@ -1,5 +1,5 @@
USING: io.unix.backend io.unix.files io.unix.sockets io.timeouts
io.unix.launcher io.unix.mmap io.backend io.unix.priority
combinators namespaces system vocabs.loader sequences ;
io.unix.launcher io.unix.mmap io.backend combinators namespaces
system vocabs.loader sequences ;
"io.unix." os append require

2
extra/lsys/ui/ui.factor
View File

@ -196,6 +196,8 @@ slate> handler> set-gadget-delegate
handler> "L-system view" open-window
500 sleep
slate> find-gl-context
1 glGenLists >model

17
extra/new-effects/new-effects.factor Normal file
View File

@ -0,0 +1,17 @@
USING: assocs kernel sequences ;
IN: new-effects
: new-nth ( seq n -- elt )
swap nth ; inline
: new-set-nth ( seq obj n -- seq )
pick set-nth ; inline
: new-at ( assoc key -- elt )
swap at ; inline
: new-at* ( assoc key -- elt ? )
swap at* ; inline
: new-set-at ( assoc value key -- assoc )
pick set-at ; inline

2
extra/peg/ebnf/ebnf-tests.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
USING: kernel tools.test peg peg.ebnf ;
USING: kernel tools.test peg peg.ebnf words ;
IN: peg.ebnf.tests
{ T{ ebnf-non-terminal f "abc" } } [

2
extra/peg/ebnf/ebnf.factor
View File

@ -278,7 +278,7 @@ M: ebnf-non-terminal (transform) ( ast -- parser )
: ebnf>quot ( string -- hashtable quot )
'ebnf' parse check-parse-result
parse-result-ast transform dup main swap at compile ;
parse-result-ast transform dup main swap at compile 1quotation ;
: [EBNF "EBNF]" parse-multiline-string ebnf>quot nip parsed ; parsing

4
extra/peg/parsers/parsers.factor
View File

@ -16,8 +16,8 @@ TUPLE: just-parser p1 ;
] ;
M: just-parser compile ( parser -- quot )
just-parser-p1 compile just-pattern append ;
M: just-parser (compile) ( parser -- quot )
just-parser-p1 compiled-parser just-pattern curry ;
: just ( parser -- parser )
just-parser construct-boa ;

102
extra/peg/peg.factor
View File

@ -3,24 +3,43 @@
USING: kernel sequences strings namespaces math assocs shuffle
vectors arrays combinators.lib math.parser match
unicode.categories sequences.lib compiler.units parser
words ;
words quotations effects memoize ;
IN: peg
TUPLE: parse-result remaining ast ;
GENERIC: compile ( parser -- quot )
: parse ( state parser -- result )
compile call ;
SYMBOL: ignore
: <parse-result> ( remaining ast -- parse-result )
parse-result construct-boa ;
SYMBOL: compiled-parsers
GENERIC: (compile) ( parser -- quot )
: compiled-parser ( parser -- word )
#! Look to see if the given parser has been compiled.
#! If not, compile it to a temporary word, cache it,
#! and return it. Otherwise return the existing one.
dup compiled-parsers get at [
nip
] [
dup (compile) define-temp
[ swap compiled-parsers get set-at ] keep
] if* ;
MEMO: compile ( parser -- word )
H{ } clone compiled-parsers [
[ compiled-parser ] with-compilation-unit
] with-variable ;
: parse ( state parser -- result )
compile execute ;
<PRIVATE
TUPLE: token-parser symbol ;
! M: token-parser equal? eq? ;
MATCH-VARS: ?token ;
@ -33,7 +52,7 @@ MATCH-VARS: ?token ;
] if
] ;
M: token-parser compile ( parser -- quot )
M: token-parser (compile) ( parser -- quot )
token-parser-symbol \ ?token token-pattern match-replace ;
TUPLE: satisfy-parser quot ;
@ -53,7 +72,7 @@ MATCH-VARS: ?quot ;
] if
] ;
M: satisfy-parser compile ( parser -- quot )
M: satisfy-parser (compile) ( parser -- quot )
satisfy-parser-quot \ ?quot satisfy-pattern match-replace ;
TUPLE: range-parser min max ;
@ -74,7 +93,7 @@ MATCH-VARS: ?min ?max ;
] if
] ;
M: range-parser compile ( parser -- quot )
M: range-parser (compile) ( parser -- quot )
T{ range-parser _ ?min ?max } range-pattern match-replace ;
TUPLE: seq-parser parsers ;
@ -82,7 +101,7 @@ TUPLE: seq-parser parsers ;
: seq-pattern ( -- quot )
[
dup [
dup parse-result-remaining ?quot call [
dup parse-result-remaining ?quot [
[ parse-result-remaining swap set-parse-result-remaining ] 2keep
parse-result-ast dup ignore = [
drop
@ -97,10 +116,10 @@ TUPLE: seq-parser parsers ;
] if
] ;
M: seq-parser compile ( parser -- quot )
M: seq-parser (compile) ( parser -- quot )
[
[ V{ } clone <parse-result> ] %
seq-parser-parsers [ compile \ ?quot seq-pattern match-replace % ] each
seq-parser-parsers [ compiled-parser \ ?quot seq-pattern match-replace % ] each
] [ ] make ;
TUPLE: choice-parser parsers ;
@ -110,14 +129,14 @@ TUPLE: choice-parser parsers ;
dup [
] [
drop dup ?quot call
drop dup ?quot
] if
] ;
M: choice-parser compile ( parser -- quot )
M: choice-parser (compile) ( parser -- quot )
[
f ,
choice-parser-parsers [ compile \ ?quot choice-pattern match-replace % ] each
choice-parser-parsers [ compiled-parser \ ?quot choice-pattern match-replace % ] each
\ nip ,
] [ ] make ;
@ -134,20 +153,20 @@ TUPLE: repeat0-parser p1 ;
: repeat0-pattern ( -- quot )
[
?quot swap (repeat0)
[ ?quot ] swap (repeat0)
] ;
M: repeat0-parser compile ( parser -- quot )
M: repeat0-parser (compile) ( parser -- quot )
[
[ V{ } clone <parse-result> ] %
repeat0-parser-p1 compile \ ?quot repeat0-pattern match-replace %
repeat0-parser-p1 compiled-parser \ ?quot repeat0-pattern match-replace %
] [ ] make ;
TUPLE: repeat1-parser p1 ;
: repeat1-pattern ( -- quot )
[
?quot swap (repeat0) [
[ ?quot ] swap (repeat0) [
dup parse-result-ast empty? [
drop f
] when
@ -156,49 +175,49 @@ TUPLE: repeat1-parser p1 ;
] if*
] ;
M: repeat1-parser compile ( parser -- quot )
M: repeat1-parser (compile) ( parser -- quot )
[
[ V{ } clone <parse-result> ] %
repeat1-parser-p1 compile \ ?quot repeat1-pattern match-replace %
repeat1-parser-p1 compiled-parser \ ?quot repeat1-pattern match-replace %
] [ ] make ;
TUPLE: optional-parser p1 ;
: optional-pattern ( -- quot )
[
dup ?quot call swap f <parse-result> or
dup ?quot swap f <parse-result> or
] ;
M: optional-parser compile ( parser -- quot )
optional-parser-p1 compile \ ?quot optional-pattern match-replace ;
M: optional-parser (compile) ( parser -- quot )
optional-parser-p1 compiled-parser \ ?quot optional-pattern match-replace ;
TUPLE: ensure-parser p1 ;
: ensure-pattern ( -- quot )
[
dup ?quot call [
dup ?quot [
ignore <parse-result>
] [
drop f
] if
] ;
M: ensure-parser compile ( parser -- quot )
ensure-parser-p1 compile \ ?quot ensure-pattern match-replace ;
M: ensure-parser (compile) ( parser -- quot )
ensure-parser-p1 compiled-parser \ ?quot ensure-pattern match-replace ;
TUPLE: ensure-not-parser p1 ;
: ensure-not-pattern ( -- quot )
[
dup ?quot call [
dup ?quot [
drop f
] [
ignore <parse-result>
] if
] ;
M: ensure-not-parser compile ( parser -- quot )
ensure-not-parser-p1 compile \ ?quot ensure-not-pattern match-replace ;
M: ensure-not-parser (compile) ( parser -- quot )
ensure-not-parser-p1 compiled-parser \ ?quot ensure-not-pattern match-replace ;
TUPLE: action-parser p1 quot ;
@ -206,14 +225,14 @@ MATCH-VARS: ?action ;
: action-pattern ( -- quot )
[
?quot call dup [
?quot dup [
dup parse-result-ast ?action call
swap [ set-parse-result-ast ] keep
] when
] ;
M: action-parser compile ( parser -- quot )
{ action-parser-p1 action-parser-quot } get-slots [ compile ] dip
M: action-parser (compile) ( parser -- quot )
{ action-parser-p1 action-parser-quot } get-slots [ compiled-parser ] dip
2array { ?quot ?action } action-pattern match-replace ;
: left-trim-slice ( string -- string )
@ -225,17 +244,22 @@ M: action-parser compile ( parser -- quot )
TUPLE: sp-parser p1 ;
M: sp-parser compile ( parser -- quot )
M: sp-parser (compile) ( parser -- quot )
[
\ left-trim-slice , sp-parser-p1 compile %
\ left-trim-slice , sp-parser-p1 compiled-parser ,
] [ ] make ;
TUPLE: delay-parser quot ;
M: delay-parser compile ( parser -- quot )
M: delay-parser (compile) ( parser -- quot )
#! For efficiency we memoize the quotation.
#! This way it is run only once and the
#! parser constructed once at run time.
[
delay-parser-quot % \ compile , \ call ,
] [ ] make ;
delay-parser-quot % \ compile ,
] [ ] make
{ } { "word" } <effect> memoize-quot
[ % \ execute , ] [ ] make ;
PRIVATE>
@ -308,7 +332,7 @@ PRIVATE>
: PEG:
(:) [
[
call compile
call compile 1quotation
[ dup [ parse-result-ast ] [ "Parse failed" throw ] if ]
append define
] with-compilation-unit

5
extra/random/mersenne-twister/mersenne-twister.factor
View File

@ -4,14 +4,11 @@
! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c
USING: arrays kernel math namespaces sequences system init
accessors math.ranges combinators.cleave random ;
accessors math.ranges combinators.cleave random new-effects ;
IN: random.mersenne-twister
<PRIVATE
: new-nth ( seq i -- elt ) swap nth ; inline
: new-set-nth ( seq obj n -- seq ) pick set-nth ; inline
TUPLE: mersenne-twister seq i ;
: mt-n 624 ; inline

32
extra/tools/deploy/shaker/shaker.factor
View File

@ -139,27 +139,29 @@ IN: tools.deploy.shaker
{ } { "cpu" } strip-vocab-globals %
{
vocabs:dictionary
lexer-factory
vocabs:load-vocab-hook
root-cache
classes:class-and-cache
classes:class-not-cache
classes:class-or-cache
classes:class<-cache
classes:classes-intersect-cache
classes:update-map
compiled-crossref
compiler.units:recompile-hook
definitions:crossref
interactive-vocabs
layouts:num-tags
layouts:num-types
layouts:tag-mask
layouts:tag-numbers
layouts:type-numbers
classes:typemap
classes:class-map
vocab-roots
definitions:crossref
compiled-crossref
interactive-vocabs
word
compiler.units:recompile-hook
listener:listener-hook
lexer-factory
classes:update-map
classes:class<map
lexer-factory
listener:listener-hook
root-cache
vocab-roots
vocabs:dictionary
vocabs:load-vocab-hook
word
} %
] when

5
extra/unix/process/process.factor
View File

@ -33,4 +33,7 @@ IN: unix.process
fork dup io-error dup zero? -roll swap curry if ; inline
: wait-for-pid ( pid -- status )
0 <int> [ 0 waitpid drop ] keep *int WEXITSTATUS ;
0 <int> [ 0 waitpid drop ] keep *int WEXITSTATUS ;
: set-priority ( n -- )
0 0 rot setpriority io-error ;

11
extra/unix/unix.factor
View File

@ -102,6 +102,17 @@ FUNCTION: int utimes ( char* path, timeval[2] times ) ;
FUNCTION: int kill ( pid_t pid, int sig ) ;
: PRIO_PROCESS 0 ; inline
: PRIO_PGRP 1 ; inline
: PRIO_USER 2 ; inline
: PRIO_MIN -20 ; inline
: PRIO_MAX 20 ; inline
! which/who = 0 for current process
FUNCTION: int getpriority ( int which, int who ) ;
FUNCTION: int setpriority ( int which, int who, int prio ) ;
! Flags for waitpid
: WNOHANG 1 ; inline

24
extra/windows/kernel32/kernel32.factor
View File

@ -189,6 +189,16 @@ TYPEDEF: FILE_NOTIFY_INFORMATION* PFILE_NOTIFY_INFORMATION
: FILE_MAP_WRITE 2 ;
: FILE_MAP_COPY 1 ;
: THREAD_MODE_BACKGROUND_BEGIN HEX: 10000 ; inline
: THREAD_MODE_BACKGROUND_END HEX: 20000 ; inline
: THREAD_PRIORITY_ABOVE_NORMAL 1 ; inline
: THREAD_PRIORITY_BELOW_NORMAL -1 ; inline
: THREAD_PRIORITY_HIGHEST 2 ; inline
: THREAD_PRIORITY_IDLE -15 ; inline
: THREAD_PRIORITY_LOWEST -2 ; inline
: THREAD_PRIORITY_NORMAL 0 ; inline
: THREAD_PRIORITY_TIME_CRITICAL 15 ; inline
C-STRUCT: OVERLAPPED
{ "int" "internal" }
{ "int" "internal-high" }
@ -998,7 +1008,7 @@ FUNCTION: HMODULE GetModuleHandleW ( LPCWSTR lpModuleName ) ;
! FUNCTION: GetNumberOfConsoleMouseButtons
! FUNCTION: GetOEMCP
FUNCTION: BOOL GetOverlappedResult ( HANDLE hFile, LPOVERLAPPED lpOverlapped, LPDWORD lpNumberOfBytesTransferred, BOOL bWait ) ;
! FUNCTION: GetPriorityClass
FUNCTION: DWORD GetPriorityClass ( HANDLE hProcess ) ;
! FUNCTION: GetPrivateProfileIntA
! FUNCTION: GetPrivateProfileIntW
! FUNCTION: GetPrivateProfileSectionA
@ -1065,8 +1075,8 @@ FUNCTION: UINT GetSystemWindowsDirectoryW ( LPTSTR lpBuffer, UINT uSize ) ;
! FUNCTION: GetThreadContext
! FUNCTION: GetThreadIOPendingFlag
! FUNCTION: GetThreadLocale
! FUNCTION: GetThreadPriority
! FUNCTION: GetThreadPriorityBoost
FUNCTION: int GetThreadPriority ( HANDLE hThread ) ;
FUNCTION: BOOL GetThreadPriorityBoost ( HANDLE hThread, PBOOL pDisablePriorityBoost ) ;
! FUNCTION: GetThreadSelectorEntry
! FUNCTION: GetThreadTimes
! FUNCTION: GetTickCount
@ -1437,9 +1447,9 @@ FUNCTION: BOOL SetHandleInformation ( HANDLE hObject, DWORD dwMask, DWORD dwFlag
! FUNCTION: SetMailslotInfo
! FUNCTION: SetMessageWaitingIndicator
! FUNCTION: SetNamedPipeHandleState
! FUNCTION: SetPriorityClass
FUNCTION: BOOL SetPriorityClass ( HANDLE hProcess, DWORD dwPriorityClass ) ;
! FUNCTION: SetProcessAffinityMask
! FUNCTION: SetProcessPriorityBoost
FUNCTION: BOOL SetProcessPriorityBoost ( HANDLE hProcess, BOOL disablePriorityBoost ) ;
! FUNCTION: SetProcessShutdownParameters
! FUNCTION: SetProcessWorkingSetSize
! FUNCTION: SetStdHandle
@ -1454,8 +1464,8 @@ FUNCTION: BOOL SetHandleInformation ( HANDLE hObject, DWORD dwMask, DWORD dwFlag
! FUNCTION: SetThreadExecutionState
! FUNCTION: SetThreadIdealProcessor
! FUNCTION: SetThreadLocale
! FUNCTION: SetThreadPriority
! FUNCTION: SetThreadPriorityBoost
FUNCTION: BOOL SetThreadPriority ( HANDLE hThread, int nPriority ) ;
FUNCTION: BOOL SetThreadPriorityBoost ( HANDLE hThread, BOOL disablePriorityBoost ) ;
! FUNCTION: SetThreadUILanguage
! FUNCTION: SetTimerQueueTimer
! FUNCTION: SetTimeZoneInformation