! Copyright (C) 2004, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs combinators definitions kernel make namespaces quotations sequences sets words words.symbol ; FROM: namespaces => set ; QUALIFIED: sets IN: classes ERROR: bad-inheritance class superclass ; PREDICATE: class < word "class" word-prop ; PREDICATE: defining-class < word "defining-class" word-prop ; MIXIN: classoid INSTANCE: class classoid INSTANCE: defining-class classoid > ; GENERIC: rank-class ( class -- n ) GENERIC: reset-class ( class -- ) M: class reset-class { "defining-class" "class" "metaclass" "superclass" "members" "participants" "predicate" } reset-props ; M: word reset-class drop ; PRIVATE> : classes ( -- seq ) implementors-map get keys ; PREDICATE: predicate < word "predicating" word-prop >boolean ; : create-predicate-word ( word -- predicate ) [ name>> "?" append ] [ vocabulary>> ] bi create dup predicate? [ dup reset-generic ] unless ; GENERIC: class-of ( object -- class ) GENERIC: instance? ( object class -- ? ) flushable GENERIC: predicate-def ( obj -- quot ) M: word predicate-def "predicate" word-prop ; M: object predicate-def [ instance? ] curry ; : predicate-word ( word -- predicate ) predicate-def first ; M: predicate flushable? drop t ; M: predicate forget* [ call-next-method ] [ f "predicating" set-word-prop ] bi ; M: predicate reset-word [ call-next-method ] [ f "predicating" set-word-prop ] bi ; : define-predicate ( class quot -- ) [ predicate-word ] dip ( object -- ? ) 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 ) [ superclass ] follow reverse! ; : superclass-of? ( class superclass -- ? ) superclasses member-eq? ; : subclass-of? ( class superclass -- ? ) swap superclass-of? ; : members ( class -- seq ) #! 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: implementors ( class/classes -- seq ) ! update-map : class-uses ( class -- seq ) [ [ members % ] [ participants % ] [ superclass [ , ] when* ] tri ] { } make ; : class-usage ( class -- seq ) update-map get at sets:members ; : class-usages ( class -- seq ) [ class-usage ] closure sets:members ; M: class implementors implementors-map get at sets:members ; M: sequence implementors [ implementors ] gather ; : forget-class ( class -- ) dup f check-metaclass { [ drop forget-predicate ] [ drop forget-methods ] [ drop implementors-map- ] [ drop update-map- ] [ drop reset-class ] [ 2drop reset-caches ] [ ?metaclass-changed ] } 2cleave ; M: class metaclass-changed swap class? [ drop ] [ forget-class ] if ; M: class forget* ( class -- ) [ call-next-method ] [ forget-class ] bi ;