let data-map take factor sequences as inputs

db4
Joe Groff 2009-10-16 15:29:57 -05:00
parent 184b32cc51
commit a0c6af5603
2 changed files with 44 additions and 13 deletions

View File

@ -1,6 +1,6 @@
! (c)Joe Groff bsd license ! (c)Joe Groff bsd license
USING: alien.data.map fry generalizations kernel locals math.vectors 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 ; specialized-arrays tools.test ;
FROM: alien.c-types => uchar short int float ; FROM: alien.c-types => uchar short int float ;
SIMDS: float int short uchar ; SIMDS: float int short uchar ;
@ -13,6 +13,17 @@ IN: alien.data.map.tests
byte-array>float-array byte-array>float-array
] unit-test ] 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 } ] [ 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 } int-array{ 1 3 5 } float-array{ 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 }

View File

@ -1,6 +1,6 @@
! (c)Joe Groff bsd license ! (c)Joe Groff bsd license
USING: accessors alien alien.c-types alien.data alien.parser arrays 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 ; lexer locals macros make math math.ranges parser sequences sequences.private ;
FROM: alien.arrays => array-length ; FROM: alien.arrays => array-length ;
IN: alien.data.map IN: alien.data.map
@ -19,8 +19,6 @@ TUPLE: data-map-param
{ iter-length fixnum read-only } { iter-length fixnum read-only }
{ iter-count fixnum read-only } ; { iter-count fixnum read-only } ;
ERROR: bad-data-map-param param remainder ;
M: data-map-param length M: data-map-param length
iter-count>> ; inline iter-count>> ; inline
@ -34,12 +32,14 @@ M: data-map-param nth-unsafe
INSTANCE: data-map-param immutable-sequence INSTANCE: data-map-param immutable-sequence
: c-type-count ( in/out -- c-type count iter-length ) : c-type-count ( in/out -- c-type count )
dup array? [ unclip swap array-length >fixnum ] [ 1 ] if dup array? [ unclip swap array-length >fixnum ] [ 1 ] if ; inline
2dup swap heap-size * >fixnum ; inline
MACRO: >param ( in -- quot: ( array -- param ) ) : c-type-iter-length ( c-type count -- iter-length )
c-type-count '[ swap heap-size * >fixnum ; inline
: [>c-type-param] ( c-type count -- quot )
2dup c-type-iter-length '[
[ _ _ ] dip [ _ _ ] dip
[ ] [ ]
[ >c-ptr ] [ >c-ptr ]
@ -49,8 +49,18 @@ MACRO: >param ( in -- quot: ( array -- param ) )
data-map-param boa data-map-param boa
] ; ] ;
MACRO: alloc-param ( out -- quot: ( len -- param ) ) : [>object-param] ( class count -- quot )
c-type-count dup '[ 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 [ _ _ ] dip
[ [
_ * >fixnum [ (byte-array) dup ] keep _ * >fixnum [ (byte-array) dup ] keep
@ -59,11 +69,21 @@ MACRO: alloc-param ( out -- quot: ( len -- param ) )
data-map-param boa 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 -- ) 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 -- ) 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 ; fry [ call ] compose ;
:: [data-map] ( ins outs param-quot -- quot ) :: [data-map] ( ins outs param-quot -- quot )