1 ! Copyright (C) 2009 Joe Groff.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors classes.struct classes.tuple combinators fry
4 functors kernel locals macros math parser quotations sequences
5 sequences.private slots specialized-arrays words ;
6 IN: classes.struct.vectored
10 : array-class-of ( type -- array-type )
11 [ define-array-vocab ] [ name>> "-array" append swap lookup-word ] bi ;
12 : <array-class>-of ( type -- array-type )
13 [ define-array-vocab ] [ name>> "<" "-array>" surround swap lookup-word ] bi ;
14 : (array-class)-of ( type -- array-type )
15 [ define-array-vocab ] [ name>> "(" "-array)" surround swap lookup-word ] bi ;
17 : >vectored-slot ( struct-slot offset -- tuple-slot )
21 [ drop type>> array-class-of dup initial-value drop ]
23 } 2cleave slot-spec boa ;
25 MACRO: first-slot ( struct-class -- quot: ( struct -- value ) )
26 struct-slots first name>> reader-word 1quotation ;
28 MACRO: set-vectored-nth ( struct-class -- quot: ( value i vector -- ) )
30 name>> reader-word 1quotation dup
31 '[ _ [ ] _ tri* set-nth-unsafe ]
32 ] map '[ _ 3cleave ] ;
34 MACRO: <vectored-slots> ( struct-class -- quot: ( n -- slots... ) )
35 struct-slots [ type>> <array-class>-of 1quotation ] map
38 MACRO: (vectored-slots) ( struct-class -- quot: ( n -- slots... ) )
39 struct-slots [ type>> (array-class)-of 1quotation ] map
42 MACRO: (vectored-element>) ( struct-class -- quot: ( elt -- struct ) )
43 [ struct-slots [ name>> reader-word 1quotation ] map ] keep
49 <FUNCTOR: define-vectored-accessors ( S>> S<< T -- )
54 [ (n)>> ] [ (vectored)>> S>> ] bi nth-unsafe ; inline
56 [ (n)>> ] [ (vectored)>> S>> ] bi set-nth-unsafe ; inline
62 GENERIC: struct-transpose ( structstruct -- ssttrruucctt )
63 GENERIC: vectored-element> ( elt -- struct )
65 <FUNCTOR: define-vectored-struct ( T -- )
67 T-array [ T array-class-of ]
69 vectored-T DEFINES-CLASS vectored-${T}
70 vectored-T-element DEFINES-CLASS vectored-${T}-element
72 <vectored-T> DEFINES <vectored-${T}>
73 (vectored-T) DEFINES (vectored-${T})
77 vectored-T tuple T struct-slots [ >vectored-slot ] map-index define-tuple-class
79 TUPLE: vectored-T-element
80 { (n) fixnum read-only }
81 { (vectored) vectored-T read-only } ;
84 name>> [ reader-word ] [ writer-word ] bi
85 vectored-T-element define-vectored-accessors
88 M: vectored-T-element vectored-element>
89 T (vectored-element>) ; inline
91 M: vectored-T nth-unsafe
92 vectored-T-element boa ; inline
95 T first-slot length ; inline
97 M: vectored-T set-nth-unsafe
98 T set-vectored-nth ; inline
100 INSTANCE: vectored-T sequence
102 : <vectored-T> ( n -- vectored-T )
103 T <vectored-slots> vectored-T boa ; inline
105 : (vectored-T) ( n -- vectored-T )
106 T (vectored-slots) vectored-T boa ; inline
108 M: vectored-T struct-transpose
109 [ vectored-element> ] T-array new map-as ; inline
111 M: T-array struct-transpose
112 dup length [ nip <iota> ] [ drop ] [ nip (vectored-T) ] 2tri
113 [ [ [ nth ] [ set-nth ] bi-curry* bi ] 2curry each ] keep ; inline
117 SYNTAX: VECTORED-STRUCT:
118 scan-word define-vectored-struct ;