core/classes/classes.factor

   1 ! Copyright (C) 2004, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays definitions assocs kernel kernel.private
   4 slots.private namespaces sequences strings words vectors math
   5 quotations combinators sorting effects graphs vocabs ;
   6 IN: classes
   7
   8 SYMBOL: class<=-cache
   9 SYMBOL: class-not-cache
  10 SYMBOL: classes-intersect-cache
  11 SYMBOL: class-and-cache
  12 SYMBOL: class-or-cache
  13
  14 : init-caches ( -- )
  15     H{ } clone class<=-cache set
  16     H{ } clone class-not-cache set
  17     H{ } clone classes-intersect-cache set
  18     H{ } clone class-and-cache set
  19     H{ } clone class-or-cache set ;
  20
  21 : reset-caches ( -- )
  22     class<=-cache get clear-assoc
  23     class-not-cache get clear-assoc
  24     classes-intersect-cache get clear-assoc
  25     class-and-cache get clear-assoc
  26     class-or-cache get clear-assoc ;
  27
  28 SYMBOL: update-map
  29
  30 PREDICATE: class < word
  31     "class" word-prop ;
  32
  33 PREDICATE: tuple-class < class
  34     "metaclass" word-prop tuple-class eq? ;
  35
  36 : classes ( -- seq ) all-words [ class? ] filter ;
  37
  38 : predicate-word ( word -- predicate )
  39     [ word-name "?" append ] keep word-vocabulary create ;
  40
  41 : predicate-effect T{ effect f 1 { "?" } } ;
  42
  43 PREDICATE: predicate < word "predicating" word-prop >boolean ;
  44
  45 : define-predicate ( class quot -- )
  46     >r "predicate" word-prop first
  47     r> predicate-effect define-declared ;
  48
  49 : superclass ( class -- super )
  50     #! Output f for non-classes to work with algebra code
  51     dup class? [ "superclass" word-prop ] [ drop f ] if ;
  52
  53 : superclasses ( class -- supers )
  54     [ superclass ] follow reverse ;
  55
  56 : members ( class -- seq )
  57     #! Output f for non-classes to work with algebra code
  58     dup class? [ "members" word-prop ] [ drop f ] if ;
  59
  60 : participants ( class -- seq )
  61     #! Output f for non-classes to work with algebra code
  62     dup class? [ "participants" word-prop ] [ drop f ] if ;
  63
  64 GENERIC: rank-class ( class -- n )
  65
  66 GENERIC: reset-class ( class -- )
  67
  68 M: word reset-class drop ;
  69
  70 ! update-map
  71 : class-uses ( class -- seq )
  72     [
  73         [ members % ]
  74         [ participants % ]
  75         [ superclass [ , ] when* ]
  76         tri
  77     ] { } make ;
  78
  79 : class-usages ( class -- assoc )
  80     [ update-map get at ] closure ;
  81
  82 <PRIVATE
  83
  84 : update-map+ ( class -- )
  85     dup class-uses update-map get add-vertex ;
  86
  87 : update-map- ( class -- )
  88     dup class-uses update-map get remove-vertex ;
  89
  90 : make-class-props ( superclass members participants metaclass -- assoc )
  91     [
  92         {
  93             [ dup [ bootstrap-word ] when "superclass" set ]
  94             [ [ bootstrap-word ] map "members" set ]
  95             [ [ bootstrap-word ] map "participants" set ]
  96             [ "metaclass" set ]
  97         } spread
  98     ] H{ } make-assoc ;
  99
 100 : (define-class) ( word props -- )
 101     >r
 102     dup reset-class
 103     dup class? [ dup new-class ] unless
 104     dup deferred? [ dup define-symbol ] when
 105     dup word-props
 106     r> assoc-union over set-word-props
 107     dup predicate-word
 108     [ 1quotation "predicate" set-word-prop ]
 109     [ swap "predicating" set-word-prop ]
 110     [ drop t "class" set-word-prop ]
 111     2tri ;
 112
 113 PRIVATE>
 114
 115 GENERIC: update-class ( class -- )
 116
 117 M: class update-class drop ;
 118
 119 GENERIC: update-methods ( class assoc -- )
 120
 121 : update-classes ( class -- )
 122     dup class-usages
 123     [ nip keys [ update-class ] each ]
 124     [ update-methods ]
 125     2bi ;
 126
 127 : define-class ( word superclass members participants metaclass -- )
 128     #! If it was already a class, update methods after.
 129     reset-caches
 130     make-class-props
 131     [ drop update-map- ]
 132     [ (define-class) ]
 133     [ drop update-map+ ]
 134     2tri ;
 135
 136 GENERIC: class ( object -- class )
 137
 138 : instance? ( obj class -- ? )
 139     "predicate" word-prop call ;