M: anonymous-complement rank-class drop 3 ;
+M: anonymous-complement predicate-def
+ class>> '[ [ _ instance? not ] [ t ] if* ] curry ;
+
M: anonymous-complement instance?
over [ class>> instance? not ] [ 2drop t ] if ;
[ normalize-complement ] dip class<= ;
PREDICATE: nontrivial-anonymous-complement < anonymous-complement
- class>> {
- [ anonymous-union? ]
- [ anonymous-intersection? ]
- [ class-members ]
- [ class-participants ]
- } cleave or or or ;
+ class>> dup anonymous-union? [ drop t ] [
+ dup anonymous-intersection? [ drop t ] [
+ dup class-members [ drop t ] [
+ class-participants
+ ] if
+ ] if
+ ] if ;
PREDICATE: empty-union < anonymous-union members>> empty? ;
<PRIVATE
-: intersection-predicate-quot ( members -- quot )
+: intersection-predicate-quot ( participants -- quot )
[
[ drop t ]
] [
M: anonymous-intersection class-name
participants>> [ class-name ] map join-words ;
+M: anonymous-intersection predicate-def
+ participants>> intersection-predicate-quot ;
+
PRIVATE>
: define-intersection-class ( class participants -- )
M: class union-of-builtins?
drop f ;
-: empty-union-predicate-quot ( class -- quot )
+: empty-union-predicate-quot ( class-members -- quot )
drop [ drop f ] ;
-: flatten-builtins ( class/builtin-classes -- seq )
- dup sequence? [
- [ flatten-class ] map concat
- ] [
- flatten-class
- ] if ;
+: flatten-builtins ( builtin-classes -- seq )
+ [ flatten-class ] map concat ;
: builtin-union-mask ( builtin-classes -- n )
0 [ class>type 2^ bitor ] reduce ;
-: builtin-union-predicate-quot ( class/builtin-classes -- quot )
+: builtin-union-predicate-quot ( builtin-classes -- quot )
flatten-builtins dup length 1 = [
first class>type [ eq? ] curry [ tag ] prepose
] [
[ layout-of ] prepose [ drop f ] [ if ] 2curry
[ dup tuple? ] prepose ;
-: full-union-predicate-quot ( class -- quot )
- class-members
+: full-union-predicate-quot ( class-members -- quot )
[ union-of-builtins? ] partition
[ [ f ] [ builtin-union-predicate-quot ] if-empty ] dip
[ [ tuple-class? ] [ tuple-layout ] bi and ] partition
swap [ suffix ] when*
predicate-quot ;
-: union-predicate-quot ( class -- quot )
+: union-predicate-quot ( class-members -- quot )
{
- { [ dup class-members empty? ] [ empty-union-predicate-quot ] }
- { [ dup union-of-builtins? ] [ builtin-union-predicate-quot ] }
+ { [ dup empty? ] [ empty-union-predicate-quot ] }
+ { [ dup [ union-of-builtins? ] all? ] [ builtin-union-predicate-quot ] }
[ full-union-predicate-quot ]
} cond ;
: define-union-predicate ( class -- )
- dup union-predicate-quot define-predicate ;
+ dup class-members union-predicate-quot define-predicate ;
M: union-class update-class define-union-predicate ;
M: union-class instance?
"members" word-prop [ instance? ] with any? ;
+M: anonymous-union predicate-def
+ members>> union-predicate-quot ;
+
M: anonymous-union instance?
members>> [ instance? ] with any? ;