factor: superclass -> superclass-of, superclasses -> superclasses-of

db4
Doug Coleman 2015-07-20 00:46:33 -07:00
parent 2adeed9cb3
commit e4c39bcf3c
17 changed files with 54 additions and 55 deletions

View File

@ -373,13 +373,13 @@ TUPLE: a-subclass < will-become-struct ;
{ f } [ will-become-struct struct-class? ] unit-test { f } [ will-become-struct struct-class? ] unit-test
{ will-become-struct } [ a-subclass superclass ] unit-test { will-become-struct } [ a-subclass superclass-of ] unit-test
{ } [ "IN: classes.struct.tests USING: classes.struct alien.c-types ; STRUCT: will-become-struct { x int } ;" eval( -- ) ] unit-test { } [ "IN: classes.struct.tests USING: classes.struct alien.c-types ; STRUCT: will-become-struct { x int } ;" eval( -- ) ] unit-test
{ t } [ will-become-struct struct-class? ] unit-test { t } [ will-become-struct struct-class? ] unit-test
{ tuple } [ a-subclass superclass ] unit-test { tuple } [ a-subclass superclass-of ] unit-test
STRUCT: bit-field-test STRUCT: bit-field-test
{ a uint bits: 12 } { a uint bits: 12 }

View File

@ -35,7 +35,7 @@ TUPLE: struct-bit-slot-spec < struct-slot-spec
bits signed? ; bits signed? ;
PREDICATE: struct-class < tuple-class PREDICATE: struct-class < tuple-class
superclass \ struct eq? ; superclass-of \ struct eq? ;
SLOT: fields SLOT: fields

View File

@ -41,7 +41,7 @@ ERROR: not-persistent class ;
dup "db-table" word-prop [ ] [ not-persistent ] ?if ; dup "db-table" word-prop [ ] [ not-persistent ] ?if ;
: db-columns ( class -- object ) : db-columns ( class -- object )
superclasses [ "db-columns" word-prop ] map concat ; superclasses-of [ "db-columns" word-prop ] map concat ;
: db-relations ( class -- object ) : db-relations ( class -- object )
"db-relations" word-prop ; "db-relations" word-prop ;

View File

@ -31,7 +31,7 @@ ERROR: no-such-responder responder ;
: base-path ( string -- seq ) : base-path ( string -- seq )
dup responder-nesting get dup responder-nesting get
[ second class-of superclasses [ name>> = ] with any? ] with find nip [ second class-of superclasses-of [ name>> = ] with any? ] with find nip
[ first ] [ no-such-responder ] ?if ; [ first ] [ no-such-responder ] ?if ;
: resolve-base-path ( string -- string' ) : resolve-base-path ( string -- string' )

View File

@ -82,7 +82,7 @@ C: <vocab-author> vocab-author
"Tuple classes" $subheading "Tuple classes" $subheading
[ [
[ <$pretty-link> ] [ <$pretty-link> ]
[ superclass <$pretty-link> ] [ superclass-of <$pretty-link> ]
[ "slots" word-prop [ name>> ] map " " join <$snippet> ] [ "slots" word-prop [ name>> ] map " " join <$snippet> ]
tri 3array tri 3array
] map ] map
@ -95,7 +95,7 @@ C: <vocab-author> vocab-author
"Predicate classes" $subheading "Predicate classes" $subheading
[ [
[ <$pretty-link> ] [ <$pretty-link> ]
[ superclass <$pretty-link> ] [ superclass-of <$pretty-link> ]
bi 2array bi 2array
] map ] map
{ { $strong "Class" } { $strong "Superclass" } } prefix { { $strong "Class" } { $strong "Superclass" } } prefix

View File

@ -159,7 +159,7 @@ M: predicate-class see-class*
<colon \ PREDICATE: pprint-word <colon \ PREDICATE: pprint-word
dup pprint-word dup pprint-word
"<" text "<" text
dup superclass pprint-word dup superclass-of pprint-word
<block <block
"predicate-definition" word-prop pprint-elements "predicate-definition" word-prop pprint-elements
pprint-; block> block> ; pprint-; block> block> ;
@ -201,7 +201,7 @@ M: array pprint-slot-name
\ final declaration. ; \ final declaration. ;
: superclass. ( class -- ) : superclass. ( class -- )
superclass dup tuple eq? [ drop ] [ "<" text pprint-word ] if ; superclass-of dup tuple eq? [ drop ] [ "<" text pprint-word ] if ;
M: tuple-class see-class* M: tuple-class see-class*
<colon \ TUPLE: pprint-word <colon \ TUPLE: pprint-word

