1 ! (c)Joe Groff bsd license
2 USING: accessors alien alien.c-types alien.data alien.parser arrays
3 byte-arrays combinators effects.parser fry generalizations grouping kernel
4 lexer locals macros make math math.ranges parser sequences
5 sequences.generalizations sequences.private ;
6 FROM: alien.arrays => array-length ;
11 : <displaced-direct-array> ( displacement bytes length type -- direct-array )
12 [ <displaced-alien> ] 2dip <c-direct-array> ; inline
16 { count fixnum read-only }
18 { bytes c-ptr read-only }
19 { byte-length fixnum read-only }
20 { iter-length fixnum read-only }
21 { iter-count fixnum read-only } ;
23 M: data-map-param length
26 M: data-map-param nth-unsafe
28 [ iter-length>> * >fixnum ]
32 } cleave <displaced-direct-array> ; inline
34 INSTANCE: data-map-param immutable-sequence
36 : c-type-count ( in/out -- c-type count )
37 dup array? [ unclip swap array-length >fixnum ] [ 1 ] if ; inline
39 : c-type-iter-length ( c-type count -- iter-length )
40 swap heap-size * >fixnum ; inline
42 : [>c-type-param] ( c-type count -- quot )
43 2dup c-type-iter-length '[
53 : [>object-param] ( class count -- quot )
56 : [>param] ( type -- quot )
57 c-type-count over c-type-name?
58 [ [>c-type-param] ] [ [>object-param] ] if ;
60 MACRO: >param ( in -- quot: ( array -- param ) )
63 : [alloc-c-type-param] ( c-type count -- quot )
64 2dup c-type-iter-length dup '[
67 _ * >fixnum [ (byte-array) dup ] keep
73 : [alloc-object-param] ( type count -- quot )
74 "Factor sequences as data-map outputs not supported" throw ;
76 : [alloc-param] ( type -- quot )
77 c-type-count over c-type-name?
78 [ [alloc-c-type-param] ] [ [alloc-object-param] ] if ;
80 MACRO: alloc-param ( out -- quot: ( len -- param ) )
83 MACRO: unpack-params ( ins -- )
84 [ c-type-count nip '[ _ firstn-unsafe ] ] map '[ _ spread ] ;
86 MACRO: pack-params ( outs -- )
87 [ ] [ c-type-count nip dup [ [ ndip _ ] dip set-firstn ] 3curry ] reduce
88 fry [ call ] compose ;
90 :: [data-map] ( ins outs param-quot -- quot )
93 #ins #outs + :> #params
99 [ ins , \ unpack-params , \ @ , ] [ ] make ,
100 #outs , \ ndip , outs , \ pack-params ,
103 ] [ ] make , #outs , \ nkeep ,
104 [ orig>> ] , #outs , \ napply ,
105 ] [ ] make fry \ call suffix ;
107 MACRO: data-map ( ins outs -- )
110 [ [ '[ _ >param ] ] map '[ _ spread ] ]
111 [ length dup '[ _ ndup _ nmin-length ] compose ] bi
113 [ [ '[ _ alloc-param ] ] map '[ _ cleave ] ] bi* compose
116 MACRO: data-map! ( ins outs -- )
117 2dup append [ '[ _ >param ] ] map '[ _ spread ] [data-map] ;
119 : parse-data-map-effect ( accum -- accum )
121 [ in>> [ (parse-c-type) ] map suffix! ]
122 [ out>> [ (parse-c-type) ] map suffix! ] bi ;
127 parse-data-map-effect \ data-map suffix! ;
130 parse-data-map-effect \ data-map! suffix! ;