diff --git a/core/classes/algebra/algebra-docs.factor b/core/classes/algebra/algebra-docs.factor index 65e6f85678..7b931c80e8 100644 --- a/core/classes/algebra/algebra-docs.factor +++ b/core/classes/algebra/algebra-docs.factor @@ -11,12 +11,7 @@ ARTICLE: "class-operations" "Class operations" class-and class-or classes-intersect? -} -"Low-level implementation detail:" -{ $subsections flatten-class - flatten-builtin-class - class-types } ; ARTICLE: "class-linearization" "Class linearization" @@ -45,18 +40,10 @@ $nl "Metaclass order:" { $subsections rank-class } ; -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 { "first" "a class" } { "second" "a class" } { "?" "a boolean" } } { $description "Tests if all instances of " { $snippet "class1" } " are also instances of " { $snippet "class2" } "." } diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor index 72c2dd575c..c56ceb7bce 100644 --- a/core/classes/algebra/algebra-tests.factor +++ b/core/classes/algebra/algebra-tests.factor @@ -7,36 +7,37 @@ stack-checker effects kernel.private sbufs math.order classes.tuple accessors generic.private ; IN: classes.algebra.tests -: class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ; - -: class-or* ( cls1 cls2 cls3 -- ? ) [ class-or ] dip 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 ] [ \ f class-not \ f null class-and* ] unit-test -[ t ] [ \ f class-not \ 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 +PREDICATE: no-docs < word "documentation" word-prop not ; -[ t ] [ number vector class-or sequence classes-intersect? ] unit-test +UNION: no-docs-union no-docs integer ; -[ f ] [ number vector class-and sequence classes-intersect? ] unit-test +TUPLE: a ; +TUPLE: b ; +UNION: c a b ; +TUPLE: tuple-example ; + +TUPLE: a1 ; +TUPLE: b1 ; +TUPLE: c1 ; + +UNION: x1 a1 b1 ; +UNION: y1 a1 c1 ; +UNION: z1 b1 c1 ; + +SINGLETON: sa +SINGLETON: sb +SINGLETON: sc + +INTERSECTION: empty-intersection ; + +INTERSECTION: generic-class generic class ; + +! class<= [ t ] [ \ fixnum \ integer class<= ] unit-test [ t ] [ \ fixnum \ fixnum class<= ] unit-test [ f ] [ \ integer \ fixnum class<= ] unit-test @@ -50,71 +51,41 @@ UNION: both first-one union-class ; [ f ] [ \ reversed \ slice class<= ] unit-test [ f ] [ \ slice \ reversed class<= ] unit-test -PREDICATE: no-docs < word "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: tuple-example ; - [ t ] [ \ null \ tuple-example class<= ] unit-test [ f ] [ \ object \ tuple-example class<= ] unit-test [ f ] [ \ object \ tuple-example class<= ] unit-test [ t ] [ \ tuple-example \ tuple class<= ] unit-test [ f ] [ \ tuple \ tuple-example 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 +[ t ] [ growable tuple sequence class-and class<= ] unit-test -[ t ] [ - growable tuple sequence class-and class<= -] unit-test - -[ t ] [ - growable assoc class-and tuple 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 @@ -127,12 +98,80 @@ UNION: z1 b1 c1 ; [ 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 integer class<= ] unit-test + +[ t ] [ object empty-intersection class<= ] unit-test +[ t ] [ empty-intersection object class<= ] unit-test +[ t ] [ \ f class-not empty-intersection class<= ] unit-test +[ f ] [ empty-intersection \ f class-not class<= ] unit-test +[ t ] [ \ number empty-intersection class<= ] unit-test +[ t ] [ empty-intersection class-not null class<= ] unit-test +[ t ] [ null empty-intersection class-not class<= ] unit-test + +[ t ] [ \ f class-not \ f class-or empty-intersection class<= ] unit-test +[ t ] [ empty-intersection \ f class-not \ f class-or class<= ] unit-test + +[ t ] [ object \ f class-not \ f class-or class<= ] unit-test + +[ t ] [ + fixnum class-not + fixnum fixnum class-not class-or + class<= +] unit-test + +[ t ] [ generic-class generic class<= ] unit-test +[ t ] [ generic-class \ class class<= ] unit-test + +! class-and +: class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip 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 ] [ \ f class-not \ f null class-and* ] unit-test + +[ t ] [ vector virtual-sequence null class-and* ] unit-test + +[ t ] [ vector array class-not vector class-and* ] unit-test + +! class-or +: class-or* ( cls1 cls2 cls3 -- ? ) [ class-or ] dip class= ; + +[ t ] [ \ f class-not \ f object class-or* ] unit-test + +! class-not +[ vector ] [ vector class-not class-not ] unit-test + +! classes-intersect? +[ t ] [ both tuple classes-intersect? ] 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 + +[ f ] [ y1 z1 class-and x1 classes-intersect? ] unit-test + +[ f ] [ a1 c1 class-or b1 c1 class-or class-and a1 b1 class-or classes-intersect? ] unit-test + +[ f ] [ integer integer class-not classes-intersect? ] unit-test [ f ] [ fixnum class-not number class-and array classes-intersect? ] unit-test -[ f ] [ fixnum class-not integer class<= ] unit-test +[ t ] [ \ word generic-class classes-intersect? ] unit-test +[ f ] [ number generic-class classes-intersect? ] unit-test +[ f ] [ sa sb classes-intersect? ] unit-test + +! class= [ t ] [ null class-not object class= ] unit-test [ t ] [ object class-not null class= ] unit-test @@ -141,13 +180,14 @@ UNION: z1 b1 c1 ; [ f ] [ null class-not null class= ] unit-test -[ t ] [ - fixnum class-not - fixnum fixnum class-not class-or - class<= -] unit-test +! class<=> -! Test method inlining +[ +lt+ ] [ integer sequence class<=> ] unit-test +[ +lt+ ] [ sequence object class<=> ] unit-test +[ +gt+ ] [ object sequence class<=> ] unit-test +[ +eq+ ] [ integer integer class<=> ] unit-test + +! smallest-class etc [ real ] [ { real sequence } smallest-class ] unit-test [ real ] [ { sequence real } smallest-class ] unit-test @@ -266,59 +306,10 @@ TUPLE: xh < xb ; [ t ] [ { xa xb xc xd xe xf xg xh } sort-classes dup sort-classes = ] unit-test -INTERSECTION: generic-class generic class ; - -[ t ] [ generic-class generic class<= ] unit-test -[ t ] [ generic-class \ class class<= ] unit-test - -! Later -[ - [ t ] [ \ class generic class-and generic-class class<= ] unit-test - [ t ] [ \ class generic class-and generic-class swap class<= ] unit-test -] drop - -[ t ] [ \ word generic-class classes-intersect? ] unit-test -[ f ] [ number generic-class classes-intersect? ] unit-test - [ H{ { word word } } ] [ generic-class flatten-class ] unit-test -[ \ + flatten-class ] must-fail - -INTERSECTION: empty-intersection ; - -[ t ] [ object empty-intersection class<= ] unit-test -[ t ] [ empty-intersection object class<= ] unit-test -[ t ] [ \ f class-not empty-intersection class<= ] unit-test -[ f ] [ empty-intersection \ f class-not class<= ] unit-test -[ t ] [ \ number empty-intersection class<= ] unit-test -[ t ] [ empty-intersection class-not null class<= ] unit-test -[ t ] [ null empty-intersection class-not class<= ] unit-test - -[ t ] [ \ f class-not \ f class-or empty-intersection class<= ] unit-test -[ t ] [ empty-intersection \ f class-not \ f class-or class<= ] unit-test - -[ t ] [ object \ f class-not \ f class-or class<= ] unit-test - -[ ] [ object flatten-builtin-class drop ] unit-test - -SINGLETON: sa -SINGLETON: sb -SINGLETON: sc - [ sa ] [ sa { sa sb sc } min-class ] unit-test -[ f ] [ sa sb classes-intersect? ] unit-test - -[ +lt+ ] [ integer sequence class<=> ] unit-test -[ +lt+ ] [ sequence object class<=> ] unit-test -[ +gt+ ] [ object sequence class<=> ] unit-test -[ +eq+ ] [ integer integer class<=> ] unit-test - -! Limitations: - -! UNION: u1 sa sb ; -! UNION: u2 sc ; - -! [ f ] [ u1 u2 classes-intersect? ] unit-test +[ \ + flatten-class ] must-fail diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index 06857d3c71..5ae4f03598 100755 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -5,18 +5,41 @@ vectors assocs namespaces words sorting layouts math hashtables kernel.private sets math.order ; IN: classes.algebra -TUPLE: anonymous-union members ; + anonymous-union -TUPLE: anonymous-intersection participants ; +TUPLE: anonymous-intersection { participants read-only } ; C: anonymous-intersection -TUPLE: anonymous-complement class ; +TUPLE: anonymous-complement { class read-only } ; C: anonymous-complement +DEFER: (class<=) + +DEFER: (class-not) + +GENERIC: (classes-intersect?) ( first second -- ? ) + +DEFER: (class-and) + +DEFER: (class-or) + +GENERIC: (flatten-class) ( class -- ) + +: normalize-class ( class -- class' ) + { + { [ dup members ] [ members ] } + { [ dup participants ] [ participants ] } + [ ] + } cond ; + +PRIVATE> + GENERIC: valid-class? ( obj -- ? ) M: class valid-class? drop t ; @@ -25,40 +48,42 @@ M: anonymous-intersection valid-class? participants>> [ valid-class? ] all? ; M: anonymous-complement valid-class? class>> valid-class? ; M: word valid-class? drop f ; -DEFER: (class<=) - : class<= ( first second -- ? ) class<=-cache get [ (class<=) ] 2cache ; -DEFER: (class-not) +: class< ( first second -- ? ) + { + { [ 2dup class<= not ] [ 2drop f ] } + { [ 2dup swap class<= not ] [ 2drop t ] } + [ [ rank-class ] bi@ < ] + } cond ; + +: class<=> ( first second -- ? ) + { + { [ 2dup class<= not ] [ 2drop +gt+ ] } + { [ 2dup swap class<= not ] [ 2drop +lt+ ] } + [ [ rank-class ] bi@ <=> ] + } cond ; + +: class= ( first second -- ? ) + [ class<= ] [ swap class<= ] 2bi and ; : class-not ( class -- complement ) class-not-cache get [ (class-not) ] cache ; -GENERIC: (classes-intersect?) ( first second -- ? ) - -: normalize-class ( class -- class' ) - { - { [ dup members ] [ members ] } - { [ dup participants ] [ participants ] } - [ ] - } cond ; - : classes-intersect? ( first second -- ? ) classes-intersect-cache get [ normalize-class (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 ; + ] } cond ; -: class< ( first second -- ? ) - { - { [ 2dup class<= not ] [ 2drop f ] } - { [ 2dup swap class<= not ] [ 2drop t ] } - [ [ rank-class ] bi@ < ] - } cond ; +M: anonymous-union (flatten-class) + members>> [ (flatten-class) ] each ; -: class<=> ( first second -- ? ) - { - { [ 2dup class<= not ] [ 2drop +gt+ ] } - { [ 2dup swap class<= not ] [ 2drop +lt+ ] } - [ [ rank-class ] bi@ <=> ] - } cond ; - -: class= ( first second -- ? ) - [ class<= ] [ swap class<= ] 2bi and ; +PRIVATE> ERROR: topological-sort-failed ; @@ -211,7 +224,7 @@ ERROR: topological-sort-failed ; : sort-classes ( seq -- newseq ) [ name>> ] sort-with >vector [ dup empty? not ] - [ dup largest-class [ over remove-nth! drop ] dip ] + [ dup largest-class [ swap remove-nth! ] dip ] produce nip ; : smallest-class ( classes -- class/f ) @@ -220,22 +233,5 @@ ERROR: topological-sort-failed ; [ ] [ [ class<= ] most ] map-reduce ] if-empty ; -GENERIC: (flatten-class) ( class -- ) - -M: anonymous-union (flatten-class) - members>> [ (flatten-class) ] each ; - : flatten-class ( class -- assoc ) [ (flatten-class) ] H{ } make-assoc ; - -: 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-type ( class -- tag/f ) - class-types dup length 1 = [ first ] [ drop f ] if ; diff --git a/core/classes/builtin/builtin.factor b/core/classes/builtin/builtin.factor index 6185e4f24d..028225ec49 100644 --- a/core/classes/builtin/builtin.factor +++ b/core/classes/builtin/builtin.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors classes classes.algebra words kernel -kernel.private namespaces sequences math math.private -combinators assocs quotations ; +USING: accessors classes classes.algebra classes.algebra.private +words kernel kernel.private namespaces sequences math +math.private combinators assocs quotations ; IN: classes.builtin SYMBOL: builtins @@ -36,6 +36,6 @@ M: builtin-class (classes-intersect?) [ swap classes-intersect? ] } cond ; -: full-cover ( -- ) builtins get sift [ (flatten-class) ] each ; +: full-cover ( -- ) builtins get [ (flatten-class) ] each ; M: anonymous-complement (flatten-class) drop full-cover ; diff --git a/core/classes/intersection/intersection.factor b/core/classes/intersection/intersection.factor index a0481a62a7..36514f3cb2 100644 --- a/core/classes/intersection/intersection.factor +++ b/core/classes/intersection/intersection.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: words accessors sequences kernel assocs combinators classes -classes.algebra classes.builtin namespaces arrays math quotations ; +classes.algebra classes.algebra.private classes.builtin +namespaces arrays math quotations ; IN: classes.intersection PREDICATE: intersection-class < class diff --git a/core/classes/predicate/predicate.factor b/core/classes/predicate/predicate.factor index e544c7f8ab..eab2746dea 100644 --- a/core/classes/predicate/predicate.factor +++ b/core/classes/predicate/predicate.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: classes classes.algebra kernel namespaces make words -sequences quotations arrays kernel.private assocs combinators ; +USING: classes classes.algebra classes.algebra.private kernel +namespaces make words sequences quotations arrays kernel.private +assocs combinators ; IN: classes.predicate PREDICATE: predicate-class < class diff --git a/core/classes/singleton/singleton.factor b/core/classes/singleton/singleton.factor index 0db49cefa0..e1caf4f46b 100644 --- a/core/classes/singleton/singleton.factor +++ b/core/classes/singleton/singleton.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008, 2009 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: classes classes.algebra classes.predicate kernel -sequences words ; +USING: classes classes.algebra classes.algebra.private +classes.predicate kernel sequences words ; IN: classes.singleton : singleton-predicate-quot ( class -- quot ) [ eq? ] curry ; diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 3e449e624e..d5c8b4dcff 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -3,8 +3,9 @@ USING: arrays definitions hashtables kernel kernel.private math namespaces make sequences sequences.private strings vectors words quotations memory combinators generic classes -classes.algebra classes.builtin classes.private slots.private -slots math.private accessors assocs effects ; +classes.algebra classes.algebra.private classes.builtin +classes.private slots.private slots math.private accessors +assocs effects ; IN: classes.tuple PREDICATE: tuple-class < class diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor index e0e86e40c0..4615d316ac 100755 --- a/core/classes/union/union.factor +++ b/core/classes/union/union.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: words sequences kernel assocs combinators classes -classes.algebra namespaces arrays math quotations ; +classes.algebra classes.algebra.private namespaces arrays math +quotations ; IN: classes.union PREDICATE: union-class < class