View File

@ -9,7 +9,7 @@ FROM: namespaces => set ;
IN: ui.gestures IN: ui.gestures
: get-gesture-handler ( gesture gadget -- quot ) : get-gesture-handler ( gesture gadget -- quot )
class-of superclasses [ "gestures" word-prop ] map assoc-stack ; class-of superclasses-of [ "gestures" word-prop ] map assoc-stack ;
GENERIC: handle-gesture ( gesture gadget -- ? ) GENERIC: handle-gesture ( gesture gadget -- ? )

View File

@ -132,7 +132,7 @@ SYMBOL: +incomparable+
<PRIVATE <PRIVATE
: superclass<= ( first second -- ? ) : superclass<= ( first second -- ? )
swap superclass dup [ swap class<= ] [ 2drop f ] if ; swap superclass-of dup [ swap class<= ] [ 2drop f ] if ;
: left-anonymous-union<= ( first second -- ? ) : left-anonymous-union<= ( first second -- ? )
[ members>> ] dip [ class<= ] curry all? ; [ members>> ] dip [ class<= ] curry all? ;

View File

@ -36,8 +36,8 @@ $nl
{ $subsections instance? } { $subsections instance? }
"You can ask a class for its superclass:" "You can ask a class for its superclass:"
{ $subsections { $subsections
superclass superclass-of
superclasses superclasses-of
subclass-of? subclass-of?
} }
"Class predicates can be used to test instances directly:" "Class predicates can be used to test instances directly:"
@ -104,24 +104,24 @@ HELP: define-predicate
{ $description "Defines a predicate word for a class." } { $description "Defines a predicate word for a class." }
$low-level-note ; $low-level-note ;
HELP: superclass HELP: superclass-of
{ $values { "class" class } { "super" class } } { $values { "class" class } { "super" class } }
{ $description "Outputs the superclass of a class. All instances of this class are also instances of the superclass." } { $description "Outputs the superclass of a class. All instances of this class are also instances of the superclass." }
{ $examples { $examples
{ $example "USING: classes prettyprint ;" { $example "USING: classes prettyprint ;"
"t superclass ." "t superclass-of ."
"word" "word"
} }
} ; } ;
HELP: superclasses HELP: superclasses-of
{ $values { $values
{ "class" class } { "class" class }
{ "supers" sequence } } { "supers" sequence } }
{ $description "Outputs a sequence of superclasses of a class along with the class itself." } { $description "Outputs a sequence of superclasses of a class along with the class itself." }
{ $examples { $examples
{ $example "USING: classes prettyprint ;" { $example "USING: classes prettyprint ;"
"t superclasses ." "t superclasses-of ."
"{ word t }" "{ word t }"
} }
} ; } ;
@ -140,13 +140,13 @@ HELP: subclass-of?
} }
} ; } ;
{ superclass superclasses subclass-of? } related-words { superclass-of superclasses-of subclass-of? } related-words
HELP: members HELP: class-members
{ $values { "class" class } { "seq" "a sequence of union members, or " { $link f } } } { $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 } "." } ; { $description "If " { $snippet "class" } " is a union class, outputs a sequence of its member classes, otherwise outputs " { $link f } "." } ;
HELP: participants HELP: class-participants
{ $values { "class" class } { "seq" "a sequence of intersection participants, or " { $link f } } } { $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 } "." } ; { $description "If " { $snippet "class" } " is an intersection class, outputs a sequence of its participant classes, otherwise outputs " { $link f } "." } ;

View File

