diff --git a/extra/io/binary/fast/authors.txt b/extra/io/binary/fast/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/io/binary/fast/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/io/binary/fast/fast-tests.factor b/extra/io/binary/fast/fast-tests.factor new file mode 100644 index 0000000000..ce2ff093b9 --- /dev/null +++ b/extra/io/binary/fast/fast-tests.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2011 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test io.binary.fast ; +IN: io.binary.fast.tests + +[ HEX: 0102 ] [ B{ 01 02 } 2be> ] unit-test +[ HEX: 01020304 ] [ B{ 01 02 03 04 } 4be> ] unit-test +[ HEX: 0102030405060708 ] [ B{ 01 02 03 04 05 06 07 08 } 8be> ] unit-test + +[ HEX: 0102 ] [ B{ 02 01 } 2le> ] unit-test +[ HEX: 01020304 ] [ B{ 04 03 02 01 } 4le> ] unit-test +[ HEX: 0102030405060708 ] [ B{ 08 07 06 05 04 03 02 01 } 8le> ] unit-test + diff --git a/extra/io/binary/fast/fast.factor b/extra/io/binary/fast/fast.factor new file mode 100644 index 0000000000..47f326f4e0 --- /dev/null +++ b/extra/io/binary/fast/fast.factor @@ -0,0 +1,42 @@ +! Copyright (C) 2011 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators combinators.smart fry kernel macros math +math.ranges sequences sequences.generalizations io.binary +locals ; +IN: io.binary.fast + +ERROR: bad-length bytes n ; + +: check-length ( bytes n -- bytes n ) + 2dup [ length ] dip > [ bad-length ] when ; inline + +<< +: be-range ( n -- range ) + 1 - 8 * 0 -8 ; inline + +: le-range ( n -- range ) + 1 - 8 * 0 swap 8 ; inline + +: reassemble-bytes ( range -- quot ) + [ dup 0 = [ drop [ ] ] [ '[ _ shift ] ] if ] map + '[ [ _ spread ] [ bitor ] reduce-outputs ] ; inline + +MACRO: reassemble-be ( n -- quot ) be-range reassemble-bytes ; + +MACRO: reassemble-le ( n -- quot ) le-range reassemble-bytes ; +>> + +:: n-be> ( bytes n -- x ) + bytes n check-length drop n firstn-unsafe n reassemble-be ; inline + +:: n-le> ( bytes n -- x ) + bytes n check-length drop n firstn-unsafe n reassemble-le ; inline + +: 2be> ( bytes -- x ) 2 n-be> ; +: 4be> ( bytes -- x ) 4 n-be> ; +: 8be> ( bytes -- x ) 8 n-be> ; + +: 2le> ( bytes -- x ) 2 n-le> ; +: 4le> ( bytes -- x ) 4 n-le> ; +: 8le> ( bytes -- x ) 8 n-le> ; +