/core/slots/slots.factor

http://github.com/abeaumont/factor · Factor · 285 lines · 218 code · 55 blank · 12 comment · 26 complexity · 3009d665425796f728d9048487db41ae MD5 · raw file

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