use radix literals

[factor.git] / extra / asn1 / asn1.factor

diff --git a/extra/asn1/asn1.factor b/extra/asn1/asn1.factor
index b087d3ae2baf47636c91feeb0af739f31ba59bb5..f43b189eae3298fddb2baead684c880f96edc38d 100644 (file)
--- a/extra/asn1/asn1.factor
+++ b/extra/asn1/asn1.factor
@@ -7,6 +7,24 @@ math.parser namespaces make pack strings sequences accessors ;
 
 IN: asn1
 
+<PRIVATE
+
+: (>128-ber) ( n -- )
+    dup 0 > [
+        [ 0x7f bitand 0x80 bitor , ] keep -7 shift
+        (>128-ber)
+    ] [
+        drop
+    ] if ;
+
+PRIVATE>
+
+: >128-ber ( n -- str )
+    [
+        [ 0x7f bitand , ] keep -7 shift
+        (>128-ber)
+    ] { } make reverse ;
+
 : tag-classes ( -- seq )
     { "universal" "application" "context_specific" "private" } ;
 
@@ -54,7 +72,7 @@ TUPLE: element syntax id tag tagclass encoding contentlength newobj objtype ;
 
 : (set-tag) ( -- )
     elements get id>> 31 bitand
-    dup elements get (>>tag)
+    dup elements get tag<<
     31 < [
         [ "unsupported tag encoding: #{" % 
           get-id # "}" %
@@ -63,22 +81,22 @@ TUPLE: element syntax id tag tagclass encoding contentlength newobj objtype ;
 
 : set-tagclass ( -- )
     get-id -6 shift tag-classes nth
-    elements get (>>tagclass) ;
+    elements get tagclass<< ;
 
 : set-encoding ( -- )
-    get-id HEX: 20 bitand
+    get-id 0x20 bitand
     zero? "primitive" "constructed" ?
-    elements get (>>encoding) ;
+    elements get encoding<< ;
 
 : set-content-length ( -- )
     read1
     dup 127 <= [ 
         127 bitand read be>
-    ] unless elements get (>>contentlength) ;
+    ] unless elements get contentlength<< ;
 
 : set-newobj ( -- )
     elements get contentlength>> read
-    elements get (>>newobj) ;
+    elements get newobj<< ;
 
 : set-objtype ( syntax -- )
     builtin-syntax 2array [
@@ -86,7 +104,7 @@ TUPLE: element syntax id tag tagclass encoding contentlength newobj objtype ;
         elements get encoding>> swap at
         elements get tag>>
         swap at [ 
-            elements get (>>objtype)
+            elements get objtype<<
         ] when*
     ] each ;
 
@@ -112,7 +130,7 @@ SYMBOL: end
     } case ;
 
 : set-id ( -- boolean )
-    read1 dup elements get (>>id) ;
+    read1 dup elements get id<< ;
 
 : read-ber ( syntax -- object )
     element new
@@ -146,7 +164,7 @@ M: fixnum >ber ( n -- byte-array )
         1array "C" pack-be
     ] [
         1array "I" pack-be 0 swap remove dup length
-        HEX: 80 + 1array "C" pack-be prepend
+        0x80 + 1array "C" pack-be prepend
     ] if ;
 
 ! =========================================================
@@ -181,7 +199,7 @@ TUPLE: tag value ;
     ] with-scope ; inline
 
 : set-tag ( value -- )
-    tagnum get (>>value) ;
+    tagnum get value<< ;
 
 M: string >ber ( str -- byte-array )
     tagnum get value>> 1array "C" pack-native swap dup
@@ -189,11 +207,10 @@ M: string >ber ( str -- byte-array )
     >byte-array append ;
 
 : >ber-application-string ( n str -- byte-array )
-    [ HEX: 40 + set-tag ] dip >ber ;
+    [ 0x40 + set-tag ] dip >ber ;
 
-GENERIC: >ber-contextspecific ( n obj -- byte-array )
-M: string >ber-contextspecific ( n str -- byte-array )
-    [ HEX: 80 + set-tag ] dip >ber ;
+: >ber-contextspecific-string ( n str -- byte-array )
+    [ 0x80 + set-tag ] dip >ber ;
 
 ! =========================================================
 ! Array
@@ -204,16 +221,16 @@ M: string >ber-contextspecific ( n str -- byte-array )
     swapd append swap [ number>string ] map "" join >array append ;
 
 M: array >ber ( array -- byte-array )
-    HEX: 30 >ber-seq-internal ;
+    0x30 >ber-seq-internal ;
 
 : >ber-set ( array -- byte-array )
-    HEX: 31 >ber-seq-internal ;
+    0x31 >ber-seq-internal ;
 
 : >ber-sequence ( array -- byte-array )
-    HEX: 30 >ber-seq-internal ;
+    0x30 >ber-seq-internal ;
 
 : >ber-appsequence ( array -- byte-array )
-    HEX: 60 >ber-seq-internal ;
+    0x60 >ber-seq-internal ;
 
-M: array >ber-contextspecific ( array -- byte-array )
-    HEX: A0 >ber-seq-internal ;
+: >ber-contextspecific-array ( array -- byte-array )
+    0xA0 >ber-seq-internal ;