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

basis/pack/pack-tests.factor

@@ -46,3 +46,10 @@ pack strings tools.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
+[ "iii" read-packed-le ] must-infer
+[ "iii" read-packed-be ] must-infer
+[ "iii" read-packed-native ] must-infer
+[ "iii" unpack-le ] must-infer
+[ "iii" unpack-be ] must-infer
+[ "iii" unpack-native ] must-infer

basis/pack/pack.factor

@@ -1,7 +1,9 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types arrays assocs byte-arrays io
 io.binary io.streams.string kernel math math.parser namespaces
 make parser prettyprint quotations sequences strings vectors
-words macros math.functions math.bitwise ;
+words macros math.functions math.bitwise fry ;
 IN: pack
 
 SYMBOL: big-endian
@@ -9,6 +11,13 @@ SYMBOL: big-endian
 : big-endian? ( -- ? )
     1 <int> *char zero? ;
 
+<PRIVATE
+
+: set-big-endian ( -- )
+    big-endian? big-endian set ; inline
+
+PRIVATE>
+
 : >endian ( obj n -- str )
     big-endian get [ >be ] [ >le ] if ; inline
 
@@ -39,6 +48,8 @@ M: string b, ( n string -- ) heap-size 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
@@ -47,6 +58,8 @@ M: string b, ( n string -- ) heap-size b, ;
         drop
     ] if ;
 
+PRIVATE>
+
 : >128-ber ( n -- str )
     [
         [ HEX: 7f bitand , ] keep -7 shift
@@ -70,7 +83,7 @@ M: string b, ( n string -- ) heap-size b, ;
 : read-s32 ( -- n ) 4 read-signed ;
 : read-u32 ( -- n ) 4 read-unsigned ;
 : read-s64 ( -- n ) 8 read-signed ;
-: read-u64 ( -- n ) 8 read-signed ;
+: read-u64 ( -- n ) 8 read-unsigned ;
 : read-s128 ( -- n ) 16 read-signed ;
 : read-u128 ( -- n ) 16 read-unsigned ;
 
@@ -81,7 +94,7 @@ M: string b, ( n string -- ) heap-size b, ;
     8 read endian> bits>double ;
 
 : read-c-string ( -- str/f )
-    "\0" read-until [ drop f ] unless ;
+    "\0" read-until swap and ;
 
 : read-c-string* ( n -- str/f )
     read [ zero? ] trim-right [ f ] when-empty ;
@@ -94,7 +107,9 @@ M: string b, ( n string -- ) heap-size b, ;
 : read-128-ber ( -- n )
     0 (read-128-ber) ;
 
-: pack-table ( -- hash )
+<PRIVATE
+
+CONSTANT: pack-table
     H{
         { CHAR: c s8, }
         { CHAR: C u8, }
@@ -110,9 +125,9 @@ M: string b, ( n string -- ) heap-size b, ;
         { CHAR: F float, }
         { CHAR: d double, }
         { CHAR: D double, }
-    } ;
+    }
 
-: unpack-table ( -- hash )
+CONSTANT: unpack-table
     H{
         { CHAR: c read-s8 }
         { CHAR: C read-u8 }
@@ -128,47 +143,79 @@ M: string b, ( n string -- ) heap-size b, ;
         { CHAR: F read-float }
         { CHAR: d read-double }
         { CHAR: D read-double }
-    } ;
+    }
 
-MACRO: (pack) ( seq str -- quot )
+CONSTANT: packed-length-table
-    [
+    H{
-        [
+        { CHAR: c 1 }
-            [
+        { CHAR: C 1 }
-                swap , pack-table at ,
+        { CHAR: s 2 }
-            ] 2each
+        { CHAR: S 2 }
-        ] [ ] make 1quotation %
+        { CHAR: t 3 }
-       [ B{ } make ] %
+        { CHAR: T 3 }
-    ] [ ] make ;
+        { CHAR: i 4 }
+        { CHAR: I 4 }
+        { CHAR: q 8 }
+        { CHAR: Q 8 }
+        { CHAR: f 4 }
+        { CHAR: F 4 }
+        { CHAR: d 8 }
+        { CHAR: D 8 }
+    }
+
+MACRO: pack ( seq str -- quot )
+    [ pack-table at 1quotation '[ _ @ ] ] [ ] 2map-as concat
+    '[ _ B{ } make ] ;
+
+PRIVATE>
  
 : pack-native ( seq str -- seq )
-    [
+    [ set-big-endian pack ] with-scope ; inline
-        big-endian? big-endian set (pack)
-    ] with-scope ;
 
 : pack-be ( seq str -- seq )
-    [ big-endian on (pack) ] with-scope ;
+    [ big-endian on pack ] with-scope ; inline
 
 : pack-le ( seq str -- seq )
-    [ big-endian off (pack) ] with-scope ;
+    [ big-endian off pack ] with-scope ; inline
 
+<PRIVATE
 
-MACRO: (unpack) ( str -- quot )
+MACRO: unpack ( str -- quot )
-    [
+    [ unpack-table at 1quotation '[ @ , ] ] { } map-as concat
-        [
+    '[ [ _ { } make ] with-string-reader ] ;
-            [ unpack-table at , \ , , ] each
+
-        ] [ ] make
+PRIVATE>
-        1quotation [ { } make ] append
-        1quotation %
-        \ with-string-reader ,
-    ] [ ] make ;
 
 : unpack-native ( seq str -- seq )
-    [
+    [ set-big-endian unpack ] with-scope ; inline
-        big-endian? big-endian set (unpack)
-    ] with-scope ;
 
 : unpack-be ( seq str -- seq )
-    [ big-endian on (unpack) ] with-scope ;
+    [ big-endian on unpack ] with-scope ; inline
 
 : unpack-le ( seq str -- seq )
-    [ big-endian off (unpack) ] with-scope ;
+    [ big-endian off unpack ] with-scope ; inline
+
+: packed-length ( str -- n )
+    [ packed-length-table at ] sigma ;
+
+ERROR: packed-read-fail str bytes ;
+
+<PRIVATE
+
+: read-packed-bytes ( str -- bytes )
+    dup packed-length [ read dup length ] keep =
+    [ nip ] [ packed-read-fail ] if ; inline
+
+PRIVATE>
+
+: read-packed ( str quot -- seq )
+    [ read-packed-bytes ] swap bi ; inline
+
+: read-packed-le ( str -- seq )
+    [ unpack-le ] read-packed ; inline
+
+: read-packed-be ( str -- seq )
+    [ unpack-be ] read-packed ; inline
+
+: read-packed-native ( str -- seq )
+    [ unpack-native ] read-packed ; inline

basis/roman/roman.factor

@@ -39,16 +39,14 @@ ERROR: roman-range-error n ;
 PRIVATE>
 
 : >roman ( n -- str )
-    dup roman-range-check [
+    dup roman-range-check
-        (>roman)
+    [ (>roman) ] "" make ;
-    ] "" make ;
 
 : >ROMAN ( n -- str ) >roman >upper ;
 
 : roman> ( str -- n )
-    >lower [ roman<= ] monotonic-split [
+    >lower [ roman<= ] monotonic-split
-        (roman>)
+    [ (roman>) ] sigma ;
-    ] map sum ;
 
 <PRIVATE