130 lines
3.4 KiB
Factor
Executable File
130 lines
3.4 KiB
Factor
Executable File
! Copyright (C) 2004, 2008 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: arrays definitions assocs kernel kernel.private
|
|
slots.private namespaces sequences strings words vectors math
|
|
quotations combinators sorting effects graphs vocabs ;
|
|
IN: classes
|
|
|
|
SYMBOL: class<-cache
|
|
SYMBOL: class-not-cache
|
|
SYMBOL: classes-intersect-cache
|
|
SYMBOL: class-and-cache
|
|
SYMBOL: class-or-cache
|
|
|
|
: init-caches ( -- )
|
|
H{ } clone class<-cache set
|
|
H{ } clone class-not-cache set
|
|
H{ } clone classes-intersect-cache set
|
|
H{ } clone class-and-cache set
|
|
H{ } clone class-or-cache set ;
|
|
|
|
: reset-caches ( -- )
|
|
class<-cache get clear-assoc
|
|
class-not-cache get clear-assoc
|
|
classes-intersect-cache get clear-assoc
|
|
class-and-cache get clear-assoc
|
|
class-or-cache get clear-assoc ;
|
|
|
|
PREDICATE: class < word ( obj -- ? ) "class" word-prop ;
|
|
|
|
SYMBOL: update-map
|
|
SYMBOL: builtins
|
|
|
|
PREDICATE: builtin-class < class
|
|
"metaclass" word-prop builtin-class eq? ;
|
|
|
|
PREDICATE: tuple-class < class
|
|
"metaclass" word-prop tuple-class eq? ;
|
|
|
|
: classes ( -- seq ) all-words [ class? ] subset ;
|
|
|
|
: type>class ( n -- class ) builtins get-global nth ;
|
|
|
|
: bootstrap-type>class ( n -- class ) builtins get nth ;
|
|
|
|
: predicate-word ( word -- predicate )
|
|
[ word-name "?" append ] keep word-vocabulary create ;
|
|
|
|
: predicate-effect 1 { "?" } <effect> ;
|
|
|
|
PREDICATE: predicate < word "predicating" word-prop >boolean ;
|
|
|
|
: define-predicate ( class quot -- )
|
|
>r "predicate" word-prop first
|
|
r> predicate-effect define-declared ;
|
|
|
|
: superclass ( class -- super )
|
|
#! Output f for non-classes to work with algebra code
|
|
dup class? [ "superclass" word-prop ] [ drop f ] if ;
|
|
|
|
: superclasses ( class -- supers )
|
|
[ dup ] [ dup superclass swap ] [ ] unfold reverse nip ;
|
|
|
|
: members ( class -- seq )
|
|
#! Output f for non-classes to work with algebra code
|
|
dup class? [ "members" word-prop ] [ drop f ] if ;
|
|
|
|
GENERIC: reset-class ( class -- )
|
|
|
|
M: word reset-class drop ;
|
|
|
|
<PRIVATE
|
|
|
|
! update-map
|
|
: class-uses ( class -- seq )
|
|
dup members swap superclass [ add ] when* ;
|
|
|
|
: class-usages ( class -- assoc )
|
|
[ update-map get at ] closure ;
|
|
|
|
: update-map+ ( class -- )
|
|
dup class-uses update-map get add-vertex ;
|
|
|
|
: update-map- ( class -- )
|
|
dup class-uses update-map get remove-vertex ;
|
|
|
|
: define-class-props ( superclass members metaclass -- assoc )
|
|
[
|
|
[ dup [ bootstrap-word ] when "superclass" set ]
|
|
[ [ bootstrap-word ] map "members" set ]
|
|
[ "metaclass" set ]
|
|
tri*
|
|
] H{ } make-assoc ;
|
|
|
|
: (define-class) ( word props -- )
|
|
over reset-class
|
|
over deferred? [ over define-symbol ] when
|
|
>r dup word-props r> union over set-word-props
|
|
dup predicate-word 2dup 1quotation "predicate" set-word-prop
|
|
over "predicating" set-word-prop
|
|
t "class" set-word-prop ;
|
|
|
|
PRIVATE>
|
|
|
|
GENERIC: update-class ( class -- )
|
|
|
|
M: class update-class drop ;
|
|
|
|
: update-classes ( assoc -- )
|
|
[ drop update-class ] assoc-each ;
|
|
|
|
GENERIC: update-methods ( assoc -- )
|
|
|
|
: define-class ( word superclass members metaclass -- )
|
|
#! If it was already a class, update methods after.
|
|
reset-caches
|
|
define-class-props
|
|
[ drop update-map- ]
|
|
[ (define-class) ] [
|
|
drop
|
|
[ update-map+ ] [
|
|
class-usages
|
|
[ update-classes ]
|
|
[ update-methods ] bi
|
|
] bi
|
|
] 2tri ;
|
|
|
|
GENERIC: class ( object -- class ) inline
|
|
|
|
M: object class type type>class ;
|