renovate data-map to take any number of inputs/outputs

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

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
+USING: accessors alien alien.c-types alien.data alien.parser arrays
-byte-arrays fry generalizations kernel lexer locals macros math
+byte-arrays combinators effects.parser fry generalizations kernel
-math.ranges parser sequences sequences.private ;
+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 ;
 
 <PRIVATE
 
-: even-/i ( d d -- q )
+: <displaced-direct-array> ( displacement bytes length type -- direct-array )
-    2dup [ >fixnum ] bi@ /mod
+    [ <displaced-alien> ] 2dip <c-direct-array> ; inline
-    [ 2nip ]
-    [ bad-data-map-input-length ] if-zero ; inline
 
-:: data-map-length ( array type count -- byte-length iter-size iter-count )
+TUPLE: data-map-param
-    array byte-length >fixnum
+    { c-type read-only }
-    type heap-size count *
+    { count fixnum read-only }
-    2dup even-/i ; inline
+    { orig read-only }
+    { bytes c-ptr read-only }
+    { byte-length fixnum read-only }
+    { iter-length fixnum read-only }
+    { iter-count fixnum read-only } ;
 
-: <displaced-direct-array> ( byte-array displacement length type -- direct-array )
+ERROR: bad-data-map-param param remainder ;
-    [ 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 )
+M: data-map-param length
-    input in-type in-count data-map-length
+    iter-count>> ; inline
-        :> iter-count :> in-size :> in-byte-length
-    input >c-ptr :> in-bytes
 
-    out-count out-type heap-size * :> out-size
+M: data-map-param nth-unsafe
-    out-size iter-count * :> out-byte-length
+    {
-    out-byte-length out-bytes-quot call :> out-bytes
+        [ iter-length>> * >fixnum ]
+        [ bytes>> ]
+        [ count>> ]
+        [ c-type>> ] 
+    } cleave <displaced-direct-array> ; inline
 
-    0 in-byte-length 1 - >fixnum in-size >fixnum <range>
+INSTANCE: data-map-param immutable-sequence
-    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>
+: 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 -- )
+MACRO:: >param ( in -- quot: ( array -- param ) )
-    '[ [ (byte-array) ] _ _ _ _ data-map-loop ] ;
+    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
+    ] ;
 
-<PRIVATE
+MACRO:: alloc-param ( out -- quot: ( len -- param ) )
+    out c-type-count :> iter-length :> count :> c-type
 
-: c-type-parsed ( accum c-type -- accum )
+    [
-    dup array? [ unclip swap product ] [ 1 ] if
+        [ c-type count ] dip
-    [ parsed ] bi@ ;
+        [
+            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
+    parse-data-map-effect \ data-map parsed ;
-    "--" expect scan-c-type c-type-parsed ")" expect
-    \ data-map parsed ;
 
 SYNTAX: data-map!(
-    scan-c-type c-type-parsed
+    parse-data-map-effect \ data-map! parsed ;
-    "--" expect scan-c-type c-type-parsed ")" expect
-    \ data-map! parsed ;