@ -3,7 +3,6 @@
USING: accessors assocs combinators definitions kernel USING: accessors assocs combinators definitions kernel
make namespaces quotations sequences sets words words.symbol ; make namespaces quotations sequences sets words words.symbol ;
FROM: namespaces => set ; FROM: namespaces => set ;
QUALIFIED: sets
IN: classes IN: classes
ERROR: bad-inheritance class superclass ; ERROR: bad-inheritance class superclass ;
@ -102,15 +101,15 @@ M: predicate reset-word
: define-predicate ( class quot -- ) : define-predicate ( class quot -- )
[ predicate-word ] dip ( object -- ? ) define-declared ; [ predicate-word ] dip ( object -- ? ) define-declared ;
: superclass ( class -- super ) : superclass-of ( class -- super )
#! Output f for non-classes to work with algebra code ! Output f for non-classes to work with algebra code
dup class? [ "superclass" word-prop ] [ drop f ] if ; dup class? [ "superclass" word-prop ] [ drop f ] if ;
: superclasses ( class -- supers ) : superclasses-of ( class -- supers )
[ superclass ] follow reverse! ; [ superclass-of ] follow reverse! ;
: superclass-of? ( class superclass -- ? ) : superclass-of? ( class superclass -- ? )
superclasses member-eq? ; superclasses-of member-eq? ;
: subclass-of? ( class superclass -- ? ) : subclass-of? ( class superclass -- ? )
swap superclass-of? ; swap superclass-of? ;
@ -130,12 +129,12 @@ GENERIC: implementors ( class/classes -- seq )
[ [
[ class-members % ] [ class-members % ]
[ class-participants % ] [ class-participants % ]
[ superclass [ , ] when* ] [ superclass-of [ , ] when* ]
tri tri
] { } make ; ] { } make ;
: class-usage ( class -- seq ) : class-usage ( class -- seq )
update-map get at sets:members ; update-map get at members ;
<PRIVATE <PRIVATE
@ -150,9 +149,9 @@ GENERIC: implementors ( class/classes -- seq )
PRIVATE> PRIVATE>
: class-usages ( class -- seq ) : class-usages ( class -- seq )
[ class-usage ] closure sets:members ; [ class-usage ] closure members ;
M: class implementors implementors-map get at sets:members ; M: class implementors implementors-map get at members ;
M: sequence implementors [ implementors ] gather ; M: sequence implementors [ implementors ] gather ;

View File

@ -14,7 +14,7 @@ GENERIC: predicate-quot ( class -- quot )
M: predicate-class predicate-quot M: predicate-class predicate-quot
[ [
\ dup , \ dup ,
[ superclass predicate-def % ] [ superclass-of predicate-def % ]
[ "predicate-definition" word-prop , ] bi [ "predicate-definition" word-prop , ] bi
[ drop f ] , \ if , [ drop f ] , \ if ,
] [ ] make ; ] [ ] make ;
@ -37,12 +37,12 @@ M: predicate-class reset-class
M: predicate-class rank-class drop 2 ; M: predicate-class rank-class drop 2 ;
M: predicate-class instance? M: predicate-class instance?
2dup superclass instance? [ 2dup superclass-of instance? [
"predicate-definition" word-prop call( object -- ? ) "predicate-definition" word-prop call( object -- ? )
] [ 2drop f ] if ; ] [ 2drop f ] if ;
M: predicate-class (flatten-class) M: predicate-class (flatten-class)
superclass (flatten-class) ; superclass-of (flatten-class) ;
M: predicate-class (classes-intersect?) M: predicate-class (classes-intersect?)
superclass classes-intersect? ; superclass-of classes-intersect? ;

View File

