diff --git a/extra/alien/data/map/map-tests.factor b/extra/alien/data/map/map-tests.factor index ea99c2b6ef..e4e1aa6d18 100644 --- a/extra/alien/data/map/map-tests.factor +++ b/extra/alien/data/map/map-tests.factor @@ -40,6 +40,13 @@ IN: alien.data.map.tests ] unit-test [ + B{ + 127 191 255 63 + 255 25 51 76 + 76 51 229 127 + 25 255 255 255 + } +] [ float-array{ 0.5 0.75 1.0 0.25 1.0 0.1 0.2 0.3 @@ -51,4 +58,35 @@ IN: alien.data.map.tests [ int-4 short-8 vconvert ] 2bi@ short-8 uchar-16 vconvert ] data-map( float-4[4] -- uchar-16 ) -] [ bad-data-map-input-length? ] must-fail-with +] unit-test + +: vmerge-transpose ( a b c d -- ac bd ac bd ) + [ (vmerge) ] bi-curry@ bi* ; inline + +[ + B{ + 1 10 11 15 + 2 20 22 25 + 3 30 33 35 + 4 40 44 45 + 5 50 55 55 + 6 60 66 65 + 7 70 77 75 + 8 80 88 85 + 9 90 99 95 + 10 100 110 105 + 11 110 121 115 + 12 120 132 125 + 13 130 143 135 + 14 140 154 145 + 15 150 165 155 + 16 160 176 165 + } +] [ + B{ 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 } + B{ 10 20 30 40 50 60 70 80 90 100 110 120 130 140 150 160 } + B{ 11 22 33 44 55 66 77 88 99 110 121 132 143 154 165 176 } + B{ 15 25 35 45 55 65 75 85 95 105 115 125 135 145 155 165 } + [ vmerge-transpose vmerge-transpose ] + data-map( uchar-16 uchar-16 uchar-16 uchar-16 -- uchar-16[4] ) +] unit-test diff --git a/extra/alien/data/map/map.factor b/extra/alien/data/map/map.factor index 5789c376ce..ea232fb15a 100644 --- a/extra/alien/data/map/map.factor +++ b/extra/alien/data/map/map.factor @@ -1,69 +1,112 @@ ! (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 kernel +lexer locals macros math math.ranges parser sequences sequences.private ; IN: alien.data.map ERROR: bad-data-map-input-length byte-length iter-size remainder ; fixnum ] bi@ /mod - [ 2nip ] - [ bad-data-map-input-length ] if-zero ; inline +: ( displacement bytes length type -- direct-array ) + [ ] 2dip ; 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 +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 } ; -: ( byte-array displacement length type -- direct-array ) - [ swap ] 2dip ; inline +ERROR: bad-data-map-param param remainder ; -:: 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 +M: data-map-param length + iter-count>> ; inline - out-count out-type heap-size * :> out-size - out-size iter-count * :> out-byte-length - out-byte-length out-bytes-quot call :> out-bytes +M: data-map-param nth-unsafe + { + [ iter-length>> * >fixnum ] + [ bytes>> ] + [ count>> ] + [ c-type>> ] + } cleave ; inline - 0 in-byte-length 1 - >fixnum in-size >fixnum - 0 out-byte-length 1 - >fixnum out-size >fixnum - [| in-base out-base | - in-bytes in-base in-count in-type - in-count firstn-unsafe - loop-quot call - out-bytes out-base out-count out-type - out-count set-firstn-unsafe - ] 2each - out-bytes ; inline +INSTANCE: data-map-param immutable-sequence -PRIVATE> +: c-type-count ( in/out -- c-type count iter-length ) + dup array? [ unclip swap product >fixnum ] [ 1 ] if + 2dup swap heap-size * >fixnum ; inline -MACRO: data-map ( in-type in-count out-type out-count -- ) - '[ [ (byte-array) ] _ _ _ _ data-map-loop ] ; +MACRO:: >param ( in -- quot: ( array -- param ) ) + in c-type-count :> iter-length :> count :> c-type -MACRO: data-map! ( in-type in-count out-type out-count -- ) - '[ swap [ [ nip >c-ptr ] curry _ _ _ _ data-map-loop drop ] keep ] ; + [ + [ c-type count ] dip + [ ] + [ >c-ptr ] + [ byte-length ] tri + iter-length + 2dup /i + data-map-param boa + ] ; - iter-length :> count :> c-type -: c-type-parsed ( accum c-type -- accum ) - dup array? [ unclip swap product ] [ 1 ] if - [ parsed ] bi@ ; + [ + [ c-type count ] dip + [ + iter-length * >fixnum [ (byte-array) dup ] keep + iter-length + ] keep + data-map-param boa + ] ; + +MACRO: unpack-params ( ins -- ) + [ c-type-count drop nip '[ _ firstn-unsafe ] ] map '[ _ spread ] ; + +MACRO: pack-params ( outs -- ) + [ ] [ c-type-count drop 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 + + [| quot | + param-quot call + [ + [ [ ins unpack-params quot call ] #outs ndip outs pack-params ] + #params neach + ] #outs nkeep + [ orig>> ] #outs napply + ] ; + +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 parsed ] + [ out>> [ parse-c-type ] map parsed ] 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 parsed ; 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! parsed ;