JezK
Edit File: yaz-asncomp
#!/usr/bin/tclsh # # yaz-comp: ASN.1 Compiler for YAZ # (c) Index Data 1996-2012 # See the file LICENSE for details. # set yc_version 0.4 # Syntax for the ASN.1 supported: # file -> file module # | module # module -> name skip DEFINITIONS ::= mbody END # mbody -> EXPORTS { nlist } # | IMPORTS { imlist } # | name ::= tmt # | skip # tmt -> tag mod type # type -> SEQUENCE { sqlist } # | SEQUENCE OF type # | CHOICE { chlist } # | basic enlist # # basic -> INTEGER # | BOOLEAN # | OCTET STRING # | BIT STRING # | EXTERNAL # | name # sqlist -> sqlist , name tmt opt # | name tmt opt # chlist -> chlist , name tmt # | name tmt # enlist -> enlist , name (n) # | name (n) # imlist -> nlist FROM name # imlist nlist FROM name # nlist -> name # | nlist , name # mod -> IMPLICIT | EXPLICIT | e # tag -> [tagtype n] | [n] | e # opt -> OPTIONAL | e # # name identifier/token # e epsilon/empty # skip one token skipped # n number # tagtype APPLICATION, CONTEXT, etc. # lex: moves input file pointer and returns type of token. # The globals $type and $val are set. $val holds name if token # is normal identifier name. # sets global var type to one of: # {} eof-of-file # \{ left curly brace # \} right curly brace # , comma # ; semicolon # ( (n) # [ [n] # : ::= # n other token n proc lex {} { global inf val type while {![string length $inf(str)]} { incr inf(lineno) set inf(cnt) [gets $inf(inf) inf(str)] if {$inf(cnt) < 0} { set type {} return {} } lappend inf(asn,$inf(asndef)) $inf(str) set l [string first -- $inf(str)] if {$l >= 0} { incr l -1 set inf(str) [string range $inf(str) 0 $l] } set inf(str) [string trim $inf(str)] } set s [string index $inf(str) 0] set type $s set val {} switch -- $s { \{ { } \} { } , { } ; { } \( { } \) { } \[ { regexp {^\[[ ]*(.+)[ ]*\]} $inf(str) s val } : { regexp {^::=} $inf(str) s } default { regexp "^\[^,\t :\{\}();\]+" $inf(str) s set type n set val $s } } set off [string length $s] set inf(str) [string trim [string range $inf(str) $off end]] return $type } # lex-expect: move pointer and expect token $t proc lex-expect {t} { global type val lex if {[string compare $t $type]} { asnError "Got $type '$val', expected $t" } } # lex-name-move: see if token is $name; moves pointer and returns # 1 if it is; returns 0 otherwise. proc lex-name-move {name} { global type val if {![string compare $type n] && ![string compare $val $name]} { lex return 1 } return 0 } # asnError: Report error and die proc asnError {msg} { global inf puts "Error in line $inf(lineno) in module $inf(module)" puts " $msg" error exit 1 } # asnWarning: Report warning and return proc asnWarning {msg} { global inf puts "Warning in line $inf(lineno) in module $inf(module)" puts " $msg" } # asnEnum: parses enumerated list - { name1 (n), name2 (n), ... } # Uses $name as prefix. If there really is a list, $lx holds the C # preprocessor definitions on return; otherwise lx isn't set. proc asnEnum {name lx} { global type val inf if {[string compare $type \{]} return upvar $lx l while {1} { set pq [asnName $name] set id [lindex $pq 0] set id ${name}_$id lex-expect n lappend l "#define $inf(dprefix)$id $val" lex-expect ")" lex if {[string compare $type ,]} break } if {[string compare $type \}]} { asnError "Missing \} in enum list got $type '$val'" } lex } # asnMod: parses tag and modifier. # $xtag and $ximplicit holds tag and implicit-indication on return. # $xtag is empty if no tag was specified. $ximplicit is 1 on implicit # tagging; 0 otherwise. proc asnMod {xtag ximplicit xtagtype} { global type val inf upvar $xtag tag upvar $ximplicit implicit upvar $xtagtype tagtype set tag {} set tagtype {} if {![string compare $type \[]} { if {[regexp {^([a-zA-Z]+)[ ]+([0-9]+)$} $val x tagtype tag]} { set tagtype ODR_$tagtype } elseif {[regexp {^([0-9]+)$} $val x tag]} { set tagtype ODR_CONTEXT } else { asnError "bad tag specification: $val" } lex } set implicit $inf(implicit-tags) if {![string compare $type n]} { if {![string compare $val EXPLICIT]} { lex set implicit 0 } elseif {![string compare $val IMPLICIT]} { lex set implicit 1 } } } # asnName: moves pointer and expects name. Returns C-validated name. proc asnName {name} { global val inf lex-expect n if {[info exists inf(membermap,$inf(module),$name,$val)]} { set nval $inf(membermap,$inf(module),$name,$val) if {$inf(verbose)} { puts " mapping member $name,$val to $nval" } if {![string match {[A-Z]*} $val]} { lex } } else { set nval $val if {![string match {[A-Z]*} $val]} { lex } } return [join [split $nval -] _] } # asnOptional: parses optional modifier. Returns 1 if OPTIONAL was # specified; 0 otherwise. proc asnOptional {} { global type val if {[lex-name-move OPTIONAL]} { return 1 } elseif {[lex-name-move DEFAULT]} { lex return 0 } return 0 } # asnSizeConstraint: parses the optional SizeConstraint. # Currently not used for anything. proc asnSizeConstraint {} { global type val if {[lex-name-move SIZE]} { asnSubtypeSpec } } # asnSubtypeSpec: parses the SubtypeSpec ... # Currently not used for anything. We now it's balanced however, i.e. # (... ( ... ) .. ) proc asnSubtypeSpec {} { global type val if {[string compare $type "("]} { return } lex set level 1 while {$level > 0} { if {![string compare $type "("]} { incr level } elseif {![string compare $type ")"]} { incr level -1 } lex } } # asnType: parses ASN.1 type. # On entry $name should hold the name we are currently defining. # Returns type indicator: # SequenceOf SEQUENCE OF # Sequence SEQUENCE # SetOf SET OF # Set SET # Choice CHOICE # Simple Basic types. # In this casecalling procedure's $tname variable is a list holding: # {C-Function C-Type} if the type is IMPORTed or ODR defined. # or # {C-Function C-Type 1} if the type should be defined in this module proc asnType {name} { global type val inf upvar tname tname set tname {} if {[string compare $type n]} { asnError "Expects type specifier, but got $type" } set v $val lex switch -- $v { SEQUENCE { asnSizeConstraint if {[lex-name-move OF]} { asnSubtypeSpec return SequenceOf } else { asnSubtypeSpec return Sequence } } SET { asnSizeConstraint if {[lex-name-move OF]} { asnSubtypeSpec return SetOf } else { asnSubtypeSpec return Set } } CHOICE { asnSubtypeSpec return Choice } } if {[string length [info commands asnBasic$v]]} { set tname [asnBasic$v] } else { if {[info exists inf(map,$inf(module),$v)]} { set v $inf(map,$inf(module),$v) } if {[info exists inf(imports,$v)]} { set tname $inf(imports,$v) } else { set w [join [split $v -] _] set tname [list $inf(fprefix)$w $inf(vprefix)$w 1] } } if {[lex-name-move DEFINED]} { if {[lex-name-move BY]} { lex } } asnSubtypeSpec return Simple } proc mapName {name} { global inf if {[info exists inf(map,$inf(module),$name)]} { set name $inf(map,$inf(module),$name) if {$inf(verbose)} { puts -nonewline " $name ($inf(lineno))" puts " mapping to $name" } } else { if {$inf(verbose)} { puts " $name ($inf(lineno))" } } return $name } # asnDef: parses type definition (top-level) and generates C code # On entry $name holds the type we are defining. proc asnDef {name} { global inf file set name [mapName $name] if {[info exist inf(defined,$inf(fprefix)$name)]} { incr inf(definedl,$name) if {$inf(verbose) > 1} { puts "set map($inf(module),$name) $name$inf(definedl,$name)" } } else { set inf(definedl,$name) 0 } set mname [join [split $name -] _] asnMod tag implicit tagtype set t [asnType $mname] asnSub $mname $t $tname $tag $implicit $tagtype } # asnSub: parses type and generates C-code # On entry, # $name holds the type we are defining. # $t is the type returned by the asnType procedure. # $tname is the $tname set by the asnType procedure. # $tag is the tag as returned by asnMod # $implicit is the implicit indicator as returned by asnMod proc asnSub {name t tname tag implicit tagtype} { global file inf set ignore 0 set defname defined,$inf(fprefix)$name if {[info exist inf($defname)]} { asnWarning "$name already defined in line $inf($defname)" set ignore 1 } set inf($defname) $inf(lineno) switch -- $t { Sequence { set l [asnSequence $name $tag $implicit $tagtype] } SequenceOf { set l [asnOf $name $tag $implicit $tagtype 0] } SetOf { set l [asnOf $name $tag $implicit $tagtype 1] } Choice { set l [asnChoice $name $tag $implicit $tagtype] } Simple { set l [asnSimple $name $tname $tag $implicit $tagtype] } default { asnError "switch asnType case not handled" } } if {$ignore} return puts $file(outc) {} puts $file(outc) "int $inf(fprefix)${name}(ODR o, $inf(vprefix)$name **p, int opt, const char *name)" puts $file(outc) \{ puts $file(outc) [lindex $l 0] puts $file(outc) \} set ok 1 set fdef "$inf(cprefix)int $inf(fprefix)${name}(ODR o, $inf(vprefix)$name **p, int opt, const char *name);" switch -- $t { Simple { set decl "typedef [lindex $l 1] $inf(vprefix)$name;" if {![string compare [lindex $tname 2] 1]} { if {![info exist inf(defined,[lindex $tname 0])]} { set ok 0 } } set inf(var,$inf(nodef)) [join [lindex $l 2] \n] incr inf(nodef) } default { set decl "typedef struct $inf(vprefix)$name $inf(vprefix)$name;" set inf(var,$inf(nodef)) "[lindex $l 1];" incr inf(nodef) } } if {$ok} { puts $file(outh) {} puts $file(outh) $decl puts $file(outh) $fdef asnForwardTypes $name } else { lappend inf(forward,code,[lindex $tname 0]) {} $decl $fdef lappend inf(forward,ref,[lindex $tname 0]) $name } } proc asnForwardTypes {name} { global inf file if {![info exists inf(forward,code,$inf(fprefix)$name)]} { return 0 } foreach r $inf(forward,code,$inf(fprefix)$name) { puts $file(outh) $r } unset inf(forward,code,$inf(fprefix)$name) while {[info exists inf(forward,ref,$inf(fprefix)$name)]} { set n $inf(forward,ref,$inf(fprefix)$name) set m [lrange $n 1 end] if {[llength $m]} { set inf(forward,ref,$inf(fprefix)$name) $m } else { unset inf(forward,ref,$inf(fprefix)$name) } asnForwardTypes [lindex $n 0] } } # asnSimple: parses simple type definition and generates C code # On entry, # $name is the name we are defining # $tname is the tname as returned by asnType # $tag is the tag as returned by asnMod # $implicit is the implicit indicator as returned by asnMod # Returns, # {c-code, h-code} # Note: Doesn't take care of enum lists yet. proc asnSimple {name tname tag implicit tagtype} { global inf set j "[lindex $tname 1] " if {[info exists inf(unionmap,$inf(module),$name)]} { set uName $inf(unionmap,$inf(module),$name) } else { set uName $name } asnEnum $uName jj if {![string length $tag]} { set l "\treturn [lindex $tname 0] (o, p, opt, name);" } elseif {$implicit} { set l \ "\treturn odr_implicit_tag(o, [lindex $tname 0], p, $tagtype, $tag, opt, name);" } else { set l \ "\treturn odr_explicit_tag(o, [lindex $tname 0], p, $tagtype, $tag, opt, name);" \ } if {[info exists jj]} { return [list $l $j $jj] } else { return [list $l $j] } } # asnSequence: parses "SEQUENCE { s-list }" and generates C code. # On entry, # $name is the type we are defining # $tag tag # $implicit # Returns, # {c-code, h-code} proc asnSequence {name tag implicit tagtype} { global val type inf lappend j "struct $inf(vprefix)$name \{" set level 0 set nchoice 0 if {![string length $tag]} { lappend l "\tif (!odr_sequence_begin(o, p, sizeof(**p), name))" lappend l "\t\treturn odr_missing(o, opt, name) && odr_ok (o);" } elseif {$implicit} { lappend l "\tif (!odr_implicit_settag(o, $tagtype, $tag) ||" lappend l "\t\t!odr_sequence_begin (o, p, sizeof(**p), name))" lappend l "\t\treturn odr_missing(o, opt, name);" } else { lappend l "\tif (!odr_constructed_begin(o, p, $tagtype, $tag, name))" lappend l "\t\treturn odr_missing(o, opt, name);" lappend l "\tif (o->direction == ODR_DECODE)" lappend l "\t\t*p = ($inf(vprefix)$name *) odr_malloc(o, sizeof(**p));" lappend l "\tif (!odr_sequence_begin(o, p, sizeof(**p), 0))" lappend l "\t\{" lappend l "\t\tif (o->direction == ODR_DECODE)" lappend l "\t\t\t*p = 0;" lappend l "\t\treturn 0;" lappend l "\t\}" } lappend l "\treturn" while {1} { set p [lindex [asnName $name] 0] asnMod ltag limplicit ltagtype set t [asnType $p] set uName { } if {[info exists inf(unionmap,$inf(module),$name,$p)]} { set uName $inf(unionmap,$inf(module),$name,$p) } if {![string compare $t Simple]} { if {[string compare $uName { }]} { set enumName $uName } else { set enumName $name } asnEnum $enumName j set opt [asnOptional] if {![string length $ltag]} { lappend l "\t\t[lindex $tname 0](o, &(*p)->$p, $opt, \"$p\") &&" } elseif {$limplicit} { lappend l "\t\todr_implicit_tag(o, [lindex $tname 0]," lappend l "\t\t\t&(*p)->$p, $ltagtype, $ltag, $opt, \"$p\") &&" } else { lappend l "\t\todr_explicit_tag(o, [lindex $tname 0]," lappend l "\t\t\t&(*p)->$p, $ltagtype, $ltag, $opt, \"$p\") &&" } set dec "\t[lindex $tname 1] *$p;" } elseif {![string compare $t SequenceOf] && [string length $uName] &&\ (![string length $ltag] || $limplicit)} { set u [asnType $p] if {[llength $uName] < 2} { set uName [list num_$p $p] } if {[string length $ltag]} { if {!$limplicit} { asnError explicittag } lappend l "\t\todr_implicit_settag(o, $ltagtype, $ltag) &&" } switch -- $u { Simple { asnEnum $name j set tmpa "odr_sequence_of(o, (Odr_fun) [lindex $tname 0], &(*p)->$p," set tmpb "&(*p)->[lindex $uName 0], \"$p\")" lappend j "\tint [lindex $uName 0];" set dec "\t[lindex $tname 1] **[lindex $uName 1];" } default { set subName [mapName ${name}_$level] asnSub $subName $u {} {} 0 {} set tmpa "odr_sequence_of(o, (Odr_fun) $inf(fprefix)$subName, &(*p)->$p," set tmpb "&(*p)->[lindex $uName 0], \"$p\")" lappend j "\tint [lindex $uName 0];" set dec "\t$inf(vprefix)$subName **[lindex $uName 1];" incr level } } set opt [asnOptional] if {$opt} { lappend l "\t\t($tmpa" lappend l "\t\t $tmpb || odr_ok(o)) &&" } else { lappend l "\t\t$tmpa" lappend l "\t\t $tmpb &&" } } elseif {!$nchoice && ![string compare $t Choice] && \ [string length $uName]} { if {[llength $uName] < 3} { set uName [list which u $name] incr nchoice } lappend j "\tint [lindex $uName 0];" lappend j "\tunion \{" lappend v "\tstatic Odr_arm arm\[\] = \{" asnArm $name [lindex $uName 2] v j lappend v "\t\};" set dec "\t\} [lindex $uName 1];" set opt [asnOptional] set oa {} set ob {} if {[string length $ltag]} { if {$limplicit} { lappend l "\t\todr_implicit_settag(o, $ltagtype, $ltag) &&" if {$opt} { asnWarning "optional handling missing in CHOICE in SEQUENCE" asnWarning " set unionmap($inf(module),$name,$p) to {}" } } else { if {$opt} { set la "((" } else { set la "" } lappend l "\t\t${la}odr_constructed_begin(o, &(*p)->[lindex $uName 1], $ltagtype, $ltag, \"$p\") &&" } } else { if {$opt} { set oa "(" set ob " || odr_ok(o))" } } lappend l "\t\t${oa}odr_choice(o, arm, &(*p)->[lindex $uName 1], &(*p)->[lindex $uName 0], 0)${ob} &&" if {[string length $ltag]} { if {!$limplicit} { if {$opt} { set lb ") || odr_ok(o))" } else { set lb "" } lappend l "\t\todr_constructed_end(o)${lb} &&" } } } else { set subName [mapName ${name}_$level] asnSub $subName $t {} {} 0 {} set opt [asnOptional] if {![string length $ltag]} { lappend l "\t\t$inf(fprefix)${subName}(o, &(*p)->$p, $opt, \"$p\") &&" } elseif {$limplicit} { lappend l "\t\todr_implicit_tag(o, $inf(fprefix)${subName}," lappend l "\t\t\t&(*p)->$p, $ltagtype, $ltag, $opt, \"$p\") &&" } else { lappend l "\t\todr_explicit_tag(o, $inf(fprefix)${subName}," lappend l "\t\t\t&(*p)->$p, $ltagtype, $ltag, $opt, \"$p\") &&" } set dec "\t$inf(vprefix)${subName} *$p;" incr level } if {$opt} { lappend j "$dec /* OPT */" } else { lappend j $dec } if {[string compare $type ,]} break } lappend j "\}" if {[string length $tag] && !$implicit} { lappend l "\t\todr_sequence_end(o) &&" lappend l "\t\todr_constructed_end(o);" } else { lappend l "\t\todr_sequence_end(o);" } if {[string compare $type \}]} { asnError "Missing \} got $type '$val'" } lex if {[info exists v]} { set l [concat $v $l] } return [list [join $l \n] [join $j \n]] } # asnOf: parses "SEQUENCE/SET OF type" and generates C code. # On entry, # $name is the type we are defining # $tag tag # $implicit # Returns, # {c-code, h-code} proc asnOf {name tag implicit tagtype isset} { global inf if {$isset} { set func odr_set_of } else { set func odr_sequence_of } if {[info exists inf(unionmap,$inf(module),$name)]} { set numName $inf(unionmap,$inf(module),$name) } else { set numName {num elements} } lappend j "struct $inf(vprefix)$name \{" lappend j "\tint [lindex $numName 0];" lappend l "\tif (!odr_initmember(o, p, sizeof(**p)))" lappend l "\t\treturn odr_missing(o, opt, name);" if {[string length $tag]} { if {$implicit} { lappend l "\todr_implicit_settag(o, $tagtype, $tag);" } else { asnWarning "Constructed SEQUENCE/SET OF not handled" } } set t [asnType $name] switch -- $t { Simple { asnEnum $name j lappend l "\tif (${func}(o, (Odr_fun) [lindex $tname 0], &(*p)->[lindex $numName 1]," lappend l "\t\t&(*p)->[lindex $numName 0], name))" lappend j "\t[lindex $tname 1] **[lindex $numName 1];" } default { set subName [mapName ${name}_s] lappend l "\tif (${func}(o, (Odr_fun) $inf(fprefix)$subName, &(*p)->[lindex $numName 1]," lappend l "\t\t&(*p)->[lindex $numName 0], name))" lappend j "\t$inf(vprefix)$subName **[lindex $numName 1];" asnSub $subName $t {} {} 0 {} } } lappend j "\}" lappend l "\t\treturn 1;" lappend l "\tif (o->direction == ODR_DECODE)" lappend l "\t\t*p = 0;" lappend l "\treturn odr_missing(o, opt, name);" return [list [join $l \n] [join $j \n]] } # asnArm: parses c-list in choice proc asnArm {name defname lx jx} { global type val inf upvar $lx l upvar $jx j while {1} { set pq [asnName $name] set p [lindex $pq 0] set q [lindex $pq 1] if {![string length $q]} { set q $p set p ${defname}_$p } asnMod ltag limplicit ltagtype set t [asnType $q] lappend enums "$inf(dprefix)$p" if {![string compare $t Simple]} { asnEnum $name j if {![string length $ltag]} { lappend l "\t\t\{-1, -1, -1, $inf(dprefix)$p," lappend l "\t\t (Odr_fun) [lindex $tname 0], \"$q\"\}," } elseif {$limplicit} { lappend l "\t\t\{ODR_IMPLICIT, $ltagtype, $ltag, $inf(dprefix)$p," lappend l "\t\t(Odr_fun) [lindex $tname 0], \"$q\"\}," } else { lappend l "\t\t\{ODR_EXPLICIT, $ltagtype, $ltag, $inf(dprefix)$p," lappend l "\t\t(Odr_fun) [lindex $tname 0], \"$q\"\}," } lappend j "\t\t[lindex $tname 1] *$q;" } else { set subName [mapName ${name}_$q] if {![string compare $inf(dprefix)${name}_$q \ $inf(vprefix)$subName]} { set po [string toupper [string index $q 0]][string \ range $q 1 end] set subName [mapName ${name}${po}] } asnSub $subName $t $tname {} 0 {} if {![string length $ltag]} { lappend l "\t\t\{-1, -1, -1, $inf(dprefix)$p," lappend l "\t\t (Odr_fun) $inf(fprefix)$subName, \"$q\"\}," } elseif {$limplicit} { lappend l "\t\t\{ODR_IMPLICIT, $ltagtype, $ltag, $inf(dprefix)$p," lappend l "\t\t(Odr_fun) $inf(fprefix)$subName, \"$q\"\}," } else { lappend l "\t\t\{ODR_EXPLICIT, $ltagtype, $ltag, $inf(dprefix)$p," lappend l "\t\t(Odr_fun) $inf(fprefix)$subName, \"$q\"\}," } lappend j "\t\t$inf(vprefix)$subName *$q;" } if {[string compare $type ,]} break } if {[string compare $type \}]} { asnError "Missing \} got $type '$val'" } lex set level 1 foreach e $enums { lappend j "#define $e $level" incr level } lappend l "\t\t\{-1, -1, -1, -1, (Odr_fun) 0, 0\}" } # asnChoice: parses "CHOICE {c-list}" and generates C code. # On entry, # $name is the type we are defining # $tag tag # $implicit # Returns, # {c-code, h-code} proc asnChoice {name tag implicit tagtype} { global type val inf if {[info exists inf(unionmap,$inf(module),$name)]} { set uName $inf(unionmap,$inf(module),$name) } else { set uName [list which u $name] } lappend j "struct $inf(vprefix)$name \{" lappend j "\tint [lindex $uName 0];" lappend j "\tunion \{" lappend l "\tstatic Odr_arm arm\[\] = \{" asnArm $name [lindex $uName 2] l j lappend j "\t\} [lindex $uName 1];" lappend j "\}" lappend l "\t\};" if {![string length $tag]} { lappend l "\tif (!odr_initmember(o, p, sizeof(**p)))" lappend l "\t\treturn odr_missing(o, opt, name);" lappend l "\tif (odr_choice(o, arm, &(*p)->[lindex $uName 1], &(*p)->[lindex $uName 0], name))" } elseif {$implicit} { lappend l "\tif (!odr_initmember(o, p, sizeof(**p)))" lappend l "\t\treturn odr_missing(o, opt, name);" lappend l "\todr_implicit_settag(o, $tagtype, $tag);" lappend l "\tif (odr_choice(o, arm, &(*p)->[lindex $uName 1], &(*p)->[lindex $uName 0], name))" } else { lappend l "\tif (!odr_constructed_begin(o, p, $tagtype, $tag, 0))" lappend l "\t\treturn odr_missing(o, opt, name);" lappend l "\tif (!odr_initmember(o, p, sizeof(**p)))" lappend l "\t\treturn odr_missing(o, opt, name);" lappend l "\tif (odr_choice(o, arm, &(*p)->[lindex $uName 1], &(*p)->[lindex $uName 0], name) &&" lappend l "\t\todr_constructed_end(o))" } lappend l "\t\treturn 1;" lappend l "\tif (o->direction == ODR_DECODE)" lappend l "\t\t*p = 0;" lappend l "\treturn odr_missing(o, opt, name);" return [list [join $l \n] [join $j \n]] } # asnImports: parses i-list in "IMPORTS {i-list}" # On return inf(import,..)-array is updated. # inf(import,"module") is a list of {C-handler, C-type} elements. # The {C-handler, C-type} is compatible with the $tname as is used by the # asnType procedure to solve external references. proc asnImports {} { global type val inf file while {1} { if {[string compare $type n]} { asnError "Missing name in IMPORTS list" } lappend nam $val lex if {![string compare $type n] && ![string compare $val FROM]} { lex if {[info exists inf(filename,$val)]} { set fname $inf(filename,$val) } else { set fname $val } puts $file(outh) "\#include <$inf(h-dir)${fname}.h>" if {[info exists inf(prefix,$val)]} { set prefix $inf(prefix,$val) } else { set prefix $inf(prefix) } foreach n $nam { if {[info exists inf(map,$val,$n)]} { set v $inf(map,$val,$n) } else { set v $n } set w [join [split $v -] _] set inf(imports,$n) [list [lindex $prefix 0]$w \ [lindex $prefix 1]$w] } unset nam lex if {[string compare $type n]} break } elseif {![string compare $type ,]} { lex } else break } if {[string compare $type \;]} { asnError "Missing ; after IMPORTS list - got $type '$val'" } lex } # asnExports: parses e-list in "EXPORTS {e-list}" # This function does nothing with elements in the list. proc asnExports {} { global type val inf while {1} { if {[string compare $type n]} { asnError "Missing name in EXPORTS list" } set inf(exports,$val) 1 lex if {[string compare $type ,]} break lex } if {[string compare $type \;]} { asnError "Missing ; after EXPORTS list - got $type ($val)" } lex } # asnModuleBody: parses a module specification and generates C code. # Exports lists, imports lists, and type definitions are handled; # other things are silently ignored. proc asnModuleBody {} { global type val file inf if {[info exists inf(prefix,$inf(module))]} { set prefix $inf(prefix,$inf(module)) } else { set prefix $inf(prefix) } set inf(fprefix) [lindex $prefix 0] set inf(vprefix) [lindex $prefix 1] set inf(dprefix) [lindex $prefix 2] if {[llength $prefix] > 3} { set inf(cprefix) [lindex $prefix 3] } else { set inf(cprefix) {YAZ_EXPORT } } if {$inf(verbose)} { puts "Module $inf(module), $inf(lineno)" } set defblock 0 if {[info exists inf(init,$inf(module),c)]} { puts $file(outc) $inf(init,$inf(module),c) } if {[info exists inf(init,$inf(module),h)]} { puts $file(outh) "\#ifdef __cplusplus" puts $file(outh) "extern \"C\" \{" puts $file(outh) "\#endif" set defblock 1 puts $file(outh) $inf(init,$inf(module),h) } if {[info exists inf(init,$inf(module),p)]} { puts $file(outp) $inf(init,$inf(module),p) } while {[string length $type]} { if {[string compare $type n]} { lex continue } if {![string compare $val END]} { break } elseif {![string compare $val EXPORTS]} { lex asnExports } elseif {![string compare $val IMPORTS]} { if {$defblock} { puts $file(outh) "\#ifdef __cplusplus" puts $file(outh) "\}" puts $file(outh) "\#endif" set defblock 0 } lex asnImports } else { if {!$defblock} { puts $file(outh) "\#ifdef __cplusplus" puts $file(outh) "extern \"C\" \{" puts $file(outh) "\#endif" set defblock 1 } set inf(asndef) $inf(nodef) set oval $val lex if {![string compare $type :]} { lex asnDef $oval set inf(asndef) 0 } elseif {![string compare $type n]} { lex if {[string length $type]} { lex } } } } if {$defblock} { puts $file(outh) "\#ifdef __cplusplus" puts $file(outh) "\}" puts $file(outh) "\#endif" set defblock 0 } foreach x [array names inf imports,*] { unset inf($x) } } # asnTagDefault: parses TagDefault section proc asnTagDefault {} { global type val inf file set inf(implicit-tags) 0 while {[string length $type]} { if {[lex-name-move EXPLICIT]} { lex set inf(implicit-tags) 0 } elseif {[lex-name-move IMPLICIT]} { lex set inf(implicit-tags) 1 } else { break } } } # asnModules: parses a collection of module specifications. # Depending on the module pattern, $inf(moduleP), a module is either # skipped or processed. proc asnModules {} { global type val inf file yc_version set inf(nodef) 0 set inf(asndef) 0 lex while {![string compare $type n]} { set inf(module) $val if {[info exists inf(moduleP)] && ![string match $inf(moduleP) $val]} { if {$inf(verbose)} { puts "Skipping $id" } while {![lex-name-move END]} { lex } } else { set inf(nodef) 1 set inf(asndef) 1 while {![lex-name-move DEFINITIONS]} { lex if {![string length $type]} return } if {[info exists inf(filename,$inf(module))]} { set fname $inf(filename,$inf(module)) } else { set fname $inf(module) } set ppname [join [split $fname -] _] if {![info exists inf(c-file)]} { set inf(c-file) ${fname}.c } set file(outc) [open $inf(c-file) w] if {![info exists inf(h-file)]} { set inf(h-file) ${fname}.h } set file(outh) [open $inf(h-path)/$inf(h-dir)$inf(h-file) w] if {0} { if {![info exists inf(p-file)]} { set inf(p-file) ${fname}-p.h } set file(outp) [open $inf(h-path)/$inf(h-dir)$inf(p-file) w] } set greeting {Generated automatically by YAZ ASN.1 Compiler} puts $file(outc) "/** \\file $inf(c-file)" puts $file(outc) " \\brief ASN.1 Module $inf(module)" puts $file(outc) "" puts $file(outc) " ${greeting} ${yc_version}" puts $file(outc) "*/" puts $file(outc) "\#if HAVE_CONFIG_H" puts $file(outc) "\#include <config.h>" puts $file(outc) "\#endif" puts $file(outc) {} puts $file(outh) "/** \\file $inf(h-file)" puts $file(outh) " \\brief ASN.1 Module $inf(module)" puts $file(outh) "" puts $file(outh) " ${greeting} ${yc_version}" puts $file(outh) "*/" puts $file(outh) {} if {[info exists file(outp)]} { puts $file(outp) "/** \\file $inf(p-file)" puts $file(outp) " \\brief ASN.1 Module $inf(module)" puts $file(outp) "" puts $file(outp) " ${greeting} ${yc_version}" puts $file(outp) "*/" puts $file(outp) {} } if {[info exists inf(p-file)]} { puts $file(outc) "\#include <$inf(h-dir)$inf(p-file)>" } else { puts $file(outc) "\#include <$inf(h-dir)$inf(h-file)>" } puts $file(outh) "\#ifndef ${ppname}_H" puts $file(outh) "\#define ${ppname}_H" puts $file(outh) {} puts $file(outh) "\#include <yaz/odr.h>" if {[info exists file(outp)]} { puts $file(outp) "\#ifndef ${ppname}_P_H" puts $file(outp) "\#define ${ppname}_P_H" puts $file(outp) {} puts $file(outp) "\#include <$inf(h-dir)$inf(h-file)>" } asnTagDefault if {[string compare $type :]} { asnError "::= expected got $type '$val'" } lex if {![lex-name-move BEGIN]} { asnError "BEGIN expected" } asnModuleBody lex if {[info exists file(outp)]} { set f $file(outp) } else { set f $file(outh) } puts $f "\#ifdef __cplusplus" puts $f "extern \"C\" \{" puts $f "\#endif" for {set i 1} {$i < $inf(nodef)} {incr i} { puts $f $inf(var,$i) if {[info exists inf(asn,$i)]} { if {0} { puts $f "/*" foreach comment $inf(asn,$i) { puts $f $comment } puts $f " */" } unset inf(asn,$i) } unset inf(var,$i) puts $f {} } puts $f "\#ifdef __cplusplus" puts $f "\}" puts $f "\#endif" if {[info exists inf(body,$inf(module),h)]} { puts $file(outh) $inf(body,$inf(module),h) } if {[info exists inf(body,$inf(module),c)]} { puts $file(outc) $inf(body,$inf(module),c) } if {[info exists inf(body,$inf(module),p)]} { if {[info exists file(outp)]} { puts $file(outp) $inf(body,$inf(module),p) } } puts $file(outh) "\#endif" if {[info exists file(outp)]} { puts $file(outp) "\#endif" } foreach f [array names file] { close $file($f) } unset inf(c-file) unset inf(h-file) catch {unset inf(p-file)} } } } # asnFile: parses an ASN.1 specification file as specified in $inf(iname). proc asnFile {} { global inf file if {$inf(verbose) > 1} { puts "Reading ASN.1 file $inf(iname)" } set inf(str) {} set inf(lineno) 0 set inf(inf) [open $inf(iname) r] asnModules } # The following procedures are invoked by the asnType function. # Each procedure takes the form: asnBasic<TYPE> and they must return # two elements: the C function handler and the C type. # On entry upvar $name is the type we are defining and global, $inf(module), is # the current module name. proc asnBasicEXTERNAL {} { return {odr_external {Odr_external}} } proc asnBasicINTEGER {} { return {odr_integer {Odr_int}} } proc asnBasicENUMERATED {} { return {odr_enum {Odr_int}} } proc asnBasicNULL {} { return {odr_null {Odr_null}} } proc asnBasicBOOLEAN {} { return {odr_bool {Odr_bool}} } proc asnBasicOCTET {} { global type val lex-name-move STRING return {odr_octetstring {Odr_oct}} } proc asnBasicBIT {} { global type val lex-name-move STRING return {odr_bitstring {Odr_bitmask}} } proc asnBasicOBJECT {} { global type val lex-name-move IDENTIFIER return {odr_oid {Odr_oid}} } proc asnBasicGeneralString {} { return {odr_generalstring char} } proc asnBasicVisibleString {} { return {odr_visiblestring char} } proc asnBasicGeneralizedTime {} { return {odr_generalizedtime char} } proc asnBasicANY {} { upvar name name global inf return [list $inf(fprefix)ANY_$name void] } # userDef: reads user definitions file $name proc userDef {name} { global inf if {$inf(verbose) > 1} { puts "Reading definitions file $name" } source $name if {[info exists default-prefix]} { set inf(prefix) ${default-prefix} } if {[info exists h-path]} { set inf(h-path) ${h-path} } foreach m [array names prefix] { set inf(prefix,$m) $prefix($m) } foreach m [array names body] { set inf(body,$m) $body($m) } foreach m [array names init] { set inf(init,$m) $init($m) } foreach m [array names filename] { set inf(filename,$m) $filename($m) } foreach m [array names map] { set inf(map,$m) $map($m) } foreach m [array names membermap] { set inf(membermap,$m) $membermap($m) } foreach m [array names unionmap] { set inf(unionmap,$m) $unionmap($m) } } set inf(verbose) 0 set inf(prefix) {yc_ Yc_ YC_} set inf(h-path) . set inf(h-dir) "" # Parse command line set l [llength $argv] set i 0 while {$i < $l} { set arg [lindex $argv $i] switch -glob -- $arg { -v { incr inf(verbose) } -c { set p [string range $arg 2 end] if {![string length $p]} { set p [lindex $argv [incr i]] } set inf(c-file) $p } -I* { set p [string range $arg 2 end] if {![string length $p]} { set p [lindex $argv [incr i]] } set inf(h-path) $p } -i* { set p [string range $arg 2 end] if {![string length $p]} { set p [lindex $argv [incr i]] } set inf(h-dir) [string trim $p \\/]/ } -h* { set p [string range $arg 2 end] if {![string length $p]} { set p [lindex $argv [incr i]] } set inf(h-file) $p } -p* { set p [string range $arg 2 end] if {![string length $p]} { set p [lindex $argv [incr i]] } set inf(p-file) $p } -d* { set p [string range $arg 2 end] if {![string length $p]} { set p [lindex $argv [incr i]] } userDef $p } -m* { set p [string range $arg 2 end] if {![string length $p]} { set p [lindex $argv [incr i]] } set inf(moduleP) $p } -x* { set p [string range $arg 2 end] if {![string length $p]} { set p [lindex $argv [incr i]] } if {[llength $p] == 1} { set inf(prefix) [list [string tolower $p] \ [string toupper $p] [string toupper $p]] } elseif {[llength $p] == 3} { set inf(prefix) $p } else { puts [llength $p] exit 1 } } default { set inf(iname) $arg } } incr i } if {![info exists inf(iname)]} { puts "YAZ ASN.1 Compiler ${yc_version}" puts "Usage:" puts -nonewline ${argv0} puts { [-v] [-c cfile] [-h hfile] [-p hfile] [-d dfile] [-I iout]} puts { [-i idir] [-m module] file} exit 1 } asnFile