Trying to fix mixin semantics
parent
d3db7e0225
commit
af41dc6169
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2005, 2009 Slava Pestov.
|
||||
! Copyright (C) 2005, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math math.order strings arrays vectors sequences
|
||||
sequences.private accessors fry ;
|
||||
|
@ -20,14 +20,16 @@ M: chunking-seq set-nth group@ <slice> 0 swap copy ;
|
|||
|
||||
M: chunking-seq like drop { } like ; inline
|
||||
|
||||
INSTANCE: chunking-seq sequence
|
||||
|
||||
MIXIN: subseq-chunking
|
||||
|
||||
INSTANCE: subseq-chunking sequence
|
||||
|
||||
M: subseq-chunking nth group@ subseq ; inline
|
||||
|
||||
MIXIN: slice-chunking
|
||||
|
||||
INSTANCE: slice-chunking sequence
|
||||
|
||||
M: slice-chunking nth group@ <slice> ; inline
|
||||
|
||||
M: slice-chunking nth-unsafe group@ slice boa ; inline
|
||||
|
|
|
@ -79,9 +79,9 @@ INSTANCE: union-with-one-member mixin-with-one-member
|
|||
|
||||
[ t ] [ a1 b1 class-or a1 c1 class-or class-and a1 class<= ] unit-test
|
||||
|
||||
[ t ] [ growable tuple sequence class-and class<= ] unit-test
|
||||
[ f ] [ growable tuple sequence class-and class<= ] unit-test
|
||||
|
||||
[ t ] [ growable assoc class-and tuple class<= ] unit-test
|
||||
[ f ] [ growable assoc class-and tuple class<= ] unit-test
|
||||
|
||||
[ t ] [ object \ f \ f class-not class-or class<= ] unit-test
|
||||
|
||||
|
@ -130,6 +130,11 @@ INSTANCE: union-with-one-member mixin-with-one-member
|
|||
[ t ] [ a union-with-one-member class<= ] unit-test
|
||||
[ f ] [ union-with-one-member class-not integer class<= ] unit-test
|
||||
|
||||
MIXIN: empty-mixin
|
||||
|
||||
[ f ] [ empty-mixin class-not null class<= ] unit-test
|
||||
[ f ] [ empty-mixin null class<= ] unit-test
|
||||
|
||||
! class-and
|
||||
: class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ;
|
||||
|
||||
|
@ -146,8 +151,6 @@ INSTANCE: union-with-one-member mixin-with-one-member
|
|||
[ 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
|
||||
|
@ -160,7 +163,8 @@ INSTANCE: union-with-one-member mixin-with-one-member
|
|||
|
||||
! classes-intersect?
|
||||
[ t ] [ both tuple classes-intersect? ] unit-test
|
||||
[ f ] [ vector virtual-sequence classes-intersect? ] unit-test
|
||||
|
||||
[ t ] [ vector virtual-sequence classes-intersect? ] unit-test
|
||||
|
||||
[ t ] [ number vector class-or sequence classes-intersect? ] unit-test
|
||||
|
||||
|
@ -188,11 +192,11 @@ INSTANCE: union-with-one-member mixin-with-one-member
|
|||
[ t ] [ union-with-one-member object classes-intersect? ] unit-test
|
||||
|
||||
[ t ] [ a mixin-with-one-member classes-intersect? ] unit-test
|
||||
[ f ] [ fixnum mixin-with-one-member classes-intersect? ] unit-test
|
||||
[ t ] [ 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
|
||||
[ f ] [ mixin-with-one-member fixnum classes-intersect? ] unit-test
|
||||
[ t ] [ mixin-with-one-member fixnum classes-intersect? ] unit-test
|
||||
[ t ] [ mixin-with-one-member object classes-intersect? ] unit-test
|
||||
|
||||
! class=
|
||||
|
|
|
@ -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: kernel classes combinators accessors sequences arrays
|
||||
vectors assocs namespaces words sorting layouts math hashtables
|
||||
|
@ -34,12 +34,9 @@ DEFER: (class-or)
|
|||
|
||||
GENERIC: (flatten-class) ( class -- )
|
||||
|
||||
: normalize-class ( class -- class' )
|
||||
{
|
||||
{ [ dup members ] [ members <anonymous-union> normalize-class ] }
|
||||
{ [ dup participants ] [ participants <anonymous-intersection> normalize-class ] }
|
||||
[ ]
|
||||
} cond ;
|
||||
GENERIC: normalize-class ( class -- class' )
|
||||
|
||||
M: object normalize-class ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
@ -93,6 +90,9 @@ M: word valid-class? drop f ;
|
|||
: left-anonymous-union<= ( first second -- ? )
|
||||
[ members>> ] dip [ class<= ] curry all? ;
|
||||
|
||||
: right-union<= ( first second -- ? )
|
||||
members [ class<= ] with any? ;
|
||||
|
||||
: right-anonymous-union<= ( first second -- ? )
|
||||
members>> [ class<= ] with any? ;
|
||||
|
||||
|
@ -117,7 +117,7 @@ M: word valid-class? drop f ;
|
|||
[ class-not normalize-class ] map
|
||||
<anonymous-union>
|
||||
] }
|
||||
[ <anonymous-complement> ]
|
||||
[ drop object ]
|
||||
} cond ;
|
||||
|
||||
: left-anonymous-complement<= ( first second -- ? )
|
||||
|
@ -147,6 +147,7 @@ PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;
|
|||
{ [ over anonymous-union? ] [ left-anonymous-union<= ] }
|
||||
{ [ over anonymous-intersection? ] [ left-anonymous-intersection<= ] }
|
||||
{ [ over nontrivial-anonymous-complement? ] [ left-anonymous-complement<= ] }
|
||||
{ [ dup members ] [ right-union<= ] }
|
||||
{ [ dup anonymous-union? ] [ right-anonymous-union<= ] }
|
||||
{ [ dup anonymous-intersection? ] [ right-anonymous-intersection<= ] }
|
||||
{ [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }
|
||||
|
|
|
@ -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: words accessors sequences kernel assocs combinators classes
|
||||
classes.algebra classes.algebra.private classes.builtin
|
||||
|
@ -33,6 +33,9 @@ M: intersection-class rank-class drop 2 ;
|
|||
M: intersection-class instance?
|
||||
"participants" word-prop [ instance? ] with all? ;
|
||||
|
||||
M: intersection-class normalize-class
|
||||
participants <anonymous-intersection> normalize-class ;
|
||||
|
||||
M: intersection-class (flatten-class)
|
||||
participants <anonymous-intersection> (flatten-class) ;
|
||||
|
||||
|
|
|
@ -38,8 +38,8 @@ MIXIN: mx1
|
|||
INSTANCE: integer mx1
|
||||
|
||||
[ t ] [ integer mx1 class<= ] unit-test
|
||||
[ t ] [ mx1 integer class<= ] unit-test
|
||||
[ t ] [ mx1 number class<= ] unit-test
|
||||
[ f ] [ mx1 integer class<= ] unit-test
|
||||
[ f ] [ mx1 number class<= ] unit-test
|
||||
|
||||
"IN: classes.mixin.tests USE: arrays INSTANCE: array mx1" eval( -- )
|
||||
|
||||
|
|
|
@ -1,11 +1,17 @@
|
|||
! Copyright (C) 2004, 2009 Slava Pestov.
|
||||
! Copyright (C) 2004, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: classes classes.union words kernel sequences
|
||||
definitions combinators arrays assocs generic accessors ;
|
||||
USING: classes classes.algebra classes.algebra.private
|
||||
classes.union words kernel sequences definitions combinators
|
||||
arrays assocs generic accessors ;
|
||||
IN: classes.mixin
|
||||
|
||||
PREDICATE: mixin-class < union-class "mixin" word-prop ;
|
||||
|
||||
M: mixin-class normalize-class ;
|
||||
|
||||
M: mixin-class (classes-intersect?)
|
||||
members [ classes-intersect? ] with any? ;
|
||||
|
||||
M: mixin-class reset-class
|
||||
[ call-next-method ] [ { "mixin" } reset-props ] bi ;
|
||||
|
||||
|
@ -53,13 +59,6 @@ TUPLE: check-mixin-class class ;
|
|||
GENERIC# add-mixin-instance 1 ( class mixin -- )
|
||||
|
||||
M: class add-mixin-instance
|
||||
#! Note: we call update-classes on the new member, not the
|
||||
#! mixin. This ensures that we only have to update the
|
||||
#! methods whose specializer intersects the new member, not
|
||||
#! the entire mixin (since the other mixin members are not
|
||||
#! affected at all). Also, all usages of the mixin will get
|
||||
#! updated by transitivity; the mixins usages appear in
|
||||
#! class-usages of the member, now that it's been added.
|
||||
[ 2drop ] [
|
||||
[ (add-mixin-instance) ] 2keep
|
||||
[ nip ] [ [ new-class? ] either? ] 2bi
|
||||
|
|
|
@ -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: words sequences kernel assocs combinators classes
|
||||
classes.algebra classes.algebra.private namespaces arrays math
|
||||
|
@ -34,5 +34,8 @@ M: union-class rank-class drop 2 ;
|
|||
M: union-class instance?
|
||||
"members" word-prop [ instance? ] with any? ;
|
||||
|
||||
M: union-class normalize-class
|
||||
members <anonymous-union> normalize-class ;
|
||||
|
||||
M: union-class (flatten-class)
|
||||
members <anonymous-union> (flatten-class) ;
|
||||
|
|
Loading…
Reference in New Issue