steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

object is now an empty intersection

db4
Slava Pestov 2008-05-11 01:37:37 -05:00
parent aaf8e66215
commit a42756abac
3 changed files with 33 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
core/bootstrap/primitives.factor
View File

@ -5,8 +5,9 @@ hashtables.private io kernel math namespaces parser sequences
strings vectors words quotations assocs layouts classes
classes.builtin classes.tuple classes.tuple.private
kernel.private vocabs vocabs.loader source-files definitions
slots.deprecated classes.union compiler.units
bootstrap.image.private io.files accessors combinators ;
slots.deprecated classes.union classes.intersection
compiler.units bootstrap.image.private io.files accessors
combinators ;
IN: bootstrap.primitives
"Creating primitives and basic runtime structures..." print flush
@ -159,16 +160,16 @@ bootstrapping? on
"tuple-layout" "classes.tuple.private" create register-builtin
! Catch-all class for providing a default method.
"object" "kernel" create
[ f builtins get [ ] filter f union-class define-class ]
[ [ drop t ] "predicate" set-word-prop ]
bi
! "object" "kernel" create
! [ f f { } intersection-class define-class ]
! [ f builtins get [ ] filter f union-class define-class ]
! [ [ drop t ] "predicate" set-word-prop ]
! bi
"object" "kernel" create
[ f f { } intersection-class define-class ]
[ [ drop t ] "predicate" set-word-prop ]
bi
"object?" "kernel" vocab-words delete-at
! Class of objects with object tag

6
core/classes/algebra/algebra-tests.factor
View File

@ -1,10 +1,10 @@
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 kernel.private sbufs math.order ;
IN: classes.algebra.tests
\ class< must-infer
\ class-and must-infer
@ -277,7 +277,7 @@ INTERSECTION: generic-class generic class ;
[
[ t ] [ \ class generic class-and generic-class class<= ] unit-test
[ t ] [ \ class generic class-and generic-class swap class<= ] unit-test
] call drop
] drop
[ t ] [ \ word generic-class classes-intersect? ] unit-test
[ f ] [ number generic-class classes-intersect? ] unit-test
@ -300,3 +300,5 @@ INTERSECTION: empty-intersection ;
[ 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

39
core/classes/algebra/algebra.factor
View File

@ -95,25 +95,26 @@ PREDICATE: nontrivial-anonymous-complement < anonymous-complement
[ participants ]
} cleave or or or ;
PREDICATE: empty-union < anonymous-union members>> empty? ;
PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;
: (class<=) ( first second -- -1/0/1 )
{
{ [ 2dup eq? ] [ 2drop t ] }
{ [ dup object eq? ] [ 2drop t ] }
{ [ over null eq? ] [ 2drop t ] }
[
[ normalize-class ] bi@ {
{ [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement<= ] }
{ [ over anonymous-union? ] [ left-anonymous-union<= ] }
{ [ over anonymous-intersection? ] [ left-anonymous-intersection<= ] }
{ [ over nontrivial-anonymous-complement? ] [ left-anonymous-complement<= ] }
{ [ dup anonymous-union? ] [ right-anonymous-union<= ] }
{ [ dup anonymous-intersection? ] [ right-anonymous-intersection<= ] }
{ [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }
{ [ over superclass ] [ superclass<= ] }
[ 2drop f ]
} cond
]
} cond ;
2dup eq? [ 2drop t ] [
[ normalize-class ] bi@ {
{ [ dup empty-intersection? ] [ 2drop t ] }
{ [ over empty-union? ] [ 2drop t ] }
{ [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement<= ] }
{ [ over anonymous-union? ] [ left-anonymous-union<= ] }
{ [ over anonymous-intersection? ] [ left-anonymous-intersection<= ] }
{ [ over nontrivial-anonymous-complement? ] [ left-anonymous-complement<= ] }
{ [ dup anonymous-union? ] [ right-anonymous-union<= ] }
{ [ dup anonymous-intersection? ] [ right-anonymous-intersection<= ] }
{ [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }
{ [ over superclass ] [ superclass<= ] }
[ 2drop f ]
} cond
] if ;
: anonymous-union-intersect? ( first second -- ? )
members>> [ classes-intersect? ] with contains? ;
@ -230,7 +231,7 @@ DEFER: flatten-builtin-class
: flatten-intersection-class ( class -- )
participants [ flatten-builtin-class ] map
dup empty? [
drop object (flatten-class)
drop builtins get [ (flatten-class) ] each
] [
unclip [ assoc-intersect ] reduce [ swap set ] assoc-each
] if ;