steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

redo pack/unpack, refactor most of pack to be more efficient. 

sorry if i killed a word you were using.
db4
Doug Coleman 2009-01-18 20:40:19 -06:00
parent 213a429928
commit 8c857f0d4b
2 changed files with 83 additions and 126 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
basis/pack/pack-tests.factor
View File

@ -1,5 +1,6 @@
USING: io io.streams.string kernel namespaces make USING: io io.streams.string kernel namespaces make
pack strings tools.test ; pack strings tools.test pack.private ;
IN: pack.tests
[ B{ 1 0 2 0 0 3 0 0 0 4 0 0 0 0 0 0 0 5 } ] [ [ B{ 1 0 2 0 0 3 0 0 0 4 0 0 0 0 0 0 0 5 } ] [
{ 1 2 3 4 5 } { 1 2 3 4 5 }
@ -37,15 +38,6 @@ pack strings tools.test ;
"cstiq" [ pack-native ] keep unpack-native "cstiq" [ pack-native ] keep unpack-native
] unit-test ] unit-test
[ 2 ] [
[ 2 "int" b, ] B{ } make
<string-reader> [ "int" read-native ] with-input-stream
] unit-test
[ "FRAM" ] [ "FRAM\0" [ read-c-string ] with-string-reader ] unit-test
[ f ] [ "" [ read-c-string ] with-string-reader ] unit-test
[ 5 ] [ "FRAM\0\u000005\0\0\0\0\0\0\0" [ read-c-string drop read-u64 ] with-string-reader ] unit-test
[ 9 ] [ "iic" packed-length ] unit-test [ 9 ] [ "iic" packed-length ] unit-test
[ "iii" read-packed-le ] must-infer [ "iii" read-packed-le ] must-infer
[ "iii" read-packed-be ] must-infer [ "iii" read-packed-be ] must-infer
@ -53,3 +45,10 @@ pack strings tools.test ;
[ "iii" unpack-le ] must-infer [ "iii" unpack-le ] must-infer
[ "iii" unpack-be ] must-infer [ "iii" unpack-be ] must-infer
[ "iii" unpack-native ] must-infer [ "iii" unpack-native ] must-infer
[ "iii" pack ] must-infer
[ "iii" unpack ] must-infer
: test-pack ( str -- ba )
"iii" pack ;
[ test-pack ] must-infer

190
basis/pack/pack.factor
View File

