Merge branch 'master' of git://factorcode.org/git/factor

db4
Doug Coleman 2009-10-15 21:37:58 -05:00
commit 66d81e5c32
3 changed files with 45 additions and 23 deletions

View File

@ -172,7 +172,7 @@ HELP: ndip
} ; } ;
HELP: nkeep HELP: nkeep
{ $values { "quot" quotation } { "n" integer } } { $values { "n" integer } }
{ $description "A generalization of " { $link keep } " that can work " { $description "A generalization of " { $link keep } " that can work "
"for any stack depth. The first " { $snippet "n" } " items after the quotation will be " "for any stack depth. The first " { $snippet "n" } " items after the quotation will be "
"saved, the quotation called, and the items restored." "saved, the quotation called, and the items restored."

View File

@ -1,5 +1,5 @@
! (c)Joe Groff bsd license ! (c)Joe Groff bsd license
USING: alien.data.map fry generalizations kernel 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
specialized-arrays tools.test ; specialized-arrays tools.test ;
FROM: alien.c-types => uchar short int float ; FROM: alien.c-types => uchar short int float ;
@ -19,6 +19,13 @@ IN: alien.data.map.tests
[ dup ] data-map!( int -- float[2] ) [ dup ] data-map!( int -- float[2] )
] unit-test ] unit-test
:: float-pixels>byte-pixels-locals ( floats scale bias -- bytes )
floats [
[ scale 255.0 * v*n bias 255.0 * v+n float-4 int-4 vconvert ] 4 napply
[ int-4 short-8 vconvert ] 2bi@
short-8 uchar-16 vconvert
] data-map( float-4[4] -- uchar-16 ) ; inline
: float-pixels>byte-pixels* ( floats scale bias -- bytes ) : float-pixels>byte-pixels* ( floats scale bias -- bytes )
'[ '[
[ _ 255.0 * v*n _ 255.0 * v+n float-4 int-4 vconvert ] 4 napply [ _ 255.0 * v*n _ 255.0 * v+n float-4 int-4 vconvert ] 4 napply
@ -29,6 +36,22 @@ IN: alien.data.map.tests
: float-pixels>byte-pixels ( floats -- bytes ) : float-pixels>byte-pixels ( floats -- bytes )
1.0 0.0 float-pixels>byte-pixels* ; 1.0 0.0 float-pixels>byte-pixels* ;
[
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
0.3 0.2 0.9 0.5
0.1 1.0 1.5 2.0
} 1.0 0.0 float-pixels>byte-pixels-locals
] unit-test
[ [
B{ B{
127 191 255 63 127 191 255 63

View File

@ -1,7 +1,7 @@
! (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 kernel
lexer locals macros math math.ranges parser sequences sequences.private ; lexer locals macros make math math.ranges parser sequences sequences.private ;
IN: alien.data.map IN: alien.data.map
ERROR: bad-data-map-input-length byte-length iter-size remainder ; ERROR: bad-data-map-input-length byte-length iter-size remainder ;
@ -39,27 +39,23 @@ INSTANCE: data-map-param immutable-sequence
dup array? [ unclip swap product >fixnum ] [ 1 ] if dup array? [ unclip swap product >fixnum ] [ 1 ] if
2dup swap heap-size * >fixnum ; inline 2dup swap heap-size * >fixnum ; inline
MACRO:: >param ( in -- quot: ( array -- param ) ) MACRO: >param ( in -- quot: ( array -- param ) )
in c-type-count :> iter-length :> count :> c-type c-type-count '[
[ _ _ ] dip
[
[ c-type count ] dip
[ ] [ ]
[ >c-ptr ] [ >c-ptr ]
[ byte-length ] tri [ byte-length ] tri
iter-length _
2dup /i 2dup /i
data-map-param boa data-map-param boa
] ; ] ;
MACRO:: alloc-param ( out -- quot: ( len -- param ) ) MACRO: alloc-param ( out -- quot: ( len -- param ) )
out c-type-count :> iter-length :> count :> c-type c-type-count dup '[
[ _ _ ] dip
[
[ c-type count ] dip
[ [
iter-length * >fixnum [ (byte-array) dup ] keep _ * >fixnum [ (byte-array) dup ] keep
iter-length _
] keep ] keep
data-map-param boa data-map-param boa
] ; ] ;
@ -76,14 +72,17 @@ MACRO: pack-params ( outs -- )
outs length :> #outs outs length :> #outs
#ins #outs + :> #params #ins #outs + :> #params
[| quot | [
param-quot call param-quot %
[ [
[ [ ins unpack-params quot call ] #outs ndip outs pack-params ] [
#params neach [ ins , \ unpack-params , \ @ , ] [ ] make ,
] #outs nkeep #outs , \ ndip , outs , \ pack-params ,
[ orig>> ] #outs napply ] [ ] make ,
] ; #params , \ neach ,
] [ ] make , #outs , \ nkeep ,
[ orig>> ] , #outs , \ napply ,
] [ ] make fry \ call suffix ;
MACRO: data-map ( ins outs -- ) MACRO: data-map ( ins outs -- )
2dup 2dup