@ -236,7 +236,7 @@ test-laptop-slot-values
[ \ laptop see ] with-string-writer string-lines second [ \ laptop see ] with-string-writer string-lines second
] unit-test ] unit-test
{ { tuple computer laptop } } [ laptop superclasses ] unit-test { { tuple computer laptop } } [ laptop superclasses-of ] unit-test
TUPLE: server < computer rackmount ; TUPLE: server < computer rackmount ;
C: <server> server C: <server> server
@ -755,12 +755,12 @@ TUPLE: code-heap-ref ;
TUPLE: metaclass-change ; TUPLE: metaclass-change ;
TUPLE: metaclass-change-subclass < metaclass-change ; TUPLE: metaclass-change-subclass < metaclass-change ;
{ metaclass-change } [ metaclass-change-subclass superclass ] unit-test { metaclass-change } [ metaclass-change-subclass superclass-of ] unit-test
{ } [ "IN: classes.tuple.tests MIXIN: metaclass-change" eval( -- ) ] unit-test { } [ "IN: classes.tuple.tests MIXIN: metaclass-change" eval( -- ) ] unit-test
{ t } [ metaclass-change-subclass tuple-class? ] unit-test { t } [ metaclass-change-subclass tuple-class? ] unit-test
{ tuple } [ metaclass-change-subclass superclass ] unit-test { tuple } [ metaclass-change-subclass superclass-of ] unit-test
! Reshaping bug related to the above ! Reshaping bug related to the above
TUPLE: a-g ; TUPLE: a-g ;
@ -800,12 +800,12 @@ TUPLE: tuple-predicate-redefine-test ;
TUPLE: final-superclass ; TUPLE: final-superclass ;
TUPLE: final-subclass < final-superclass ; TUPLE: final-subclass < final-superclass ;
{ final-superclass } [ final-subclass superclass ] unit-test { final-superclass } [ final-subclass superclass-of ] unit-test
! Making the superclass final should change the superclass of the subclass ! Making the superclass final should change the superclass of the subclass
{ } [ "IN: classes.tuple.tests TUPLE: final-superclass ; final" eval( -- ) ] unit-test { } [ "IN: classes.tuple.tests TUPLE: final-superclass ; final" eval( -- ) ] unit-test
{ tuple } [ final-subclass superclass ] unit-test { tuple } [ final-subclass superclass-of ] unit-test
{ f } [ \ final-subclass final-class? ] unit-test { f } [ \ final-subclass final-class? ] unit-test

View File

@ -18,7 +18,7 @@ PREDICATE: tuple-class < class
ERROR: not-a-tuple object ; ERROR: not-a-tuple object ;
: all-slots ( class -- slots ) : all-slots ( class -- slots )
superclasses [ "slots" word-prop ] map concat ; superclasses-of [ "slots" word-prop ] map concat ;
ERROR: no-slot name tuple ; ERROR: no-slot name tuple ;
@ -153,7 +153,7 @@ M: object final-class? drop f ;
} case define-predicate ; } case define-predicate ;
: class-size ( class -- n ) : class-size ( class -- n )
superclasses [ "slots" word-prop length ] map-sum ; superclasses-of [ "slots" word-prop length ] map-sum ;
: boa-check-quot ( class -- quot ) : boa-check-quot ( class -- quot )
all-slots [ class>> instance-check-quot ] map shallow-spread>quot all-slots [ class>> instance-check-quot ] map shallow-spread>quot
@ -173,16 +173,16 @@ M: object final-class? drop f ;
[ make-slots ] [ class-size 2 + ] bi* finalize-slots ; [ make-slots ] [ class-size 2 + ] bi* finalize-slots ;
: define-tuple-slots ( class -- ) : define-tuple-slots ( class -- )
dup "slots" word-prop over superclass prepare-slots dup "slots" word-prop over superclass-of prepare-slots
define-accessors ; define-accessors ;
: make-tuple-layout ( class -- layout ) : make-tuple-layout ( class -- layout )
[ [
{ {
[ , ] [ , ]
[ [ superclass class-size ] [ "slots" word-prop length ] bi + , ] [ [ superclass-of class-size ] [ "slots" word-prop length ] bi + , ]
[ superclasses length 1 - , ] [ superclasses-of length 1 - , ]
[ superclasses [ [ , ] [ hashcode , ] bi ] each ] [ superclasses-of [ [ , ] [ hashcode , ] bi ] each ]
} cleave } cleave
] { } make ; ] { } make ;
@ -269,7 +269,7 @@ M: tuple-class update-class
[ define-new-tuple-class ] 3bi ; [ define-new-tuple-class ] 3bi ;
: tuple-class-unchanged? ( class superclass slots -- ? ) : tuple-class-unchanged? ( class superclass slots -- ? )
[ [ superclass ] [ bootstrap-word ] bi* = ] [ [ superclass-of ] [ bootstrap-word ] bi* = ]
[ [ "slots" word-prop ] dip = ] [ [ "slots" word-prop ] dip = ]
bi-curry* bi and ; bi-curry* bi and ;

View File

