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

Working on intersection classes

db4
Slava Pestov 2008-05-10 18:09:05 -05:00
parent 3b914f0a9d
commit 315110eb09
14 changed files with 183 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
core/bootstrap/syntax.factor
View File

@ -46,6 +46,7 @@ IN: bootstrap.syntax
"TUPLE:"
"T{"
"UNION:"
"INTERSECTION:"
"USE:"
"USING:"
"V{"

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

@ -6,6 +6,12 @@ classes.private classes.union classes.mixin classes.predicate
vectors definitions source-files compiler.units growable
random inference effects kernel.private sbufs math.order ;
\ class< must-infer
\ class-and must-infer
\ class-or must-infer
\ flatten-class must-infer
\ flatten-builtin-class must-infer
: class= [ class<= ] [ swap class<= ] 2bi and ;
: class-and* >r class-and r> class= ;
@ -261,3 +267,18 @@ TUPLE: xg < xb ;
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
[ t ] [ \ class generic class-and generic-class class<= ] unit-test
[ t ] [ \ class generic class-and generic-class swap class<= ] unit-test
[ 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

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

@ -37,7 +37,7 @@ TUPLE: anonymous-union members ;
C: <anonymous-union> anonymous-union
TUPLE: anonymous-intersection members ;
TUPLE: anonymous-intersection participants ;
C: <anonymous-intersection> anonymous-intersection
@ -54,19 +54,25 @@ C: <anonymous-complement> anonymous-complement
: right-union-class<= ( first second -- ? )
members [ class<= ] with contains? ;
: left-anonymous-union< ( first second -- ? )
: left-intersection-class<= ( first second -- ? )
>r participants r> [ class<= ] curry contains? ;
: right-intersection-class<= ( first second -- ? )
participants [ class<= ] with all? ;
: left-anonymous-union<= ( first second -- ? )
>r members>> r> [ class<= ] curry all? ;
: right-anonymous-union< ( first second -- ? )
: right-anonymous-union<= ( first second -- ? )
members>> [ class<= ] with contains? ;
: left-anonymous-intersection< ( first second -- ? )
>r members>> r> [ class<= ] curry contains? ;
: left-anonymous-intersection<= ( first second -- ? )
>r participants>> r> [ class<= ] curry contains? ;
: right-anonymous-intersection< ( first second -- ? )
members>> [ class<= ] with all? ;
: right-anonymous-intersection<= ( first second -- ? )
participants>> [ class<= ] with all? ;
: anonymous-complement< ( first second -- ? )
: anonymous-complement<= ( first second -- ? )
[ class>> ] bi@ swap class<= ;
: (class<=) ( first second -- -1/0/1 )
@ -74,15 +80,17 @@ C: <anonymous-complement> anonymous-complement
{ [ 2dup eq? ] [ 2drop t ] }
{ [ dup object eq? ] [ 2drop t ] }
{ [ over null eq? ] [ 2drop t ] }
{ [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement< ] }
{ [ over anonymous-union? ] [ left-anonymous-union< ] }
{ [ over anonymous-intersection? ] [ left-anonymous-intersection< ] }
{ [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement<= ] }
{ [ over anonymous-union? ] [ left-anonymous-union<= ] }
{ [ over anonymous-intersection? ] [ left-anonymous-intersection<= ] }
{ [ over members ] [ left-union-class<= ] }
{ [ dup anonymous-union? ] [ right-anonymous-union< ] }
{ [ dup anonymous-intersection? ] [ right-anonymous-intersection< ] }
{ [ over participants ] [ left-intersection-class<= ] }
{ [ dup anonymous-union? ] [ right-anonymous-union<= ] }
{ [ dup anonymous-intersection? ] [ right-anonymous-intersection<= ] }
{ [ over anonymous-complement? ] [ 2drop f ] }
{ [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }
{ [ dup members ] [ right-union-class<= ] }
{ [ dup participants ] [ right-intersection-class<= ] }
{ [ over superclass ] [ superclass<= ] }
[ 2drop f ]
} cond ;
@ -91,7 +99,7 @@ C: <anonymous-complement> anonymous-complement
members>> [ classes-intersect? ] with contains? ;
: anonymous-intersection-intersect? ( first second -- ? )
members>> [ classes-intersect? ] with all? ;
participants>> [ classes-intersect? ] with all? ;
: anonymous-complement-intersect? ( first second -- ? )
class>> class<= not ;
@ -99,6 +107,9 @@ C: <anonymous-complement> anonymous-complement
: union-class-intersect? ( first second -- ? )
members [ classes-intersect? ] with contains? ;
: intersection-class-intersect? ( first second -- ? )
participants [ classes-intersect? ] with all? ;
: tuple-class-intersect? ( first second -- ? )
{
{ [ over tuple eq? ] [ 2drop t ] }
@ -123,6 +134,7 @@ C: <anonymous-complement> anonymous-complement
{ [ dup builtin-class? ] [ builtin-class-intersect? ] }
{ [ dup superclass ] [ superclass classes-intersect? ] }
{ [ dup members ] [ union-class-intersect? ] }
{ [ dup participants ] [ intersection-class-intersect? ] }
} cond ;
: left-union-and ( first second -- class )
@ -131,6 +143,12 @@ C: <anonymous-complement> anonymous-complement
: right-union-and ( first second -- class )
members [ class-and ] with map <anonymous-union> ;
: left-intersection-and ( first second -- class )
>r participants r> suffix <anonymous-intersection> ;
: right-intersection-and ( first second -- class )
participants swap suffix <anonymous-intersection> ;
: left-anonymous-union-and ( first second -- class )
>r members>> r> [ class-and ] curry map <anonymous-union> ;
@ -138,10 +156,10 @@ C: <anonymous-complement> anonymous-complement
members>> [ class-and ] with map <anonymous-union> ;
: left-anonymous-intersection-and ( first second -- class )
>r members>> r> suffix <anonymous-intersection> ;
>r participants>> r> suffix <anonymous-intersection> ;
: right-anonymous-intersection-and ( first second -- class )
members>> swap suffix <anonymous-intersection> ;
participants>> swap suffix <anonymous-intersection> ;
: (class-and) ( first second -- class )
{
@ -149,9 +167,11 @@ C: <anonymous-complement> anonymous-complement
{ [ 2dup swap class<= ] [ nip ] }
{ [ 2dup classes-intersect? not ] [ 2drop null ] }
{ [ dup members ] [ right-union-and ] }
{ [ dup participants ] [ right-intersection-and ] }
{ [ dup anonymous-union? ] [ right-anonymous-union-and ] }
{ [ dup anonymous-intersection? ] [ right-anonymous-intersection-and ] }
{ [ over members ] [ left-union-and ] }
{ [ over participants ] [ left-intersection-and ] }
{ [ over anonymous-union? ] [ left-anonymous-union-and ] }
{ [ over anonymous-intersection? ] [ left-anonymous-intersection-and ] }
[ 2array <anonymous-intersection> ]
@ -203,11 +223,23 @@ C: <anonymous-complement> anonymous-complement
tuck [ class<= ] with all? [ peek ] [ drop f ] if
] if ;
DEFER: (flatten-class)
DEFER: flatten-builtin-class
: flatten-intersection-class ( class -- )
participants [ flatten-builtin-class ] map
dup empty? [
drop object (flatten-class)
] [
unclip [ assoc-intersect ] reduce [ swap set ] assoc-each
] if ;
: (flatten-class) ( class -- )
{
{ [ dup tuple-class? ] [ dup set ] }
{ [ dup builtin-class? ] [ dup set ] }
{ [ dup members ] [ members [ (flatten-class) ] each ] }
{ [ dup participants ] [ flatten-intersection-class ] }
{ [ dup superclass ] [ superclass (flatten-class) ] }
[ drop ]
} cond ;

7
core/classes/classes-docs.factor
View File

@ -40,6 +40,7 @@ $nl
"There are several sorts of classes:"
{ $subsection "builtin-classes" }
{ $subsection "unions" }
{ $subsection "intersections" }
{ $subsection "mixins" }
{ $subsection "predicates" }
{ $subsection "singletons" }
@ -86,7 +87,11 @@ HELP: members
{ $values { "class" class } { "seq" "a sequence of union members, or " { $link f } } }
{ $description "If " { $snippet "class" } " is a union class, outputs a sequence of its member classes, otherwise outputs " { $link f } "." } ;
HELP: participants
{ $values { "class" class } { "seq" "a sequence of intersection participants, or " { $link f } } }
{ $description "If " { $snippet "class" } " is an intersection class, outputs a sequence of its participant classes, otherwise outputs " { $link f } "." } ;
HELP: define-class
{ $values { "word" word } { "members" "a sequence of class words" } { "superclass" class } { "metaclass" class } }
{ $values { "word" word } { "superclass" class } { "members" "a sequence of class words" } { "participants" "a sequence of class words" } { "metaclass" class } }
{ $description "Sets a property indicating this word is a class word, thus making it an instance of " { $link class } ", and registers it with " { $link update-map } "." }
$low-level-note ;

25
core/classes/classes.factor
View File

@ -57,6 +57,10 @@ PREDICATE: predicate < word "predicating" word-prop >boolean ;
#! Output f for non-classes to work with algebra code
dup class? [ "members" word-prop ] [ drop f ] if ;
: participants ( class -- seq )
#! Output f for non-classes to work with algebra code
dup class? [ "participants" word-prop ] [ drop f ] if ;
GENERIC: rank-class ( class -- n )
GENERIC: reset-class ( class -- )
@ -67,7 +71,12 @@ M: word reset-class drop ;
! update-map
: class-uses ( class -- seq )
[ members ] [ superclass ] bi [ suffix ] when* ;
[
[ members % ]
[ participants % ]
[ superclass [ , ] when* ]
tri
] { } make ;
: class-usages ( class -- assoc )
[ update-map get at ] closure ;
@ -78,12 +87,14 @@ M: word reset-class drop ;
: update-map- ( class -- )
dup class-uses update-map get remove-vertex ;
: make-class-props ( superclass members metaclass -- assoc )
: make-class-props ( superclass members participants metaclass -- assoc )
[
[ dup [ bootstrap-word ] when "superclass" set ]
[ [ bootstrap-word ] map "members" set ]
[ "metaclass" set ]
tri*
{
[ dup [ bootstrap-word ] when "superclass" set ]
[ [ bootstrap-word ] map "members" set ]
[ [ bootstrap-word ] map "participants" set ]
[ "metaclass" set ]
} spread
] H{ } make-assoc ;
: (define-class) ( word props -- )
@ -112,7 +123,7 @@ GENERIC: update-methods ( assoc -- )
[ update-methods ]
bi ;
: define-class ( word superclass members metaclass -- )
: define-class ( word superclass members participants metaclass -- )
#! If it was already a class, update methods after.
reset-caches
make-class-props

28
core/classes/intersection/intersection-docs.factor Normal file
View File

@ -0,0 +1,28 @@
USING: generic help.markup help.syntax kernel kernel.private
namespaces sequences words arrays layouts help effects math
layouts classes.private classes compiler.units ;
IN: classes.intersection
ARTICLE: "intersections" "Intersection classes"
"An object is an instance of a intersection class if it is an instance of all of its participants."
{ $subsection POSTPONE: INTERSECTION: }
{ $subsection define-intersection-class }
"Intersection classes can be introspected:"
{ $subsection participants }
"The set of intersection classes is a class:"
{ $subsection intersection-class }
{ $subsection intersection-class? }
"Intersection classes are used to associate a method with objects which are simultaneously instances of multiple different classes, as well as to conveniently define predicates." ;
ABOUT: "intersections"
HELP: define-intersection-class
{ $values { "class" class } { "participants" "a sequence of classes" } }
{ $description "Defines a intersection class with specified participants. This is the run time equivalent of " { $link POSTPONE: INTERSECTION: } "." }
{ $notes "This word must be called from inside " { $link with-compilation-unit } "." }
{ $side-effects "class" } ;
{ intersection-class define-intersection-class POSTPONE: INTERSECTION: } related-words
HELP: intersection-class
{ $class-description "The class of intersection classes." } ;

33
core/classes/intersection/intersection.factor Normal file
View File

@ -0,0 +1,33 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: words sequences kernel assocs combinators classes
namespaces arrays math quotations ;
IN: classes.intersection
PREDICATE: intersection-class < class
"metaclass" word-prop intersection-class eq? ;
: intersection-predicate-quot ( members -- quot )
dup empty? [
drop [ drop t ]
] [
unclip "predicate" word-prop swap [
"predicate" word-prop [ dup ] swap [ not ] 3append
[ drop f ]
] { } map>assoc alist>quot
] if ;
: define-intersection-predicate ( class -- )
dup participants intersection-predicate-quot define-predicate ;
M: intersection-class update-class define-intersection-predicate ;
: define-intersection-class ( class members -- )
[ f f rot intersection-class define-class ]
[ drop update-classes ]
2bi ;
M: intersection-class reset-class
{ "class" "metaclass" "participants" } reset-props ;
M: intersection-class rank-class drop 2 ;

2
core/classes/predicate/predicate.factor
View File

@ -14,7 +14,7 @@ PREDICATE: predicate-class < class
] [ ] make ;
: define-predicate-class ( class superclass definition -- )
[ drop f predicate-class define-class ]
[ drop f f predicate-class define-class ]
[ nip "predicate-definition" set-word-prop ]
[
2drop

9
core/classes/tuple/tuple.factor
View File

@ -160,7 +160,7 @@ M: tuple-class update-class
tri ;
: define-new-tuple-class ( class superclass slots -- )
[ drop f tuple-class define-class ]
[ drop f f tuple-class define-class ]
[ nip "slot-names" set-word-prop ]
[ 2drop update-classes ]
3tri ;
@ -226,10 +226,11 @@ M: tuple-class reset-class
} reset-props
] bi ;
: reset-tuple-class ( class -- )
[ [ reset-class ] [ update-map- ] bi ] each-subclass ;
M: tuple-class forget*
[ [ reset-class ] each-subclass ]
[ call-next-method ]
bi ;
[ reset-tuple-class ] [ call-next-method ] bi ;
M: tuple-class rank-class drop 0 ;

