core/slots/slots.factor

   1 ! Copyright (C) 2005, 2011 Slava Pestov.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien arrays assocs byte-arrays classes
   4 classes.algebra classes.algebra.private classes.maybe
   5 combinators generic generic.standard hashtables kernel
   6 kernel.private math quotations sequences sequences.private
   7 strings words ;
   8 IN: slots
   9
  10 <PRIVATE
  11 PRIMITIVE: set-slot ( value obj n -- )
  12 PRIMITIVE: slot ( obj m -- value )
  13 PRIVATE>
  14
  15 TUPLE: slot-spec name offset class initial read-only ;
  16
  17 PREDICATE: reader < word "reader" word-prop ;
  18
  19 PREDICATE: reader-method < method "reading" word-prop >boolean ;
  20
  21 PREDICATE: writer < word "writer" word-prop ;
  22
  23 PREDICATE: writer-method < method "writing" word-prop >boolean ;
  24
  25 : <slot-spec> ( -- slot-spec )
  26     slot-spec new
  27         object bootstrap-word >>class ;
  28
  29 : define-typecheck ( class generic quot props -- )
  30     [ create-method ] 2dip
  31     [ [ props>> ] [ drop ] [ ] tri* assoc-union! drop ]
  32     [ drop define ]
  33     [ 2drop make-inline ]
  34     3tri ;
  35
  36 GENERIC#: reader-quot 1 ( class slot-spec -- quot )
  37
  38 M: object reader-quot
  39     nip [ offset>> [ slot ] curry ] [ class>> ] bi
  40     dup object bootstrap-word eq?
  41     [ drop ] [ 1array [ declare ] curry compose ] if ;
  42
  43 : reader-word ( name -- word )
  44     ">>" append "accessors" create-word
  45     dup t "reader" set-word-prop ;
  46
  47 : reader-props ( slot-spec -- assoc )
  48     "reading" associate ;
  49
  50 : define-reader-generic ( name -- )
  51     reader-word ( object -- value ) define-simple-generic ;
  52
  53 : define-reader ( class slot-spec -- )
  54     [ nip name>> define-reader-generic ]
  55     [
  56         {
  57             [ drop ]
  58             [ nip name>> reader-word ]
  59             [ reader-quot ]
  60             [ nip reader-props ]
  61         } 2cleave define-typecheck
  62     ] 2bi ;
  63
  64 : writer-word ( name -- word )
  65     "<<" append "accessors" create-word
  66     dup t "writer" set-word-prop ;
  67
  68 ERROR: bad-slot-value value class ;
  69
  70 GENERIC: instance-check-quot ( obj -- quot )
  71
  72 M: class instance-check-quot
  73     {
  74         { [ dup object bootstrap-word eq? ] [ drop [ ] ] }
  75         { [ dup "coercer" word-prop ] [ "coercer" word-prop ] }
  76         [ call-next-method ]
  77     } cond ;
  78
  79 M: object instance-check-quot
  80     [ predicate-def [ dup ] prepose ] keep
  81     [ bad-slot-value ] curry [ unless ] curry compose ;
  82
  83 GENERIC#: writer-quot 1 ( class slot-spec -- quot )
  84
  85 M: object writer-quot
  86     nip
  87     [ class>> instance-check-quot dup empty? [ [ dip ] curry ] unless ]
  88     [ offset>> [ set-slot ] curry ]
  89     bi append ;
  90
  91 : writer-props ( slot-spec -- assoc )
  92     "writing" associate ;
  93
  94 : define-writer-generic ( name -- )
  95     writer-word ( value object -- ) define-simple-generic ;
  96
  97 : define-writer ( class slot-spec -- )
  98     [ nip name>> define-writer-generic ] [
  99         {
 100             [ drop ]
 101             [ nip name>> writer-word ]
 102             [ writer-quot ]
 103             [ nip writer-props ]
 104         } 2cleave define-typecheck
 105     ] 2bi ;
 106
 107 : setter-word ( name -- word )
 108     ">>" prepend "accessors" create-word ;
 109
 110 : define-setter ( name -- )
 111     dup setter-word dup deferred? [
 112         swap writer-word 1quotation [ over ] prepose
 113         ( object value -- object ) define-inline
 114     ] [ 2drop ] if ;
 115
 116 : changer-word ( name -- word )
 117     "change-" prepend "accessors" create-word ;
 118
 119 : define-changer ( name -- )
 120     dup changer-word dup deferred? [
 121         over reader-word 1quotation
 122         [ dip call ] curry [ dip swap ] curry [ over ] prepose
 123         rot setter-word 1quotation compose
 124         ( object quot -- object ) define-inline
 125     ] [ 2drop ] if ;
 126
 127 : define-slot-methods ( class slot-spec -- )
 128     [ define-reader ]
 129     [
 130         dup read-only>> [ 2drop ] [
 131             [ name>> define-setter drop ]
 132             [ name>> define-changer drop ]
 133             [ define-writer ]
 134             2tri
 135         ] if
 136     ] 2bi ;
 137
 138 : define-accessors ( class specs -- )
 139     [ define-slot-methods ] with each ;
 140
 141 : define-protocol-slot ( name -- )
 142     {
 143         [ define-reader-generic ]
 144         [ define-writer-generic ]
 145         [ define-setter ]
 146         [ define-changer ]
 147     } cleave ;
 148
 149 DEFER: initial-value
 150
 151 GENERIC: initial-value* ( class -- object ? )
 152
 153 M: class initial-value* drop f f ;
 154
 155 M: maybe initial-value* drop f t ;
 156
 157 ! Default initial value is f, 0, or the default initial value of
 158 ! the smallest class. Special case 0 because float is ostensibly
 159 ! smaller than integer in union{ integer float } because of
 160 ! alphabetical sorting.
 161 M: anonymous-union initial-value*
 162     {
 163         { [ f over instance? ] [ drop f t ] }
 164         { [ 0 over instance? ] [ drop 0 t ] }
 165         [
 166             members>> sort-classes [ initial-value ] { } map>assoc
 167             ?last [ second t ] [ f f ] if*
 168         ]
 169     } cond ;
 170
 171 ! See if any of the initial values fit the intersection class,
 172 ! or else return that none do, and leave it up to the user to
 173 ! provide an initial: value.
 174 M: anonymous-intersection initial-value*
 175     {
 176         { [ f over instance? ] [ drop f t ] }
 177         { [ 0 over instance? ] [ drop 0 t ] }
 178         [
 179             [ ]
 180             [ participants>> sort-classes [ initial-value ] { } map>assoc ]
 181             [ ] tri
 182
 183             [ [ first2 nip ] dip instance? ] curry find swap [
 184                 nip second t
 185             ] [
 186                 2drop f f
 187             ] if
 188         ]
 189     } cond ;
 190
 191 : initial-value ( class -- object ? )
 192     {
 193         { [ dup only-classoid? ] [ dup initial-value* ] }
 194         { [ dup "initial-value" word-prop ] [ dup "initial-value" word-prop t ] }
 195         { [ \ f bootstrap-word over class<= ] [ f t ] }
 196         { [ \ array-capacity bootstrap-word over class<= ] [ 0 t ] }
 197         { [ \ integer-array-capacity bootstrap-word over class<= ] [ 0 t ] }
 198         { [ bignum bootstrap-word over class<= ] [ 0 >bignum t ] }
 199         { [ float bootstrap-word over class<= ] [ 0.0 t ] }
 200         { [ string bootstrap-word over class<= ] [ "" t ] }
 201         { [ array bootstrap-word over class<= ] [ { } t ] }
 202         { [ byte-array bootstrap-word over class<= ] [ B{ } t ] }
 203         { [ pinned-alien bootstrap-word over class<= ] [ <bad-alien> t ] }
 204         { [ quotation bootstrap-word over class<= ] [ [ ] t ] }
 205         [ dup initial-value* ]
 206     } cond nipd ;
 207
 208 GENERIC: make-slot ( desc -- slot-spec )
 209
 210 M: string make-slot
 211     <slot-spec>
 212         swap >>name ;
 213
 214 : peel-off-name ( slot-spec array -- slot-spec array )
 215     [ first >>name ] [ rest ] bi ; inline
 216
 217 : init-slot-class ( slot-spec class -- slot-spec )
 218     [ >>class ] [ initial-value [ >>initial ] [ drop ] if ] bi ;
 219
 220 : peel-off-class ( slot-spec array -- slot-spec array )
 221     dup empty? [
 222         dup first classoid? [
 223             [ first init-slot-class ] [ rest ] bi
 224         ] when
 225     ] unless ;
 226
 227 ERROR: bad-slot-attribute key ;
 228
 229 : peel-off-attributes ( slot-spec array -- slot-spec array )
 230     dup empty? [
 231         unclip {
 232             { initial: [ [ first >>initial ] [ rest ] bi ] }
 233             { read-only [ [ t >>read-only ] dip ] }
 234             [ bad-slot-attribute ]
 235         } case
 236     ] unless ;
 237
 238 ERROR: bad-initial-value name initial-value class ;
 239
 240 : check-initial-value ( slot-spec -- slot-spec )
 241     [ ] [
 242         [ ] [ initial>> ] [ class>> ] tri
 243         2dup instance? [
 244             2drop
 245         ] [
 246             [ name>> ] 2dip bad-initial-value
 247         ] if
 248     ] if-bootstrapping ;
 249
 250 M: array make-slot
 251     <slot-spec>
 252         swap
 253         peel-off-name
 254         peel-off-class
 255         [ dup empty? ] [ peel-off-attributes ] until drop
 256     check-initial-value ;
 257
 258 M: slot-spec make-slot
 259     check-initial-value ;
 260
 261 : make-slots ( slots -- specs )
 262     [ make-slot ] map ;
 263
 264 : finalize-slots ( specs base -- specs )
 265     over length <iota> [ + ] with map [ >>offset ] 2map ;
 266
 267 : slot-named* ( name specs -- offset spec/f )
 268     [ name>> = ] with find ;
 269
 270 : slot-named ( name specs -- spec/f )
 271     slot-named* nip ;