@ -118,7 +118,7 @@ TUPLE: tuple-dispatch-engine echelons ;
at* [ [ methods>> ] bi@ assoc-union! drop ] [ 2drop ] if ; at* [ [ methods>> ] bi@ assoc-union! drop ] [ 2drop ] if ;
: copy-superclasses-methods ( class engine assoc -- ) : copy-superclasses-methods ( class engine assoc -- )
[ superclasses ] 2dip [ superclasses-of ] 2dip
[ swapd copy-superclass-methods ] 2curry each ; [ swapd copy-superclass-methods ] 2curry each ;
: convert-tuple-inheritance ( assoc -- assoc' ) : convert-tuple-inheritance ( assoc -- assoc' )
@ -202,7 +202,7 @@ SYMBOL: predicate-engines
predicate-engines get [ at ] curry map-find drop ; predicate-engines get [ at ] curry map-find drop ;
: next-predicate-engine ( engine -- word ) : next-predicate-engine ( engine -- word )
class>> superclasses class>> superclasses-of
find-predicate-engine find-predicate-engine
default get or ; default get or ;

View File

@ -7,7 +7,7 @@ words alien.parser ;
IN: constructors IN: constructors
: all-slots-assoc ( class -- slots ) : all-slots-assoc ( class -- slots )
superclasses [ superclasses-of [
[ "slots" word-prop ] keep '[ _ ] { } map>assoc [ "slots" word-prop ] keep '[ _ ] { } map>assoc
] map concat ; ] map concat ;

View File

@ -217,7 +217,7 @@ M: uniform-tuple (bind-uniforms)
: all-uniform-tuple-slots ( class -- slots ) : all-uniform-tuple-slots ( class -- slots )
dup "uniform-tuple-slots" word-prop dup "uniform-tuple-slots" word-prop
[ [ superclass all-uniform-tuple-slots ] dip append ] [ drop { } ] if* ; [ [ superclass-of all-uniform-tuple-slots ] dip append ] [ drop { } ] if* ;
DEFER: uniform-texture-accessors DEFER: uniform-texture-accessors
@ -486,8 +486,8 @@ DEFER: [bind-uniform-tuple]
{ uniforms-cleave 2cleave } >quotation ; { uniforms-cleave 2cleave } >quotation ;
:: [bind-uniforms] ( superclass uniforms -- quot ) :: [bind-uniforms] ( superclass uniforms -- quot )
superclass "uniform-tuple-texture-units" word-prop 0 or :> first-texture-unit superclass-of "uniform-tuple-texture-units" word-prop 0 or :> first-texture-unit
superclass \ (bind-uniforms) lookup-method :> next-method superclass-of \ (bind-uniforms) lookup-method :> next-method
first-texture-unit uniforms "" [bind-uniform-tuple] nip :> bind-quot first-texture-unit uniforms "" [bind-uniform-tuple] nip :> bind-quot
{ 2dup next-method } bind-quot [ ] append-as ; { 2dup next-method } bind-quot [ ] append-as ;

View File

@ -63,13 +63,13 @@ GENERIC: mdb-index-map ( tuple -- sequence )
: (mdb-collection) ( class -- mdb-collection ) : (mdb-collection) ( class -- mdb-collection )
dup MDB_COLLECTION word-prop dup MDB_COLLECTION word-prop
[ nip ] [ nip ]
[ superclass [ (mdb-collection) ] [ f ] if* ] if* ; inline recursive [ superclass-of [ (mdb-collection) ] [ f ] if* ] if* ; inline recursive
: (mdb-slot-map) ( class -- slot-map ) : (mdb-slot-map) ( class -- slot-map )
superclasses [ MDB_SLOTDEF_MAP word-prop ] map assoc-combine ; inline superclasses-of [ MDB_SLOTDEF_MAP word-prop ] map assoc-combine ; inline
: (mdb-index-map) ( class -- index-map ) : (mdb-index-map) ( class -- index-map )
superclasses [ MDB_INDEX_MAP word-prop ] map assoc-combine ; inline superclasses-of [ MDB_INDEX_MAP word-prop ] map assoc-combine ; inline
: split-optl ( seq -- key options ) : split-optl ( seq -- key options )
[ first ] [ rest ] bi ; inline [ first ] [ rest ] bi ; inline