4
core/classes/union/union-docs.factor
View File

@ -4,7 +4,7 @@ layouts classes.private classes compiler.units ;
IN: classes.union
ARTICLE: "unions" "Union classes"
"An object is an instance of a union class if it is an instance of one of its members. Union classes are used to associate the same method with several different classes, as well as to conveniently define predicates."
"An object is an instance of a union class if it is an instance of one of its members."
{ $subsection POSTPONE: UNION: }
{ $subsection define-union-class }
"Union classes can be introspected:"
@ -12,7 +12,7 @@ ARTICLE: "unions" "Union classes"
"The set of union classes is a class:"
{ $subsection union-class }
{ $subsection union-class? }
"Unions are used to define behavior shared between a fixed set of classes."
"Unions are used to define behavior shared between a fixed set of classes, as well as to conveniently define predicates."
{ $see-also "mixins" "tuple-subclassing" } ;
ABOUT: "unions"

3
core/classes/union/union.factor
View File

@ -7,7 +7,6 @@ IN: classes.union
PREDICATE: union-class < class
"metaclass" word-prop union-class eq? ;
! Union classes for dispatch on multiple classes.
: union-predicate-quot ( members -- quot )
dup empty? [
drop [ drop f ]
@ -24,7 +23,7 @@ PREDICATE: union-class < class
M: union-class update-class define-union-predicate ;
: define-union-class ( class members -- )
[ f swap union-class define-class ]
[ f swap f union-class define-class ]
[ drop update-classes ]
2bi ;

9
core/syntax/syntax.factor
View File

@ -5,8 +5,9 @@ definitions generic hashtables kernel math
namespaces parser sequences strings sbufs vectors words
quotations io assocs splitting classes.tuple generic.standard
generic.math classes io.files vocabs float-arrays
classes.union classes.mixin classes.predicate classes.singleton
compiler.units combinators debugger ;
classes.union classes.intersection classes.mixin
classes.predicate classes.singleton compiler.units
combinators debugger ;
IN: bootstrap.syntax
! These words are defined as a top-level form, instead of with
@ -135,6 +136,10 @@ IN: bootstrap.syntax
CREATE-CLASS parse-definition define-union-class
] define-syntax
"INTERSECTION:" [
CREATE-CLASS parse-definition define-intersection-class
] define-syntax
"MIXIN:" [
CREATE-CLASS define-mixin-class
] define-syntax

