1 ! (c)2009 Joe Groff bsd license
2 USING: accessors classes.struct classes.tuple combinators fry
3 functors kernel locals macros math parser quotations sequences
4 sequences.private slots specialized-arrays words ;
5 IN: classes.struct.vectored
9 : array-class-of ( type -- array-type )
10 [ define-array-vocab ] [ name>> "-array" append swap lookup-word ] bi ;
11 : <array-class>-of ( type -- array-type )
12 [ define-array-vocab ] [ name>> "<" "-array>" surround swap lookup-word ] bi ;
13 : (array-class)-of ( type -- array-type )
14 [ define-array-vocab ] [ name>> "(" "-array)" surround swap lookup-word ] bi ;
16 : >vectored-slot ( struct-slot offset -- tuple-slot )
20 [ drop type>> array-class-of dup initial-value drop ]
22 } 2cleave slot-spec boa ;
24 MACRO: first-slot ( struct-class -- quot: ( struct -- value ) )
25 struct-slots first name>> reader-word 1quotation ;
27 MACRO: set-vectored-nth ( struct-class -- quot: ( value i vector -- ) )
29 name>> reader-word 1quotation dup
30 '[ _ [ ] _ tri* set-nth-unsafe ]
31 ] map '[ _ 3cleave ] ;
33 MACRO: <vectored-slots> ( struct-class -- quot: ( n -- slots... ) )
34 struct-slots [ type>> <array-class>-of 1quotation ] map
37 MACRO: (vectored-slots) ( struct-class -- quot: ( n -- slots... ) )
38 struct-slots [ type>> (array-class)-of 1quotation ] map
41 MACRO: (vectored-element>) ( struct-class -- quot: ( elt -- struct ) )
42 [ struct-slots [ name>> reader-word 1quotation ] map ] keep
43 '[ _ cleave _ <struct-boa> ] ;
48 FUNCTOR: define-vectored-accessors ( S>> S<< T -- )
53 [ (n)>> ] [ (vectored)>> S>> ] bi nth-unsafe ; inline
55 [ (n)>> ] [ (vectored)>> S>> ] bi set-nth-unsafe ; inline
61 GENERIC: struct-transpose ( structstruct -- ssttrruucctt )
62 GENERIC: vectored-element> ( elt -- struct )
64 FUNCTOR: define-vectored-struct ( T -- )
66 T-array [ T array-class-of ]
68 vectored-T DEFINES-CLASS vectored-${T}
69 vectored-T-element DEFINES-CLASS vectored-${T}-element
71 <vectored-T> DEFINES <vectored-${T}>
72 (vectored-T) DEFINES (vectored-${T})
76 vectored-T tuple T struct-slots [ >vectored-slot ] map-index define-tuple-class
78 TUPLE: vectored-T-element
79 { (n) fixnum read-only }
80 { (vectored) vectored-T read-only } ;
83 name>> [ reader-word ] [ writer-word ] bi
84 vectored-T-element define-vectored-accessors
87 M: vectored-T-element vectored-element>
88 T (vectored-element>) ; inline
90 M: vectored-T nth-unsafe
91 vectored-T-element boa ; inline
94 T first-slot length ; inline
96 M: vectored-T set-nth-unsafe
97 T set-vectored-nth ; inline
99 INSTANCE: vectored-T sequence
101 : <vectored-T> ( n -- vectored-T )
102 T <vectored-slots> vectored-T boa ; inline
104 : (vectored-T) ( n -- vectored-T )
105 T (vectored-slots) vectored-T boa ; inline
107 M: vectored-T struct-transpose
108 [ vectored-element> ] T-array new map-as ; inline
110 M: T-array struct-transpose
111 dup length [ nip iota ] [ drop ] [ nip (vectored-T) ] 2tri
112 [ [ [ nth ] [ set-nth ] bi-curry* bi ] 2curry each ] keep ; inline
116 SYNTAX: VECTORED-STRUCT:
117 scan-word define-vectored-struct ;