! (c)Joe Groff bsd license
-USING: alien alien.c-types alien.data alien.parser arrays
-byte-arrays fry generalizations kernel lexer locals macros math
-math.ranges parser sequences sequences.private ;
+USING: accessors alien alien.c-types alien.data alien.parser arrays
+byte-arrays combinators effects.parser fry generalizations grouping kernel
+lexer locals macros make math math.ranges parser sequences
+sequences.generalizations sequences.private ;
+FROM: alien.arrays => array-length ;
IN: alien.data.map
-ERROR: bad-data-map-input-length byte-length iter-size remainder ;
-
-<PRIVATE
-
-: even-/i ( d d -- q )
- 2dup [ >fixnum ] bi@ /mod
- [ 2nip ]
- [ bad-data-map-input-length ] if-zero ; inline
-
-:: data-map-length ( array type count -- byte-length iter-size iter-count )
- array byte-length >fixnum
- type heap-size count *
- 2dup even-/i ; inline
-
-: <displaced-direct-array> ( byte-array displacement length type -- direct-array )
- [ swap <displaced-alien> ] 2dip <c-direct-array> ; inline
-
-:: data-map-loop ( input loop-quot out-bytes-quot in-type in-count out-type out-count -- out-bytes )
- input in-type in-count data-map-length
- :> iter-count :> in-size :> in-byte-length
- input >c-ptr :> in-bytes
-
- out-count out-type heap-size * :> out-size
- out-size iter-count * :> out-byte-length
- out-byte-length out-bytes-quot call :> out-bytes
-
- 0 in-byte-length 1 - >fixnum in-size >fixnum <range>
- 0 out-byte-length 1 - >fixnum out-size >fixnum <range>
- [| in-base out-base |
- in-bytes in-base in-count in-type <displaced-direct-array>
- in-count firstn-unsafe
- loop-quot call
- out-bytes out-base out-count out-type <displaced-direct-array>
- out-count set-firstn-unsafe
- ] 2each
- out-bytes ; inline
-
-PRIVATE>
-
-MACRO: data-map ( in-type in-count out-type out-count -- )
- '[ [ (byte-array) ] _ _ _ _ data-map-loop ] ;
-
-MACRO: data-map! ( in-type in-count out-type out-count -- )
- '[ swap [ [ nip >c-ptr ] curry _ _ _ _ data-map-loop drop ] keep ] ;
-
<PRIVATE
-: c-type-parsed ( accum c-type -- accum )
- dup array? [ unclip swap product ] [ 1 ] if
- [ parsed ] bi@ ;
+: <displaced-direct-array> ( displacement bytes length type -- direct-array )
+ [ <displaced-alien> ] 2dip <c-direct-array> ; inline
+
+TUPLE: data-map-param
+ { c-type read-only }
+ { count fixnum read-only }
+ { orig read-only }
+ { bytes c-ptr read-only }
+ { byte-length fixnum read-only }
+ { iter-length fixnum read-only }
+ { iter-count fixnum read-only } ;
+
+M: data-map-param length
+ iter-count>> ; inline
+
+M: data-map-param nth-unsafe
+ {
+ [ iter-length>> * >fixnum ]
+ [ bytes>> ]
+ [ count>> ]
+ [ c-type>> ]
+ } cleave <displaced-direct-array> ; inline
+
+INSTANCE: data-map-param immutable-sequence
+
+: c-type-count ( in/out -- c-type count )
+ dup array? [ unclip swap array-length >fixnum ] [ 1 ] if ; inline
+
+: c-type-iter-length ( c-type count -- iter-length )
+ swap heap-size * >fixnum ; inline
+
+: [>c-type-param] ( c-type count -- quot )
+ 2dup c-type-iter-length '[
+ [ _ _ ] dip
+ [ ]
+ [ >c-ptr ]
+ [ byte-length ] tri
+ _
+ 2dup /i
+ data-map-param boa
+ ] ;
+
+: [>object-param] ( class count -- quot )
+ nip '[ _ <sliced-groups> ] ;
+
+: [>param] ( type -- quot )
+ c-type-count over c-type-word?
+ [ [>c-type-param] ] [ [>object-param] ] if ;
+
+MACRO: >param ( in -- quot: ( array -- param ) )
+ [>param] ;
+
+: [alloc-c-type-param] ( c-type count -- quot )
+ 2dup c-type-iter-length dup '[
+ [ _ _ ] dip
+ [
+ _ * >fixnum [ (byte-array) dup ] keep
+ _
+ ] keep
+ data-map-param boa
+ ] ;
+
+: [alloc-object-param] ( type count -- quot )
+ "Factor sequences as data-map outputs not supported" throw ;
+
+: [alloc-param] ( type -- quot )
+ c-type-count over c-type-word?
+ [ [alloc-c-type-param] ] [ [alloc-object-param] ] if ;
+
+MACRO: alloc-param ( out -- quot: ( len -- param ) )
+ [alloc-param] ;
+
+MACRO: unpack-params ( ins -- )
+ [ c-type-count nip '[ _ firstn-unsafe ] ] map '[ _ spread ] ;
+
+MACRO: pack-params ( outs -- )
+ [ ] [ c-type-count nip dup [ [ ndip _ ] dip set-firstn ] 3curry ] reduce
+ fry [ call ] compose ;
+
+:: [data-map] ( ins outs param-quot -- quot )
+ ins length :> #ins
+ outs length :> #outs
+ #ins #outs + :> #params
+
+ [
+ param-quot %
+ [
+ [
+ [ ins , \ unpack-params , \ @ , ] [ ] make ,
+ #outs , \ ndip , outs , \ pack-params ,
+ ] [ ] make ,
+ #params , \ neach ,
+ ] [ ] make , #outs , \ nkeep ,
+ [ orig>> ] , #outs , \ napply ,
+ ] [ ] make fry \ call suffix ;
+
+MACRO: data-map ( ins outs -- )
+ 2dup
+ [
+ [ [ '[ _ >param ] ] map '[ _ spread ] ]
+ [ length dup '[ _ ndup _ nmin-length ] compose ] bi
+ ]
+ [ [ '[ _ alloc-param ] ] map '[ _ cleave ] ] bi* compose
+ [data-map] ;
+
+MACRO: data-map! ( ins outs -- )
+ 2dup append [ '[ _ >param ] ] map '[ _ spread ] [data-map] ;
+
+: parse-data-map-effect ( accum -- accum )
+ ")" parse-effect
+ [ in>> [ (parse-c-type) ] map suffix! ]
+ [ out>> [ (parse-c-type) ] map suffix! ] bi ;
PRIVATE>
SYNTAX: data-map(
- scan-c-type c-type-parsed
- "--" expect scan-c-type c-type-parsed ")" expect
- \ data-map parsed ;
+ parse-data-map-effect \ data-map suffix! ;
SYNTAX: data-map!(
- scan-c-type c-type-parsed
- "--" expect scan-c-type c-type-parsed ")" expect
- \ data-map! parsed ;
+ parse-data-map-effect \ data-map! suffix! ;
projects / factor.git / blobdiff