use radix literals

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

diff --git a/extra/asn1/asn1.factor b/extra/asn1/asn1.factor
index 8954ffd8ccd1cf1459963dd7a45b718503aa6532..f43b189eae3298fddb2baead684c880f96edc38d 100644 (file)
--- a/extra/asn1/asn1.factor
+++ b/extra/asn1/asn1.factor
@@ -3,10 +3,28 @@
 
 USING: arrays asn1.ldap assocs byte-arrays combinators
 continuations io io.binary io.streams.string kernel math
-math.parser namespaces pack strings sequences ;
+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" } ;
 
@@ -48,17 +66,13 @@ SYMBOL: elements
 
 TUPLE: element syntax id tag tagclass encoding contentlength newobj objtype ;
 
-: <element> element construct-empty ;
-
-: set-id ( -- boolean )
-    read1 dup elements get set-element-id ;
 
 : get-id ( -- id )
-    elements get element-id ;
+    elements get id>> ;
 
 : (set-tag) ( -- )
-    elements get element-id 31 bitand
-    dup elements get set-element-tag
+    elements get id>> 31 bitand
+    dup elements get tag<<
     31 < [
         [ "unsupported tag encoding: #{" % 
           get-id # "}" %
@@ -67,30 +81,30 @@ TUPLE: element syntax id tag tagclass encoding contentlength newobj objtype ;
 
 : set-tagclass ( -- )
     get-id -6 shift tag-classes nth
-    elements get set-element-tagclass ;
+    elements get tagclass<< ;
 
 : set-encoding ( -- )
-    get-id HEX: 20 bitand
+    get-id 0x20 bitand
     zero? "primitive" "constructed" ?
-    elements get set-element-encoding ;
+    elements get encoding<< ;
 
 : set-content-length ( -- )
     read1
     dup 127 <= [ 
         127 bitand read be>
-    ] unless elements get set-element-contentlength ;
+    ] unless elements get contentlength<< ;
 
 : set-newobj ( -- )
-    elements get element-contentlength read
-    elements get set-element-newobj ;
+    elements get contentlength>> read
+    elements get newobj<< ;
 
 : set-objtype ( syntax -- )
     builtin-syntax 2array [
-        elements get element-tagclass swap at
-        elements get element-encoding swap at
-        elements get element-tag
+        elements get tagclass>> swap at
+        elements get encoding>> swap at
+        elements get tag>>
         swap at [ 
-            elements get set-element-objtype
+            elements get objtype<<
         ] when*
     ] each ;
 
@@ -98,33 +112,37 @@ DEFER: read-ber
 
 SYMBOL: end
 
-: (read-array) ( stream -- )
-    elements get element-id [
-        elements get element-syntax read-ber
+: (read-array) ( -- )
+    elements get id>> [
+        elements get syntax>> read-ber
         dup end = [ drop ] [ , (read-array) ] if
     ] when ;
 
 : read-array ( -- array ) [ (read-array) ] { } make ;
 
-: set-case ( -- )
-    elements get element-newobj
-    elements get element-objtype {
+: set-case ( -- object )
+    elements get newobj>>
+    elements get objtype>> {
         { "boolean" [ "\0" = not ] }
         { "string" [ "" or ] }
         { "integer" [ be> ] }
         { "array" [ "" or [ read-array ] with-string-reader ] }
     } case ;
 
+: set-id ( -- boolean )
+    read1 dup elements get id<< ;
+
 : read-ber ( syntax -- object )
-    <element> elements set
-    elements get set-element-syntax
+    element new
+        swap >>syntax
+    elements set
     set-id [
         (set-tag)
         set-tagclass
         set-encoding
         set-content-length
         set-newobj
-        elements get element-syntax set-objtype
+        elements get syntax>> set-objtype
         set-case
     ] [ end ] if ;
 
@@ -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 ;
 
 ! =========================================================
@@ -172,7 +190,7 @@ SYMBOL: tagnum
 
 TUPLE: tag value ;
 
-: <tag> ( -- <tag> ) 4 tag construct-boa ;
+: <tag> ( -- <tag> ) 4 tag boa ;
 
 : with-ber ( quot -- )
     [
@@ -181,19 +199,18 @@ TUPLE: tag value ;
     ] with-scope ; inline
 
 : set-tag ( value -- )
-    tagnum get set-tag-value ;
+    tagnum get value<< ;
 
 M: string >ber ( str -- byte-array )
-    tagnum get tag-value 1array "C" pack-native swap dup
+    tagnum get value>> 1array "C" pack-native swap dup
     length >ber-length-encoding swapd append swap
     >byte-array append ;
 
 : >ber-application-string ( n str -- byte-array )
-    >r HEX: 40 + set-tag r> >ber ;
+    [ 0x40 + set-tag ] dip >ber ;
 
-GENERIC: >ber-contextspecific ( n obj -- byte-array )
-M: string >ber-contextspecific ( n str -- byte-array )
-    >r HEX: 80 + set-tag r> >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 ;