From a0c6af560316afdc15bba446bdc0c94fab9dedfa Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Fri, 16 Oct 2009 15:29:57 -0500
Subject: [PATCH] let data-map take factor sequences as inputs

---
 extra/alien/data/map/map-tests.factor | 13 +++++++-
 extra/alien/data/map/map.factor       | 44 +++++++++++++++++++--------
 2 files changed, 44 insertions(+), 13 deletions(-)

diff --git a/extra/alien/data/map/map-tests.factor b/extra/alien/data/map/map-tests.factor
index eb47d3675c..25b07c381b 100644
--- a/extra/alien/data/map/map-tests.factor
+++ b/extra/alien/data/map/map-tests.factor
@@ -1,6 +1,6 @@
 ! (c)Joe Groff bsd license
 USING: alien.data.map fry generalizations kernel locals math.vectors
-math.vectors.conversion math math.vectors.simd
+math.vectors.conversion math math.vectors.simd sequences
 specialized-arrays tools.test ;
 FROM: alien.c-types => uchar short int float ;
 SIMDS: float int short uchar ;
@@ -13,6 +13,17 @@ IN: alien.data.map.tests
     byte-array>float-array
 ] unit-test
 
+[
+    float-4-array{
+        float-4{ 0.0 1.0  2.0  3.0 }
+        float-4{ 4.0 5.0  6.0  7.0 }
+        float-4{ 8.0 9.0 10.0 11.0 }
+    }
+] [
+    12 iota [ float-4-boa ] data-map( object[4] -- float-4 )
+    byte-array>float-4-array
+] unit-test
+
 [ float-array{ 1.0 1.0 3.0 3.0 5.0 5.0 0.0 0.0 } ]
 [
     int-array{ 1 3 5 } float-array{ 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 }
diff --git a/extra/alien/data/map/map.factor b/extra/alien/data/map/map.factor
index 21a026644e..8039015a85 100644
--- a/extra/alien/data/map/map.factor
+++ b/extra/alien/data/map/map.factor
@@ -1,6 +1,6 @@
 ! (c)Joe Groff bsd license
 USING: accessors alien alien.c-types alien.data alien.parser arrays
-byte-arrays combinators effects.parser fry generalizations kernel
+byte-arrays combinators effects.parser fry generalizations grouping kernel
 lexer locals macros make math math.ranges parser sequences sequences.private ;
 FROM: alien.arrays => array-length ;
 IN: alien.data.map
@@ -19,8 +19,6 @@ TUPLE: data-map-param
     { iter-length fixnum read-only }
     { iter-count fixnum read-only } ;
 
-ERROR: bad-data-map-param param remainder ;
-
 M: data-map-param length
     iter-count>> ; inline
 
@@ -34,12 +32,14 @@ M: data-map-param nth-unsafe
 
 INSTANCE: data-map-param immutable-sequence
 
-: c-type-count ( in/out -- c-type count iter-length )
-    dup array? [ unclip swap array-length >fixnum ] [ 1 ] if
-    2dup swap heap-size * >fixnum ; inline
+: c-type-count ( in/out -- c-type count )
+    dup array? [ unclip swap array-length >fixnum ] [ 1 ] if ; inline
 
-MACRO: >param ( in -- quot: ( array -- param ) )
-    c-type-count '[
+: 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 ]
@@ -49,8 +49,18 @@ MACRO: >param ( in -- quot: ( array -- param ) )
         data-map-param boa
     ] ;
 
-MACRO: alloc-param ( out -- quot: ( len -- param ) )
-    c-type-count dup '[
+: [>object-param] ( class count -- quot )
+    nip '[ _ <sliced-groups> ] ;
+
+: [>param] ( type -- quot )
+    c-type-count over c-type-name?
+    [ [>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
@@ -59,11 +69,21 @@ MACRO: alloc-param ( out -- quot: ( len -- param ) )
         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-name?
+    [ [alloc-c-type-param] ] [ [alloc-object-param] ] if ; 
+
+MACRO: alloc-param ( out -- quot: ( len -- param ) )
+    [alloc-param] ;
+
 MACRO: unpack-params ( ins -- )
-    [ c-type-count drop nip '[ _ firstn-unsafe ] ] map '[ _ spread ] ;
+    [ c-type-count nip '[ _ firstn-unsafe ] ] map '[ _ spread ] ;
 
 MACRO: pack-params ( outs -- )
-    [ ] [ c-type-count drop nip dup [ [ ndip _ ] dip set-firstn ] 3curry ] reduce
+    [ ] [ c-type-count nip dup [ [ ndip _ ] dip set-firstn ] 3curry ] reduce
     fry [ call ] compose ;
 
 :: [data-map] ( ins outs param-quot -- quot )