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

new accessors

db4
Doug Coleman 2008-08-31 02:51:31 -05:00
parent b7fd4bb765
commit 7d1e346cec
1 changed files with 12 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
extra/asn1/asn1.factor
View File

@ -54,7 +54,7 @@ TUPLE: element syntax id tag tagclass encoding contentlength newobj objtype ;
: (set-tag) ( -- )
elements get id>> 31 bitand
dup elements get set-element-tag
dup elements get (>>tag)
31 < [
[ "unsupported tag encoding: #{" %
get-id # "}" %
@ -63,22 +63,22 @@ 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
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 contentlength>> read
elements get set-element-newobj ;
elements get (>>newobj) ;
: set-objtype ( syntax -- )
builtin-syntax 2array [
@ -86,7 +86,7 @@ TUPLE: element syntax id tag tagclass encoding contentlength newobj objtype ;
elements get encoding>> swap at
elements get tag>>
swap at [
elements get set-element-objtype
elements get (>>objtype)
] when*
] each ;
@ -96,15 +96,15 @@ SYMBOL: end
: (read-array) ( -- )
elements get id>> [
elements get element-syntax read-ber
elements get syntax>> read-ber
dup end = [ drop ] [ , (read-array) ] if
] when ;
: read-array ( -- array ) [ (read-array) ] { } make ;
: set-case ( -- object )
elements get element-newobj
elements get element-objtype {
elements get newobj>>
elements get objtype>> {
{ "boolean" [ "\0" = not ] }
{ "string" [ "" or ] }
{ "integer" [ be> ] }
@ -112,7 +112,7 @@ SYMBOL: end
} case ;
: set-id ( -- boolean )
read1 dup elements get set-element-id ;
read1 dup elements get (>>id) ;
: read-ber ( syntax -- object )
element new
@ -124,7 +124,7 @@ SYMBOL: end
set-encoding
set-content-length
set-newobj
elements get element-syntax set-objtype
elements get syntax>> set-objtype
set-case
] [ end ] if ;
@ -181,7 +181,7 @@ 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