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

core/bootstrap/image/image.factor

@@ -348,8 +348,10 @@ M: curry '
 : emit-global ( -- )
     [
         {
-            dictionary source-files
+            dictionary source-files builtins
-            typemap builtins class<map class-map update-map
+            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

core/bootstrap/primitives.factor

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

core/classes/algebra/algebra-docs.factor

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

core/classes/algebra/algebra-tests.factor

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

core/classes/algebra/algebra.factor

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

core/classes/classes-docs.factor

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

core/classes/classes-tests.factor

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

core/classes/classes.factor

@@ -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
+SYMBOL: class<-cache
-vectors math quotations combinators sorting effects graphs ;
+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 ;
+: members ( class -- seq )
-
+    #! Output f for non-classes to work with algebra code
-: class-empty? ( class -- ? ) members dup [ empty? ] when ;
+    dup class? [ "members" word-prop ] [ drop f ] if ;
-
-: (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 ;
 
 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 update-map-
-    over class-usages [
+    dupd (define-class)
-        uncache-classes
+    dup update-map+
-        dupd (define-class)
+    class-usages dup update-predicates update-methods ;
-    ] keep cache-classes r>
-    [ class-usages dup update-predicates update-methods ]
-    [ drop ] if ;
 
 GENERIC: class ( object -- class ) inline
 

core/generator/registers/registers.factor

@@ -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
+USING: arrays assocs classes classes.private classes.algebra
-cpu.architecture generator.fixup hashtables kernel layouts math
+combinators cpu.architecture generator.fixup hashtables kernel
-namespaces quotations sequences system vectors words effects
+layouts math namespaces quotations sequences system vectors
-alien byte-arrays bit-arrays float-arrays ;
+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< [
+    class-tags dup length 1 = [ first ] [ drop f ] if ;
-        drop object tag-number
-    ] [
-        flatten-builtin-class keys
-        dup length 1 = [ first tag-number ] [ drop f ] if
-    ] if ;
 
 : class-matches? ( actual expected -- ? )
     {

core/generic/generic-docs.factor

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

core/generic/generic-tests.factor

@@ -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
+quotations classes classes.algebra continuations layouts
-compiler.units ;
+classes.union sorting compiler.units ;
 IN: generic.tests
 
 GENERIC: foobar ( x -- y )

core/generic/generic.factor

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

core/generic/math/math.factor

@@ -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 null class< ] [ drop { -1 -1 } ] }
-        { [ dup math-class? ] [ types last/first ] }
+        { [ dup math-class? ] [ class-types last/first ] }
         { [ t ] [ drop { 100 100 } ] }
     } cond ;
     

core/generic/standard/standard.factor

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

core/inference/class/class.factor

@@ -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
+effects classes classes.algebra inference.dataflow
-combinators ;
+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
+    over class? [
-    [ r> set-value-interval* ] [ r> 2drop ] if ;
+        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 ;

core/optimizer/control/control.factor

@@ -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
+combinators classes classes.algebra generic.math continuations
-optimizer.backend generic.standard ;
+optimizer.def-use optimizer.backend generic.standard ;
 IN: optimizer.control
 
 ! ! ! Rudimentary CFA

core/optimizer/inlining/inlining.factor

@@ -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
+combinators classes classes.algebra generic.math continuations
-optimizer.backend generic.standard optimizer.specializers
+optimizer.def-use optimizer.backend generic.standard
-optimizer.def-use optimizer.pattern-match generic.standard
+optimizer.specializers optimizer.def-use optimizer.pattern-match
-optimizer.control kernel.private ;
+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 ;

core/optimizer/known-words/known-words.factor

@@ -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
+classes.algebra optimizer.def-use optimizer.backend
-optimizer.inlining float-arrays sequences.private combinators ;
+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 ] }

core/optimizer/math/math.factor