2
extra/locals/locals-tests.factor
View File

@ -246,3 +246,5 @@ M:: fixnum next-method-test ( a -- b ) a call-next-method 1 + ;
: no-with-locals-test { 1 2 3 } [| x | x 3 + ] map ;
[ { 4 5 6 } ] [ no-with-locals-test ] unit-test
[ ] [ 1 2 [let | a [ ] b [ ] | ] ] unit-test

16
extra/locals/locals.factor
View File

@ -355,30 +355,34 @@ M: wlet pprint* \ [wlet pprint-let ;
M: let* pprint* \ [let* pprint-let ;
PREDICATE: lambda-word < word
"lambda" word-prop >boolean ;
PREDICATE: lambda-word < word "lambda" word-prop >boolean ;
M: lambda-word definer drop \ :: \ ; ;
M: lambda-word definition
"lambda" word-prop body>> ;
PREDICATE: lambda-macro < macro
"lambda" word-prop >boolean ;
INTERSECTION: lambda-macro macro lambda-word ;
M: lambda-macro definer drop \ MACRO:: \ ; ;
M: lambda-macro definition
"lambda" word-prop body>> ;
PREDICATE: lambda-method < method-body
"lambda" word-prop >boolean ;
INTERSECTION: lambda-method method-body lambda-word ;
M: lambda-method definer drop \ M:: \ ; ;
M: lambda-method definition
"lambda" word-prop body>> ;
INTERSECTION: lambda-memoized memoized lambda-word ;
M: lambda-memoized definer drop \ MEMO:: \ ; ;
M: lambda-memoized definition
"lambda" word-prop body>> ;
: method-stack-effect ( method -- effect )
dup "lambda" word-prop vars>>
swap "method-generic" word-prop stack-effect