@ -3,7 +3,9 @@
USING: alien alien.c-types arrays assocs byte-arrays io USING: alien alien.c-types arrays assocs byte-arrays io
io.binary io.streams.string kernel math math.parser namespaces io.binary io.streams.string kernel math math.parser namespaces
make parser prettyprint quotations sequences strings vectors make parser prettyprint quotations sequences strings vectors
words macros math.functions math.bitwise fry ; words macros math.functions math.bitwise fry generalizations
combinators.smart io.streams.byte-array io.encodings.binary
math.vectors combinators multiline ;
IN: pack IN: pack
SYMBOL: big-endian SYMBOL: big-endian
@ -18,131 +20,77 @@ SYMBOL: big-endian
PRIVATE> PRIVATE>
: >endian ( obj n -- str )
big-endian get [ >be ] [ >le ] if ; inline
: endian> ( obj -- str )
big-endian get [ be> ] [ le> ] if ; inline
GENERIC: b, ( n obj -- )
M: integer b, ( m n -- ) >endian % ;
! for doing native, platform-dependent sized values
M: string b, ( n string -- ) heap-size b, ;
: read-native ( string -- n ) heap-size read endian> ;
! Portable
: s8, ( n -- ) 1 b, ;
: u8, ( n -- ) 1 b, ;
: s16, ( n -- ) 2 b, ;
: u16, ( n -- ) 2 b, ;
: s24, ( n -- ) 3 b, ;
: u24, ( n -- ) 3 b, ;
: s32, ( n -- ) 4 b, ;
: u32, ( n -- ) 4 b, ;
: s64, ( n -- ) 8 b, ;
: u64, ( n -- ) 8 b, ;
: s128, ( n -- ) 16 b, ;
: u128, ( n -- ) 16 b, ;
: float, ( n -- ) float>bits 4 b, ;
: double, ( n -- ) double>bits 8 b, ;
: c-string, ( str -- ) % 0 u8, ;
<PRIVATE
: (>128-ber) ( n -- )
dup 0 > [
[ HEX: 7f bitand HEX: 80 bitor , ] keep -7 shift
(>128-ber)
] [
drop
] if ;
PRIVATE>
: >128-ber ( n -- str )
[
[ HEX: 7f bitand , ] keep -7 shift
(>128-ber)
] { } make reverse ;
: >signed ( x n -- y ) : >signed ( x n -- y )
2dup neg 1+ shift 1 = [ 2^ - ] [ drop ] if ; 2dup neg 1+ shift 1 = [ 2^ - ] [ drop ] if ;
: read-signed ( n -- str ) : >endian ( obj n -- str )
dup read endian> swap 8 * >signed ; big-endian get [ >be ] [ >le ] if ; inline
: read-unsigned ( n -- m ) read endian> ; : unsigned-endian> ( obj -- str )
big-endian get [ be> ] [ le> ] if ; inline
: read-s8 ( -- n ) 1 read-signed ; : signed-endian> ( obj n -- str )
: read-u8 ( -- n ) 1 read-unsigned ; [ unsigned-endian> ] dip >signed ;
: read-s16 ( -- n ) 2 read-signed ;
: read-u16 ( -- n ) 2 read-unsigned ;
: read-s24 ( -- n ) 3 read-signed ;
: read-u24 ( -- n ) 3 read-unsigned ;
: read-s32 ( -- n ) 4 read-signed ;
: read-u32 ( -- n ) 4 read-unsigned ;
: read-s64 ( -- n ) 8 read-signed ;
: read-u64 ( -- n ) 8 read-unsigned ;
: read-s128 ( -- n ) 16 read-signed ;
: read-u128 ( -- n ) 16 read-unsigned ;
: read-float ( -- n ) GENERIC: >n-byte-array ( obj n -- byte-array )
4 read endian> bits>float ;
: read-double ( -- n ) M: integer >n-byte-array ( m n -- byte-array ) >endian ;
8 read endian> bits>double ;
: read-c-string ( -- str/f ) ! for doing native, platform-dependent sized values
"\0" read-until swap and ; M: string >n-byte-array ( n string -- byte-array ) heap-size >n-byte-array ;
: read-c-string* ( n -- str/f ) : s8>byte-array ( n -- byte-array ) 1 >n-byte-array ;
read [ zero? ] trim-right [ f ] when-empty ; : u8>byte-array ( n -- byte-array ) 1 >n-byte-array ;
: s16>byte-array ( n -- byte-array ) 2 >n-byte-array ;
: (read-128-ber) ( n -- n ) : u16>byte-array ( n -- byte-array ) 2 >n-byte-array ;
read1 : s24>byte-array ( n -- byte-array ) 3 >n-byte-array ;
[ [ 7 shift ] [ 7 clear-bit ] bi* bitor ] keep : u24>byte-array ( n -- byte-array ) 3 >n-byte-array ;
7 bit? [ (read-128-ber) ] when ; : s32>byte-array ( n -- byte-array ) 4 >n-byte-array ;
: u32>byte-array ( n -- byte-array ) 4 >n-byte-array ;
: read-128-ber ( -- n ) : s64>byte-array ( n -- byte-array ) 8 >n-byte-array ;
0 (read-128-ber) ; : u64>byte-array ( n -- byte-array ) 8 >n-byte-array ;
: s128>byte-array ( n -- byte-array ) 16 >n-byte-array ;
: u128>byte-array ( n -- byte-array ) 16 >n-byte-array ;
: write-float ( n -- byte-array ) float>bits 4 >n-byte-array ;
: write-double ( n -- byte-array ) double>bits 8 >n-byte-array ;
: write-c-string ( byte-array -- byte-array ) { 0 } B{ } append-as ;
<PRIVATE <PRIVATE
CONSTANT: pack-table CONSTANT: pack-table
H{ H{
{ CHAR: c s8, } { CHAR: c s8>byte-array }
{ CHAR: C u8, } { CHAR: C u8>byte-array }
{ CHAR: s s16, } { CHAR: s s16>byte-array }
{ CHAR: S u16, } { CHAR: S u16>byte-array }
{ CHAR: t s24, } { CHAR: t s24>byte-array }
{ CHAR: T u24, } { CHAR: T u24>byte-array }
{ CHAR: i s32, } { CHAR: i s32>byte-array }
{ CHAR: I u32, } { CHAR: I u32>byte-array }
{ CHAR: q s64, } { CHAR: q s64>byte-array }
{ CHAR: Q u64, } { CHAR: Q u64>byte-array }
{ CHAR: f float, } { CHAR: f write-float }
{ CHAR: F float, } { CHAR: F write-float }
{ CHAR: d double, } { CHAR: d write-double }
{ CHAR: D double, } { CHAR: D write-double }
} }
CONSTANT: unpack-table CONSTANT: unpack-table
H{ H{
{ CHAR: c read-s8 } { CHAR: c [ 8 signed-endian> ] }
{ CHAR: C read-u8 } { CHAR: C [ unsigned-endian> ] }
{ CHAR: s read-s16 } { CHAR: s [ 16 signed-endian> ] }
{ CHAR: S read-u16 } { CHAR: S [ unsigned-endian> ] }
{ CHAR: t read-s24 } { CHAR: t [ 24 signed-endian> ] }
{ CHAR: T read-u24 } { CHAR: T [ unsigned-endian> ] }
{ CHAR: i read-s32 } { CHAR: i [ 32 signed-endian> ] }
{ CHAR: I read-u32 } { CHAR: I [ unsigned-endian> ] }
{ CHAR: q read-s64 } { CHAR: q [ 64 signed-endian> ] }
{ CHAR: Q read-u64 } { CHAR: Q [ unsigned-endian> ] }
{ CHAR: f read-float } { CHAR: f [ unsigned-endian> bits>float ] }
{ CHAR: F read-float } { CHAR: F [ unsigned-endian> bits>float ] }
{ CHAR: d read-double } { CHAR: d [ unsigned-endian> bits>double ] }
{ CHAR: D read-double } { CHAR: D [ unsigned-endian> bits>double ] }
} }
CONSTANT: packed-length-table CONSTANT: packed-length-table
@ -163,12 +111,20 @@ CONSTANT: packed-length-table
{ CHAR: D 8 } { CHAR: D 8 }
} }
MACRO: pack ( seq str -- quot ) MACRO: pack ( str -- quot )
[ pack-table at 1quotation '[ _ @ ] ] [ ] 2map-as concat [ pack-table at '[ _ execute ] ] { } map-as
'[ _ B{ } make ] ; '[ _ spread ]
'[ _ input<sequence ]
'[ _ B{ } append-outputs-as ] ;
PRIVATE> PRIVATE>
: ch>packed-length ( ch -- n )
packed-length-table at ; inline
: packed-length ( str -- n )
[ ch>packed-length ] sigma ;
: pack-native ( seq str -- seq ) : pack-native ( seq str -- seq )
[ set-big-endian pack ] with-scope ; inline [ set-big-endian pack ] with-scope ; inline
@ -180,9 +136,14 @@ PRIVATE>
<PRIVATE <PRIVATE
: start/end ( seq -- seq1 seq2 )
[ 0 [ + ] accumulate nip dup ] keep v+ ; inline
MACRO: unpack ( str -- quot ) MACRO: unpack ( str -- quot )
[ unpack-table at 1quotation '[ @ , ] ] { } map-as concat [ [ ch>packed-length ] { } map-as start/end ]
'[ [ _ { } make ] with-string-reader ] ; [ [ unpack-table at '[ @ ] ] { } map-as ] bi
[ '[ [ _ _ ] dip <slice> @ ] ] 3map
'[ _ cleave ] '[ _ output>array ] ;
PRIVATE> PRIVATE>
@ -195,9 +156,6 @@ PRIVATE>
: unpack-le ( seq str -- seq ) : unpack-le ( seq str -- seq )
[ big-endian off unpack ] with-scope ; inline [ big-endian off unpack ] with-scope ; inline
: packed-length ( str -- n )
[ packed-length-table at ] sigma ;
ERROR: packed-read-fail str bytes ; ERROR: packed-read-fail str bytes ;
<PRIVATE <PRIVATE