@@ -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
+combinators splitting layouts math.parser classes
-optimizer.pattern-match optimizer.backend optimizer.def-use
+classes.algebra generic.math optimizer.pattern-match
-optimizer.inlining generic.standard system ;
+optimizer.backend optimizer.def-use optimizer.inlining
+generic.standard system ;
 
 { + bignum+ float+ fixnum+fast } {
     { { number 0 } [ drop ] }

core/optimizer/optimizer-tests.factor

@@ -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
+optimizer.backend classes classes.algebra inference.dataflow
-continuations growable optimizer.inlining namespaces hints ;
+tuples.private continuations growable optimizer.inlining
+namespaces hints ;
 IN: optimizer.tests
 
 [ H{ { 1 5 } { 3 4 } { 2 5 } } ] [

core/optimizer/pattern-match/pattern-match.factor

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

core/tuples/tuples-tests.factor

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

extra/combinators/lib/lib-tests.factor

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

extra/io/launcher/launcher-docs.factor

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

extra/io/launcher/launcher.factor

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

extra/io/paths/paths.factor

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

extra/io/priority/priority.factor

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

extra/io/unix/launcher/launcher.factor

@@ -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?
+    dup stderr>> dup +stdout+ eq? [
-    [ drop 1 2 dup2 io-error ] [ ?closed write-flags 2 redirect ] if ;
+        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

extra/io/unix/priority/priority.factor

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

extra/io/unix/unix.factor

@@ -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
+io.unix.launcher io.unix.mmap io.backend combinators namespaces
-combinators namespaces system vocabs.loader sequences ;
+system vocabs.loader sequences ;
 
 "io.unix." os append require

extra/lsys/ui/ui.factor

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

extra/new-effects/new-effects.factor

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

extra/peg/ebnf/ebnf-tests.factor

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

extra/peg/ebnf/ebnf.factor

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

extra/peg/parsers/parsers.factor

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

extra/peg/peg.factor

@@ -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 )
+M: optional-parser (compile) ( parser -- quot )
-  optional-parser-p1 compile \ ?quot optional-pattern match-replace ;
+  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 )
+M: ensure-parser (compile) ( parser -- quot )
-  ensure-parser-p1 compile \ ?quot ensure-pattern match-replace ;
+  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 )
+M: ensure-not-parser (compile) ( parser -- quot )
-  ensure-not-parser-p1 compile \ ?quot ensure-not-pattern match-replace ;
+  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 )
+M: action-parser (compile) ( parser -- quot )
-  { action-parser-p1 action-parser-quot } get-slots [ compile ] dip 
+  { 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 ,
+    delay-parser-quot % \ compile ,
-  ] [ ] make ;
+  ] [ ] 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

extra/random/mersenne-twister/mersenne-twister.factor

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

extra/tools/deploy/shaker/shaker.factor

@@ -139,27 +139,29 @@ IN: tools.deploy.shaker
             { } { "cpu" } strip-vocab-globals %
 
             {
-                vocabs:dictionary
+                classes:class-and-cache
-                lexer-factory
+                classes:class-not-cache
-                vocabs:load-vocab-hook
+                classes:class-or-cache
-                root-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
+                lexer-factory
-                classes:class<map
+                listener:listener-hook
+                root-cache
+                vocab-roots
+                vocabs:dictionary
+                vocabs:load-vocab-hook
+                word
             } %
         ] when
 

extra/unix/process/process.factor

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

extra/unix/unix.factor

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

extra/windows/kernel32/kernel32.factor

@@ -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: int GetThreadPriority ( HANDLE hThread ) ;
-! FUNCTION: GetThreadPriorityBoost
+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: BOOL SetThreadPriority ( HANDLE hThread, int nPriority ) ;
-! FUNCTION: SetThreadPriorityBoost
+FUNCTION: BOOL SetThreadPriorityBoost ( HANDLE hThread, BOOL disablePriorityBoost ) ;
 ! FUNCTION: SetThreadUILanguage
 ! FUNCTION: SetTimerQueueTimer
 ! FUNCTION: SetTimeZoneInformation