/core/classes/tuple/tuple.factor

http://github.com/abeaumont/factor · Factor · 402 lines · 300 code · 98 blank · 4 comment · 49 complexity · 974260d1f3f26e50e5d55f7262cc3a11 MD5 · raw file

  1. ! Copyright (C) 2005, 2010 Slava Pestov.
  2. ! See http://factorcode.org/license.txt for BSD license.
  3. USING: accessors arrays assocs classes classes.algebra
  4. classes.algebra.private classes.builtin classes.private
  5. combinators definitions effects generic kernel kernel.private
  6. make math math.private memory namespaces quotations sequences
  7. sequences.private slots slots.private strings words ;
  8. IN: classes.tuple
  9. PREDICATE: tuple-class < class
  10. "metaclass" word-prop tuple-class eq? ;
  11. ERROR: not-a-tuple object ;
  12. : all-slots ( class -- slots )
  13. superclasses [ "slots" word-prop ] map concat ;
  14. ERROR: no-slot name tuple ;
  15. : offset-of-slot ( name tuple -- n )
  16. 2dup class-of all-slots slot-named
  17. [ 2nip offset>> ] [ no-slot ] if* ;
  18. : get-slot-named ( name tuple -- value )
  19. [ nip ] [ offset-of-slot ] 2bi slot ;
  20. : set-slot-named ( value name tuple -- )
  21. [ nip ] [ offset-of-slot ] 2bi set-slot ;
  22. : set-slots ( assoc tuple -- )
  23. [ swapd set-slot-named ] curry assoc-each ; inline
  24. : from-slots ( assoc class -- tuple )
  25. new [ set-slots ] keep ; inline
  26. PREDICATE: immutable-tuple-class < tuple-class
  27. all-slots [ read-only>> ] all? ;
  28. <PRIVATE
  29. : tuple-layout ( class -- layout )
  30. "layout" word-prop ;
  31. : layout-of ( tuple -- layout )
  32. 1 slot { array } declare ; inline
  33. M: tuple class-of layout-of 2 slot { word } declare ; inline
  34. : tuple-size ( tuple -- size )
  35. layout-of 3 slot { fixnum } declare ; inline
  36. : layout-up-to-date? ( object -- ? )
  37. dup tuple?
  38. [ [ layout-of ] [ class-of tuple-layout ] bi eq? ] [ drop t ] if ;
  39. : check-tuple ( object -- tuple )
  40. dup tuple? [ not-a-tuple ] unless ; inline
  41. : prepare-tuple>array ( tuple -- n tuple layout )
  42. check-tuple [ tuple-size iota ] [ ] [ layout-of ] tri ;
  43. : copy-tuple-slots ( n tuple -- array )
  44. [ array-nth ] curry map ;
  45. : check-slots ( seq class -- seq class )
  46. [ ] [
  47. 2dup all-slots [
  48. class>> 2dup instance?
  49. [ 2drop ] [ bad-slot-value ] if
  50. ] 2each
  51. ] if-bootstrapping ; inline
  52. : initial-values ( class -- slots )
  53. all-slots [ initial>> ] map ;
  54. : pad-slots ( slots class -- slots' class )
  55. [ initial-values over length tail append ] keep ; inline
  56. PRIVATE>
  57. : tuple>array ( tuple -- array )
  58. prepare-tuple>array
  59. [ copy-tuple-slots ] dip
  60. first prefix ;
  61. : tuple-slots ( tuple -- seq )
  62. prepare-tuple>array drop copy-tuple-slots ;
  63. GENERIC: slots>tuple ( seq class -- tuple )
  64. M: tuple-class slots>tuple ( seq class -- tuple )
  65. check-slots pad-slots
  66. tuple-layout <tuple> [
  67. [ tuple-size iota ]
  68. [ [ set-array-nth ] curry ]
  69. bi 2each
  70. ] keep ;
  71. : >tuple ( seq -- tuple )
  72. unclip slots>tuple ;
  73. ERROR: bad-superclass class ;
  74. : tuple= ( tuple1 tuple2 -- ? )
  75. 2dup [ tuple? ] both? [
  76. 2dup [ layout-of ] bi@ eq? [
  77. [ drop tuple-size ]
  78. [ [ [ drop array-nth ] [ nip array-nth ] 3bi = ] 2curry ]
  79. 2bi all-integers?
  80. ] [ 2drop f ] if
  81. ] [ 2drop f ] if ; inline
  82. GENERIC: final-class? ( object -- ? )
  83. M: tuple-class final-class? "final" word-prop ;
  84. M: builtin-class final-class? tuple eq? not ;
  85. M: class final-class? drop t ;
  86. M: object final-class? drop f ;
  87. <PRIVATE
  88. : tuple-predicate-quot/1 ( class -- quot )
  89. #! Fast path for tuples with no superclass
  90. [ ] curry [ layout-of 7 slot ] [ eq? ] surround 1quotation
  91. [ dup tuple? ] [ [ drop f ] if ] surround ;
  92. : tuple-instance? ( object class offset -- ? )
  93. rot dup tuple? [
  94. layout-of
  95. 2dup 1 slot fixnum<=
  96. [ swap slot eq? ] [ 3drop f ] if
  97. ] [ 3drop f ] if ; inline
  98. : layout-class-offset ( echelon -- n )
  99. 2 * 5 + ;
  100. : tuple-predicate-quot ( class echelon -- quot )
  101. layout-class-offset [ tuple-instance? ] 2curry ;
  102. : echelon-of ( class -- n )
  103. tuple-layout third ;
  104. : define-tuple-predicate ( class -- )
  105. dup dup echelon-of {
  106. { 1 [ tuple-predicate-quot/1 ] }
  107. [ tuple-predicate-quot ]
  108. } case define-predicate ;
  109. : class-size ( class -- n )
  110. superclasses [ "slots" word-prop length ] map-sum ;
  111. : boa-check-quot ( class -- quot )
  112. all-slots [ class>> instance-check-quot ] map shallow-spread>quot
  113. f like ;
  114. : define-boa-check ( class -- )
  115. dup boa-check-quot "boa-check" set-word-prop ;
  116. : tuple-prototype ( class -- prototype )
  117. [ initial-values ] keep over [ ] any?
  118. [ slots>tuple ] [ 2drop f ] if ;
  119. : define-tuple-prototype ( class -- )
  120. dup tuple-prototype "prototype" set-word-prop ;
  121. : prepare-slots ( slots superclass -- slots' )
  122. [ make-slots ] [ class-size 2 + ] bi* finalize-slots ;
  123. : define-tuple-slots ( class -- )
  124. dup "slots" word-prop over superclass prepare-slots
  125. define-accessors ;
  126. : make-tuple-layout ( class -- layout )
  127. [
  128. {
  129. [ , ]
  130. [ [ superclass class-size ] [ "slots" word-prop length ] bi + , ]
  131. [ superclasses length 1 - , ]
  132. [ superclasses [ [ , ] [ hashcode , ] bi ] each ]
  133. } cleave
  134. ] { } make ;
  135. : define-tuple-layout ( class -- )
  136. dup make-tuple-layout "layout" set-word-prop ;
  137. : compute-slot-permutation ( new-slots old-slots -- triples )
  138. [ [ [ name>> ] map ] bi@ [ index ] curry map ]
  139. [ drop [ class>> ] map ]
  140. [ drop [ initial>> ] map ]
  141. 2tri 3array flip ;
  142. : update-slot ( old-values n class initial -- value )
  143. pick [
  144. [ [ swap nth dup ] dip instance? ] dip swap
  145. [ drop ] [ nip ] if
  146. ] [ [ 3drop ] dip ] if ;
  147. : apply-slot-permutation ( old-values triples -- new-values )
  148. [ first3 update-slot ] with map ;
  149. SYMBOL: outdated-tuples
  150. : permute-slots ( old-values layout -- new-values )
  151. [ first all-slots ] [ outdated-tuples get at ] bi
  152. compute-slot-permutation
  153. apply-slot-permutation ;
  154. : update-tuple ( tuple -- newtuple )
  155. [ tuple-slots ] [ layout-of ] bi
  156. [ permute-slots ] [ first ] bi
  157. slots>tuple ;
  158. : outdated-tuple? ( tuple assoc -- ? )
  159. [ [ layout-of ] dip key? ]
  160. [ drop class-of "forgotten" word-prop not ]
  161. 2bi and ;
  162. : update-tuples ( -- )
  163. outdated-tuples get
  164. dup assoc-empty? [ drop ] [
  165. [ [ tuple? ] instances ] dip [ outdated-tuple? ] curry filter
  166. dup [ update-tuple ] map become
  167. ] if ;
  168. : update-tuples-after ( class -- )
  169. [ all-slots ] [ tuple-layout ] bi outdated-tuples get set-at ;
  170. M: tuple-class update-class
  171. {
  172. [ define-boa-check ]
  173. [ define-tuple-layout ]
  174. [ define-tuple-slots ]
  175. [ define-tuple-predicate ]
  176. [ define-tuple-prototype ]
  177. } cleave ;
  178. : define-new-tuple-class ( class superclass slots -- )
  179. [ drop f f tuple-class define-class ]
  180. [ nip "slots" set-word-prop ]
  181. [ 2drop update-classes ]
  182. 3tri ;
  183. : subclasses ( class -- classes )
  184. class-usages [ tuple-class? ] filter ;
  185. : each-subclass ( class quot -- )
  186. [ subclasses ] dip each ; inline
  187. : redefine-tuple-class ( class superclass slots -- )
  188. [
  189. 2drop
  190. [
  191. [ update-tuples-after ]
  192. [ changed-conditionally ]
  193. bi
  194. ] each-subclass
  195. ]
  196. [ define-new-tuple-class ] 3bi ;
  197. : tuple-class-unchanged? ( class superclass slots -- ? )
  198. [ [ superclass ] [ bootstrap-word ] bi* = ]
  199. [ [ "slots" word-prop ] dip = ]
  200. bi-curry* bi and ;
  201. : check-superclass ( superclass -- )
  202. dup final-class? [ bad-superclass ] when
  203. dup class? [ bad-superclass ] unless drop ;
  204. GENERIC# (define-tuple-class) 2 ( class superclass slots -- )
  205. : thrower-effect ( slots -- effect )
  206. [ name>> ] map { "*" } <effect> ;
  207. : error-slots ( slots -- slots' )
  208. [
  209. dup string? [ 1array ] when
  210. read-only swap remove
  211. read-only suffix
  212. ] map ;
  213. : reset-final ( class -- )
  214. dup final-class? [
  215. [ f "final" set-word-prop ]
  216. [ changed-conditionally ]
  217. bi
  218. ] [ drop ] if ;
  219. PRIVATE>
  220. : define-tuple-class ( class superclass slots -- )
  221. over check-superclass
  222. over prepare-slots
  223. (define-tuple-class) ;
  224. GENERIC: make-final ( class -- )
  225. M: tuple-class make-final
  226. [ dup class-usage ?metaclass-changed ]
  227. [ t "final" set-word-prop ]
  228. bi ;
  229. M: word (define-tuple-class)
  230. define-new-tuple-class ;
  231. M: tuple-class (define-tuple-class)
  232. pick reset-final
  233. 3dup tuple-class-unchanged?
  234. [ 2drop ?define-symbol ] [ redefine-tuple-class ] if ;
  235. PREDICATE: error-class < tuple-class
  236. "error-class" word-prop ;
  237. M: error-class reset-class
  238. [ call-next-method ] [ "error-class" remove-word-prop ] bi ;
  239. : define-error-class ( class superclass slots -- )
  240. error-slots {
  241. [ define-tuple-class ]
  242. [ 2drop reset-generic ]
  243. [ 2drop t "error-class" set-word-prop ]
  244. [
  245. 2drop
  246. [ dup [ boa throw ] curry ]
  247. [ all-slots thrower-effect ]
  248. bi define-declared
  249. ]
  250. } 3cleave ;
  251. : boa-effect ( class -- effect )
  252. [ all-slots [ name>> ] map ] [ name>> 1array ] bi <effect> ;
  253. ERROR: not-a-tuple-class obj ;
  254. : check-tuple-class ( class -- class )
  255. dup tuple-class? [ not-a-tuple-class ] unless ; inline
  256. : define-boa-word ( word class -- )
  257. check-tuple-class [ [ boa ] curry ] [ boa-effect ] bi
  258. define-inline ;
  259. : forget-slot-accessors ( class slots -- )
  260. [
  261. name>>
  262. [ reader-word ?lookup-method forget ]
  263. [ writer-word ?lookup-method forget ] 2bi
  264. ] with each ;
  265. M: tuple-class reset-class
  266. [
  267. dup "slots" word-prop forget-slot-accessors
  268. ] [
  269. [ call-next-method ]
  270. [ { "layout" "slots" "boa-check" "prototype" "final" } reset-props ]
  271. bi
  272. ] bi ;
  273. M: tuple-class metaclass-changed
  274. ! Our superclass is no longer a tuple class, redefine with
  275. ! default superclass
  276. nip tuple over "slots" word-prop define-tuple-class ;
  277. M: tuple-class rank-class drop 1 ;
  278. M: tuple-class instance?
  279. dup echelon-of layout-class-offset tuple-instance? ;
  280. M: tuple-class (flatten-class) dup ,, ;
  281. M: tuple-class (classes-intersect?)
  282. {
  283. { [ over builtin-class? ] [ drop tuple eq? ] }
  284. { [ over tuple-class? ] [ [ class<= ] [ swap class<= ] 2bi or ] }
  285. } cond ;
  286. M: tuple clone (clone) ; inline
  287. M: tuple equal? over tuple? [ tuple= ] [ 2drop f ] if ;
  288. : tuple-hashcode ( depth obj -- hash )
  289. [
  290. [ drop 1000003 ] dip
  291. [ class-of hashcode ] [ tuple-size ] bi
  292. [ dup fixnum+fast 82520 fixnum+fast ] [ iota ] bi
  293. ] 2keep [
  294. swapd array-nth hashcode* >fixnum rot fixnum-bitxor
  295. pick fixnum*fast [ [ fixnum+fast ] keep ] dip swap
  296. ] 2curry each drop nip 97531 fixnum+fast ; inline
  297. M: tuple hashcode* [ tuple-hashcode ] recursive-hashcode ;
  298. M: tuple-class new
  299. dup "prototype" word-prop [ (clone) ] [ tuple-layout <tuple> ] ?if ;
  300. M: tuple-class boa
  301. [ "boa-check" word-prop [ call ] when* ]
  302. [ tuple-layout ]
  303. bi <tuple-boa> ;
  304. M: tuple-class initial-value* new t ;