From c1782794542d7a679b90048c80e58a0fa92fa828 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 21 Jan 2010 00:44:34 +1300 Subject: [PATCH] Clean up class algebra a bit, and change mixins to recompile less, taking advantage of new semantics --- core/bootstrap/primitives.factor | 3 ++ core/classes/algebra/algebra-tests.factor | 6 ++-- core/classes/builtin/builtin.factor | 7 +---- core/classes/intersection/intersection.factor | 14 +++++---- core/classes/mixin/mixin.factor | 29 ++++++++----------- core/classes/predicate/predicate.factor | 6 +++- core/classes/singleton/singleton.factor | 9 ++++-- core/classes/tuple/tuple-docs.factor | 3 +- core/classes/union/union.factor | 4 +++ 9 files changed, 45 insertions(+), 36 deletions(-) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 67107c8c9a..ecf66834ce 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -126,6 +126,9 @@ call( -- ) prepare-slots make-slots 1 finalize-slots [ "slots" set-word-prop ] [ define-accessors ] 2bi ; +: define-builtin-predicate ( class -- ) + dup class>type [ eq? ] curry [ tag ] prepend define-predicate ; + : define-builtin ( symbol slotspec -- ) [ [ define-builtin-predicate ] keep ] dip define-builtin-slots ; diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor index 39b1a2d4e7..fcce372fe8 100644 --- a/core/classes/algebra/algebra-tests.factor +++ b/core/classes/algebra/algebra-tests.factor @@ -164,7 +164,7 @@ MIXIN: empty-mixin ! classes-intersect? [ t ] [ both tuple classes-intersect? ] unit-test -[ t ] [ vector virtual-sequence classes-intersect? ] unit-test +[ f ] [ vector virtual-sequence classes-intersect? ] unit-test [ t ] [ number vector class-or sequence classes-intersect? ] unit-test @@ -192,11 +192,11 @@ MIXIN: empty-mixin [ t ] [ union-with-one-member object classes-intersect? ] unit-test [ t ] [ a mixin-with-one-member classes-intersect? ] unit-test -[ t ] [ fixnum mixin-with-one-member classes-intersect? ] unit-test +[ f ] [ fixnum mixin-with-one-member classes-intersect? ] unit-test [ t ] [ object mixin-with-one-member classes-intersect? ] unit-test [ t ] [ mixin-with-one-member a classes-intersect? ] unit-test -[ t ] [ mixin-with-one-member fixnum classes-intersect? ] unit-test +[ f ] [ mixin-with-one-member fixnum classes-intersect? ] unit-test [ t ] [ mixin-with-one-member object classes-intersect? ] unit-test ! class= diff --git a/core/classes/builtin/builtin.factor b/core/classes/builtin/builtin.factor index 028225ec49..fd14a64e35 100644 --- a/core/classes/builtin/builtin.factor +++ b/core/classes/builtin/builtin.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2004, 2008 Slava Pestov. +! Copyright (C) 2004, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors classes classes.algebra classes.algebra.private words kernel kernel.private namespaces sequences math @@ -20,11 +20,6 @@ M: object class tag type>class ; inline M: builtin-class rank-class drop 0 ; -GENERIC: define-builtin-predicate ( class -- ) - -M: builtin-class define-builtin-predicate - dup class>type [ eq? ] curry [ tag ] prepend define-predicate ; - M: builtin-class instance? [ tag ] [ class>type ] bi* eq? ; M: builtin-class (flatten-class) dup set ; diff --git a/core/classes/intersection/intersection.factor b/core/classes/intersection/intersection.factor index 6eb9f57823..242f099ea0 100644 --- a/core/classes/intersection/intersection.factor +++ b/core/classes/intersection/intersection.factor @@ -8,6 +8,8 @@ IN: classes.intersection PREDICATE: intersection-class < class "metaclass" word-prop intersection-class eq? ; + + +: define-intersection-class ( class participants -- ) + [ [ f f ] dip intersection-class define-class ] + [ drop update-classes ] + 2bi ; diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor index 8a7599205d..3a6670a4f7 100644 --- a/core/classes/mixin/mixin.factor +++ b/core/classes/mixin/mixin.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2004, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: classes classes.algebra classes.algebra.private -classes.union words kernel sequences definitions combinators -arrays assocs generic accessors ; +classes.union classes.union.private words kernel sequences +definitions combinators arrays assocs generic accessors ; IN: classes.mixin PREDICATE: mixin-class < union-class "mixin" word-prop ; @@ -46,40 +46,35 @@ TUPLE: check-mixin-class class ; [ [ members swap bootstrap-word ] dip call ] [ drop ] 2bi swap redefine-mixin-class ; inline -: update-classes/new ( mixin -- ) +: update-mixin-class ( member mixin -- ) class-usages + [ update-methods ] [ [ update-class ] each ] - [ implementors [ remake-generic ] each ] bi ; + [ implementors [ remake-generic ] each ] + tri ; : (add-mixin-instance) ( class mixin -- ) [ [ suffix ] change-mixin-class ] [ [ f ] 2dip "instances" word-prop set-at ] - 2bi ; + [ update-mixin-class ] + 2tri ; GENERIC# add-mixin-instance 1 ( class mixin -- ) M: class add-mixin-instance - [ 2drop ] [ - [ (add-mixin-instance) ] 2keep - [ nip ] [ [ new-class? ] either? ] 2bi - [ update-classes/new ] [ update-classes ] if - ] if-mixin-member? ; + [ 2drop ] [ (add-mixin-instance) ] if-mixin-member? ; : (remove-mixin-instance) ( class mixin -- ) [ [ swap remove ] change-mixin-class ] [ "instances" word-prop delete-at ] - 2bi ; + [ update-mixin-class ] + 2tri ; : remove-mixin-instance ( class mixin -- ) #! The order of the three clauses is important here. The last #! one must come after the other two so that the entries it #! adds to changed-generics are not overwritten. - [ - [ (remove-mixin-instance) ] - [ nip update-classes ] - [ class-usages update-methods ] - 2tri - ] [ 2drop ] if-mixin-member? ; + [ (remove-mixin-instance) ] [ 2drop ] if-mixin-member? ; M: mixin-class class-forgotten remove-mixin-instance ; diff --git a/core/classes/predicate/predicate.factor b/core/classes/predicate/predicate.factor index eab2746dea..c0dfb4efa0 100644 --- a/core/classes/predicate/predicate.factor +++ b/core/classes/predicate/predicate.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2004, 2009 Slava Pestov. +! Copyright (C) 2004, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: classes classes.algebra classes.algebra.private kernel namespaces make words sequences quotations arrays kernel.private @@ -8,6 +8,8 @@ IN: classes.predicate PREDICATE: predicate-class < class "metaclass" word-prop predicate-class eq? ; + + : define-predicate-class ( class superclass definition -- ) [ drop f f predicate-class define-class ] [ nip "predicate-definition" set-word-prop ] diff --git a/core/classes/singleton/singleton.factor b/core/classes/singleton/singleton.factor index e1caf4f46b..02ca405145 100644 --- a/core/classes/singleton/singleton.factor +++ b/core/classes/singleton/singleton.factor @@ -1,11 +1,16 @@ -! Copyright (C) 2008, 2009 Doug Coleman, Slava Pestov. +! Copyright (C) 2008, 2010 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: classes classes.algebra classes.algebra.private -classes.predicate kernel sequences words ; +classes.predicate classes.predicate.private kernel sequences +words ; IN: classes.singleton + + PREDICATE: singleton-class < predicate-class [ "predicate-definition" word-prop ] [ singleton-predicate-quot ] diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index 45d3931448..4dcbf86280 100644 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -348,8 +348,7 @@ HELP: tuple-class HELP: tuple= { $values { "tuple1" tuple } { "tuple2" tuple } { "?" "a boolean" } } -{ $description "Low-level tuple equality test. User code should use " { $link = } " instead." } -{ $warning "This word is in the " { $vocab-link "classes.tuple.private" } " vocabulary because it does not do any type checking. Passing values which are not tuples can result in memory corruption." } ; +{ $description "Checks if two tuples have equal slot values. This is the default behavior of " { $link = } " on tuples, unless the tuple class subclasses " { $link identity-tuple } " or implements a method on " { $link equal? } ". In cases where equality has been redefined, this word can be used to get the default semantics if needed." } ; HELP: tuple { $class-description "The class of tuples. This class is further partitioned into disjoint subclasses; each tuple shape defined by " { $link POSTPONE: TUPLE: } " is a new class." diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor index 6774848677..9540b0be86 100644 --- a/core/classes/union/union.factor +++ b/core/classes/union/union.factor @@ -8,6 +8,8 @@ IN: classes.union PREDICATE: union-class < class "metaclass" word-prop union-class eq? ; + + : define-union-class ( class members -- ) [ (define-union-class) ] [ drop update-classes ] 2bi ;