From e35614e805c56abc81190b3bbfc962aed1342b8b Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Wed, 14 Oct 2009 21:50:06 -0500
Subject: [PATCH] renovate data-map to take any number of inputs/outputs
---
extra/alien/data/map/map-tests.factor | 40 +++++++-
extra/alien/data/map/map.factor | 133 +++++++++++++++++---------
2 files changed, 127 insertions(+), 46 deletions(-)
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 ;
<PRIVATE
-: even-/i ( d d -- q )
- 2dup [ >fixnum ] bi@ /mod
- [ 2nip ]
- [ bad-data-map-input-length ] if-zero ; inline
+: <displaced-direct-array> ( displacement bytes length type -- direct-array )
+ [ <displaced-alien> ] 2dip <c-direct-array> ; 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 } ;
-: <displaced-direct-array> ( byte-array displacement length type -- direct-array )
- [ swap <displaced-alien> ] 2dip <c-direct-array> ; 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 <displaced-direct-array> ; inline
- 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
+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
+ ] ;
-<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
- [ 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 ;