3 # yaz-comp: ASN.1 Compiler for YAZ
4 # (c) Index Data 1996-2007
5 # See the file LICENSE for details.
7 # $Id: yaz-asncomp,v 1.9 2008-01-06 13:02:48 adam Exp $
12 # Syntax for the ASN.1 supported:
15 # module -> name skip DEFINITIONS ::= mbody END
16 # mbody -> EXPORTS { nlist }
17 # | IMPORTS { imlist }
21 # type -> SEQUENCE { sqlist }
32 # sqlist -> sqlist , name tmt opt
34 # chlist -> chlist , name tmt
36 # enlist -> enlist , name (n)
38 # imlist -> nlist FROM name
39 # imlist nlist FROM name
42 # mod -> IMPLICIT | EXPLICIT | e
43 # tag -> [tagtype n] | [n] | e
46 # name identifier/token
48 # skip one token skipped
50 # tagtype APPLICATION, CONTEXT, etc.
52 # lex: moves input file pointer and returns type of token.
53 # The globals $type and $val are set. $val holds name if token
54 # is normal identifier name.
55 # sets global var type to one of:
58 # \} right curly brace
67 while {![string length $inf(str)]} {
69 set inf(cnt) [gets $inf(inf) inf(str)]
74 lappend inf(asn,$inf(asndef)) $inf(str)
75 set l [string first -- $inf(str)]
78 set inf(str) [string range $inf(str) 0 $l]
80 set inf(str) [string trim $inf(str)]
82 set s [string index $inf(str) 0]
92 \[ { regexp {^\[[ ]*(.+)[ ]*\]} $inf(str) s val }
93 : { regexp {^::=} $inf(str) s }
95 regexp "^\[^,\t :\{\}();\]+" $inf(str) s
100 set off [string length $s]
101 set inf(str) [string trim [string range $inf(str) $off end]]
105 # lex-expect: move pointer and expect token $t
106 proc lex-expect {t} {
109 if {[string compare $t $type]} {
110 asnError "Got $type '$val', expected $t"
114 # lex-name-move: see if token is $name; moves pointer and returns
115 # 1 if it is; returns 0 otherwise.
116 proc lex-name-move {name} {
118 if {![string compare $type n] && ![string compare $val $name]} {
125 # asnError: Report error and die
126 proc asnError {msg} {
129 puts "Error in line $inf(lineno) in module $inf(module)"
135 # asnWarning: Report warning and return
136 proc asnWarning {msg} {
139 puts "Warning in line $inf(lineno) in module $inf(module)"
143 # asnEnum: parses enumerated list - { name1 (n), name2 (n), ... }
144 # Uses $name as prefix. If there really is a list, $lx holds the C
145 # preprocessor definitions on return; otherwise lx isn't set.
146 proc asnEnum {name lx} {
149 if {[string compare $type \{]} return
152 set pq [asnName $name]
153 set id [lindex $pq 0]
156 lappend l "#define $inf(dprefix)$id $val"
159 if {[string compare $type ,]} break
161 if {[string compare $type \}]} {
162 asnError "Missing \} in enum list got $type '$val'"
167 # asnMod: parses tag and modifier.
168 # $xtag and $ximplicit holds tag and implicit-indication on return.
169 # $xtag is empty if no tag was specified. $ximplicit is 1 on implicit
170 # tagging; 0 otherwise.
171 proc asnMod {xtag ximplicit xtagtype} {
175 upvar $ximplicit implicit
176 upvar $xtagtype tagtype
180 if {![string compare $type \[]} {
181 if {[regexp {^([a-zA-Z]+)[ ]+([0-9]+)$} $val x tagtype tag]} {
182 set tagtype ODR_$tagtype
183 } elseif {[regexp {^([0-9]+)$} $val x tag]} {
184 set tagtype ODR_CONTEXT
186 asnError "bad tag specification: $val"
190 set implicit $inf(implicit-tags)
191 if {![string compare $type n]} {
192 if {![string compare $val EXPLICIT]} {
195 } elseif {![string compare $val IMPLICIT]} {
202 # asnName: moves pointer and expects name. Returns C-validated name.
203 proc asnName {name} {
206 if {[info exists inf(membermap,$inf(module),$name,$val)]} {
207 set nval $inf(membermap,$inf(module),$name,$val)
209 puts " mapping member $name,$val to $nval"
211 if {![string match {[A-Z]*} $val]} {
216 if {![string match {[A-Z]*} $val]} {
220 return [join [split $nval -] _]
223 # asnOptional: parses optional modifier. Returns 1 if OPTIONAL was
224 # specified; 0 otherwise.
225 proc asnOptional {} {
227 if {[lex-name-move OPTIONAL]} {
229 } elseif {[lex-name-move DEFAULT]} {
236 # asnSizeConstraint: parses the optional SizeConstraint.
237 # Currently not used for anything.
238 proc asnSizeConstraint {} {
240 if {[lex-name-move SIZE]} {
245 # asnSubtypeSpec: parses the SubtypeSpec ...
246 # Currently not used for anything. We now it's balanced however, i.e.
248 proc asnSubtypeSpec {} {
251 if {[string compare $type "("]} {
257 if {![string compare $type "("]} {
259 } elseif {![string compare $type ")"]} {
266 # asnType: parses ASN.1 type.
267 # On entry $name should hold the name we are currently defining.
268 # Returns type indicator:
269 # SequenceOf SEQUENCE OF
274 # Simple Basic types.
275 # In this casecalling procedure's $tname variable is a list holding:
276 # {C-Function C-Type} if the type is IMPORTed or ODR defined.
278 # {C-Function C-Type 1} if the type should be defined in this module
279 proc asnType {name} {
284 if {[string compare $type n]} {
285 asnError "Expects type specifier, but got $type"
292 if {[lex-name-move OF]} {
302 if {[lex-name-move OF]} {
315 if {[string length [info commands asnBasic$v]]} {
316 set tname [asnBasic$v]
318 if {[info exists inf(map,$inf(module),$v)]} {
319 set v $inf(map,$inf(module),$v)
321 if {[info exists inf(imports,$v)]} {
322 set tname $inf(imports,$v)
324 set w [join [split $v -] _]
325 set tname [list $inf(fprefix)$w $inf(vprefix)$w 1]
328 if {[lex-name-move DEFINED]} {
329 if {[lex-name-move BY]} {
337 proc mapName {name} {
339 if {[info exists inf(map,$inf(module),$name)]} {
340 set name $inf(map,$inf(module),$name)
342 puts -nonewline " $name ($inf(lineno))"
343 puts " mapping to $name"
347 puts " $name ($inf(lineno))"
353 # asnDef: parses type definition (top-level) and generates C code
354 # On entry $name holds the type we are defining.
358 set name [mapName $name]
359 if {[info exist inf(defined,$inf(fprefix)$name)]} {
360 incr inf(definedl,$name)
361 if {$inf(verbose) > 1} {
362 puts "set map($inf(module),$name) $name$inf(definedl,$name)"
365 set inf(definedl,$name) 0
367 set mname [join [split $name -] _]
368 asnMod tag implicit tagtype
369 set t [asnType $mname]
370 asnSub $mname $t $tname $tag $implicit $tagtype
374 # asnSub: parses type and generates C-code
376 # $name holds the type we are defining.
377 # $t is the type returned by the asnType procedure.
378 # $tname is the $tname set by the asnType procedure.
379 # $tag is the tag as returned by asnMod
380 # $implicit is the implicit indicator as returned by asnMod
381 proc asnSub {name t tname tag implicit tagtype} {
385 set defname defined,$inf(fprefix)$name
386 if {[info exist inf($defname)]} {
387 asnWarning "$name already defined in line $inf($defname)"
390 set inf($defname) $inf(lineno)
392 Sequence { set l [asnSequence $name $tag $implicit $tagtype] }
393 SequenceOf { set l [asnOf $name $tag $implicit $tagtype 0] }
394 SetOf { set l [asnOf $name $tag $implicit $tagtype 1] }
395 Choice { set l [asnChoice $name $tag $implicit $tagtype] }
396 Simple { set l [asnSimple $name $tname $tag $implicit $tagtype] }
397 default { asnError "switch asnType case not handled" }
402 puts $file(outc) "int $inf(fprefix)$name (ODR o, $inf(vprefix)$name **p, int opt, const char *name)"
404 puts $file(outc) [lindex $l 0]
407 set fdef "$inf(cprefix)int $inf(fprefix)$name (ODR o, $inf(vprefix)$name **p, int opt, const char *name);"
410 set decl "typedef [lindex $l 1] $inf(vprefix)$name;"
411 if {![string compare [lindex $tname 2] 1]} {
412 if {![info exist inf(defined,[lindex $tname 0])]} {
416 set inf(var,$inf(nodef)) [join [lindex $l 2] \n]
420 set decl "typedef struct $inf(vprefix)$name $inf(vprefix)$name;"
421 set inf(var,$inf(nodef)) "[lindex $l 1];"
427 puts $file(outh) $decl
428 puts $file(outh) $fdef
429 asnForwardTypes $name
431 lappend inf(forward,code,[lindex $tname 0]) {} $decl $fdef
432 lappend inf(forward,ref,[lindex $tname 0]) $name
436 proc asnForwardTypes {name} {
439 if {![info exists inf(forward,code,$inf(fprefix)$name)]} {
442 foreach r $inf(forward,code,$inf(fprefix)$name) {
445 unset inf(forward,code,$inf(fprefix)$name)
447 while {[info exists inf(forward,ref,$inf(fprefix)$name)]} {
448 set n $inf(forward,ref,$inf(fprefix)$name)
449 set m [lrange $n 1 end]
451 set inf(forward,ref,$inf(fprefix)$name) $m
453 unset inf(forward,ref,$inf(fprefix)$name)
455 asnForwardTypes [lindex $n 0]
459 # asnSimple: parses simple type definition and generates C code
461 # $name is the name we are defining
462 # $tname is the tname as returned by asnType
463 # $tag is the tag as returned by asnMod
464 # $implicit is the implicit indicator as returned by asnMod
467 # Note: Doesn't take care of enum lists yet.
468 proc asnSimple {name tname tag implicit tagtype} {
471 set j "[lindex $tname 1] "
473 if {[info exists inf(unionmap,$inf(module),$name)]} {
474 set uName $inf(unionmap,$inf(module),$name)
480 if {![string length $tag]} {
481 set l "\treturn [lindex $tname 0] (o, p, opt, name);"
482 } elseif {$implicit} {
484 "\treturn odr_implicit_tag (o, [lindex $tname 0], p, $tagtype, $tag, opt, name);"
487 "\treturn odr_explicit_tag (o, [lindex $tname 0], p, $tagtype, $tag, opt, name);" \
489 if {[info exists jj]} {
490 return [list $l $j $jj]
496 # asnSequence: parses "SEQUENCE { s-list }" and generates C code.
498 # $name is the type we are defining
503 proc asnSequence {name tag implicit tagtype} {
506 lappend j "struct $inf(vprefix)$name \{"
509 if {![string length $tag]} {
510 lappend l "\tif (!odr_sequence_begin (o, p, sizeof(**p), name))"
511 lappend l "\t\treturn odr_missing(o, opt, name) && odr_ok (o);"
512 } elseif {$implicit} {
513 lappend l "\tif (!odr_implicit_settag (o, $tagtype, $tag) ||"
514 lappend l "\t\t!odr_sequence_begin (o, p, sizeof(**p), name))"
515 lappend l "\t\treturn odr_missing(o, opt, name);"
517 lappend l "\tif (!odr_constructed_begin (o, p, $tagtype, $tag, name))"
518 lappend l "\t\treturn odr_missing(o, opt, name);"
519 lappend l "\tif (o->direction == ODR_DECODE)"
520 lappend l "\t\t*p = ($inf(vprefix)$name *) odr_malloc (o, sizeof(**p));"
522 lappend l "\tif (!odr_sequence_begin (o, p, sizeof(**p), 0))"
524 lappend l "\t\tif(o->direction == ODR_DECODE)"
525 lappend l "\t\t\t*p = 0;"
526 lappend l "\t\treturn 0;"
531 set p [lindex [asnName $name] 0]
532 asnMod ltag limplicit ltagtype
536 if {[info exists inf(unionmap,$inf(module),$name,$p)]} {
537 set uName $inf(unionmap,$inf(module),$name,$p)
540 if {![string compare $t Simple]} {
541 if {[string compare $uName { }]} {
547 set opt [asnOptional]
548 if {![string length $ltag]} {
549 lappend l "\t\t[lindex $tname 0](o, &(*p)->$p, $opt, \"$p\") &&"
550 } elseif {$limplicit} {
551 lappend l "\t\todr_implicit_tag (o, [lindex $tname 0],"
552 lappend l "\t\t\t&(*p)->$p, $ltagtype, $ltag, $opt, \"$p\") &&"
554 lappend l "\t\todr_explicit_tag (o, [lindex $tname 0],"
555 lappend l "\t\t\t&(*p)->$p, $ltagtype, $ltag, $opt, \"$p\") &&"
557 set dec "\t[lindex $tname 1] *$p;"
558 } elseif {![string compare $t SequenceOf] && [string length $uName] &&\
559 (![string length $ltag] || $limplicit)} {
562 if {[llength $uName] < 2} {
563 set uName [list num_$p $p]
565 if {[string length $ltag]} {
569 lappend l "\t\todr_implicit_settag (o, $ltagtype, $ltag) &&"
574 set tmpa "odr_sequence_of(o, (Odr_fun) [lindex $tname 0], &(*p)->$p,"
575 set tmpb "&(*p)->[lindex $uName 0], \"$p\")"
576 lappend j "\tint [lindex $uName 0];"
577 set dec "\t[lindex $tname 1] **[lindex $uName 1];"
580 set subName [mapName ${name}_$level]
581 asnSub $subName $u {} {} 0 {}
583 set tmpa "odr_sequence_of(o, (Odr_fun) $inf(fprefix)$subName, &(*p)->$p,"
584 set tmpb "&(*p)->[lindex $uName 0], \"$p\")"
585 lappend j "\tint [lindex $uName 0];"
586 set dec "\t$inf(vprefix)$subName **[lindex $uName 1];"
590 set opt [asnOptional]
592 lappend l "\t\t($tmpa"
593 lappend l "\t\t $tmpb || odr_ok(o)) &&"
595 lappend l "\t\t$tmpa"
596 lappend l "\t\t $tmpb &&"
598 } elseif {!$nchoice && ![string compare $t Choice] && \
599 [string length $uName]} {
600 if {[llength $uName] < 3} {
601 set uName [list which u $name]
604 lappend j "\tint [lindex $uName 0];"
605 lappend j "\tunion \{"
606 lappend v "\tstatic Odr_arm arm\[\] = \{"
607 asnArm $name [lindex $uName 2] v j
609 set dec "\t\} [lindex $uName 1];"
610 set opt [asnOptional]
613 if {[string length $ltag]} {
615 lappend l "\t\todr_implicit_settag (o, $ltagtype, $ltag) &&"
617 asnWarning "optional handling missing in CHOICE in SEQUENCE"
618 asnWarning " set unionmap($inf(module),$name,$p) to {}"
626 lappend l "\t\t${la}odr_constructed_begin (o, &(*p)->[lindex $uName 1], $ltagtype, $ltag, \"$p\") &&"
631 set ob " || odr_ok(o))"
634 lappend l "\t\t${oa}odr_choice (o, arm, &(*p)->[lindex $uName 1], &(*p)->[lindex $uName 0], 0)${ob} &&"
635 if {[string length $ltag]} {
638 set lb ") || odr_ok(o))"
642 lappend l "\t\todr_constructed_end (o)${lb} &&"
646 set subName [mapName ${name}_$level]
647 asnSub $subName $t {} {} 0 {}
648 set opt [asnOptional]
649 if {![string length $ltag]} {
650 lappend l "\t\t$inf(fprefix)${subName} (o, &(*p)->$p, $opt, \"$p\") &&"
651 } elseif {$limplicit} {
652 lappend l "\t\todr_implicit_tag (o, $inf(fprefix)${subName},"
653 lappend l "\t\t\t&(*p)->$p, $ltagtype, $ltag, $opt, \"$p\") &&"
655 lappend l "\t\todr_explicit_tag (o, $inf(fprefix)${subName},"
656 lappend l "\t\t\t&(*p)->$p, $ltagtype, $ltag, $opt, \"$p\") &&"
658 set dec "\t$inf(vprefix)${subName} *$p;"
662 lappend j "$dec /* OPT */"
666 if {[string compare $type ,]} break
669 if {[string length $tag] && !$implicit} {
670 lappend l "\t\todr_sequence_end (o) &&"
671 lappend l "\t\todr_constructed_end (o);"
673 lappend l "\t\todr_sequence_end (o);"
675 if {[string compare $type \}]} {
676 asnError "Missing \} got $type '$val'"
679 if {[info exists v]} {
682 return [list [join $l \n] [join $j \n]]
685 # asnOf: parses "SEQUENCE/SET OF type" and generates C code.
687 # $name is the type we are defining
692 proc asnOf {name tag implicit tagtype isset} {
698 set func odr_sequence_of
701 if {[info exists inf(unionmap,$inf(module),$name)]} {
702 set numName $inf(unionmap,$inf(module),$name)
704 set numName {num elements}
707 lappend j "struct $inf(vprefix)$name \{"
708 lappend j "\tint [lindex $numName 0];"
710 lappend l "\tif (!odr_initmember (o, p, sizeof(**p)))"
711 lappend l "\t\treturn odr_missing(o, opt, name);"
712 if {[string length $tag]} {
714 lappend l "\todr_implicit_settag (o, $tagtype, $tag);"
716 asnWarning "Constructed SEQUENCE/SET OF not handled"
719 set t [asnType $name]
723 lappend l "\tif ($func (o, (Odr_fun) [lindex $tname 0], &(*p)->[lindex $numName 1],"
724 lappend l "\t\t&(*p)->[lindex $numName 0], name))"
725 lappend j "\t[lindex $tname 1] **[lindex $numName 1];"
728 set subName [mapName ${name}_s]
729 lappend l "\tif ($func (o, (Odr_fun) $inf(fprefix)$subName, &(*p)->[lindex $numName 1],"
730 lappend l "\t\t&(*p)->[lindex $numName 0], name))"
731 lappend j "\t$inf(vprefix)$subName **[lindex $numName 1];"
732 asnSub $subName $t {} {} 0 {}
736 lappend l "\t\treturn 1;"
737 lappend l "\tif(o->direction == ODR_DECODE)"
738 lappend l "\t\t*p = 0;"
739 lappend l "\treturn odr_missing(o, opt, name);"
740 return [list [join $l \n] [join $j \n]]
743 # asnArm: parses c-list in choice
744 proc asnArm {name defname lx jx} {
750 set pq [asnName $name]
753 if {![string length $q]} {
757 asnMod ltag limplicit ltagtype
760 lappend enums "$inf(dprefix)$p"
761 if {![string compare $t Simple]} {
763 if {![string length $ltag]} {
764 lappend l "\t\t\{-1, -1, -1, $inf(dprefix)$p,"
765 lappend l "\t\t (Odr_fun) [lindex $tname 0], \"$q\"\},"
766 } elseif {$limplicit} {
767 lappend l "\t\t\{ODR_IMPLICIT, $ltagtype, $ltag, $inf(dprefix)$p,"
768 lappend l "\t\t(Odr_fun) [lindex $tname 0], \"$q\"\},"
770 lappend l "\t\t\{ODR_EXPLICIT, $ltagtype, $ltag, $inf(dprefix)$p,"
771 lappend l "\t\t(Odr_fun) [lindex $tname 0], \"$q\"\},"
773 lappend j "\t\t[lindex $tname 1] *$q;"
775 set subName [mapName ${name}_$q]
776 if {![string compare $inf(dprefix)${name}_$q \
777 $inf(vprefix)$subName]} {
778 set po [string toupper [string index $q 0]][string \
780 set subName [mapName ${name}${po}]
782 asnSub $subName $t $tname {} 0 {}
783 if {![string length $ltag]} {
784 lappend l "\t\t\{-1, -1, -1, $inf(dprefix)$p,"
785 lappend l "\t\t (Odr_fun) $inf(fprefix)$subName, \"$q\"\},"
786 } elseif {$limplicit} {
787 lappend l "\t\t\{ODR_IMPLICIT, $ltagtype, $ltag, $inf(dprefix)$p,"
788 lappend l "\t\t(Odr_fun) $inf(fprefix)$subName, \"$q\"\},"
790 lappend l "\t\t\{ODR_EXPLICIT, $ltagtype, $ltag, $inf(dprefix)$p,"
791 lappend l "\t\t(Odr_fun) $inf(fprefix)$subName, \"$q\"\},"
793 lappend j "\t\t$inf(vprefix)$subName *$q;"
795 if {[string compare $type ,]} break
797 if {[string compare $type \}]} {
798 asnError "Missing \} got $type '$val'"
803 lappend j "#define $e $level"
806 lappend l "\t\t\{-1, -1, -1, -1, (Odr_fun) 0, 0\}"
809 # asnChoice: parses "CHOICE {c-list}" and generates C code.
811 # $name is the type we are defining
816 proc asnChoice {name tag implicit tagtype} {
819 if {[info exists inf(unionmap,$inf(module),$name)]} {
820 set uName $inf(unionmap,$inf(module),$name)
822 set uName [list which u $name]
825 lappend j "struct $inf(vprefix)$name \{"
826 lappend j "\tint [lindex $uName 0];"
827 lappend j "\tunion \{"
828 lappend l "\tstatic Odr_arm arm\[\] = \{"
829 asnArm $name [lindex $uName 2] l j
830 lappend j "\t\} [lindex $uName 1];"
833 if {![string length $tag]} {
834 lappend l "\tif (!odr_initmember(o, p, sizeof(**p)))"
835 lappend l "\t\treturn odr_missing(o, opt, name);"
836 lappend l "\tif (odr_choice(o, arm, &(*p)->[lindex $uName 1], &(*p)->[lindex $uName 0], name))"
837 } elseif {$implicit} {
838 lappend l "\tif (!odr_initmember(o, p, sizeof(**p)))"
839 lappend l "\t\treturn odr_missing(o, opt, name);"
840 lappend l "\todr_implicit_settag(o, $tagtype, $tag);"
841 lappend l "\tif (odr_choice(o, arm, &(*p)->[lindex $uName 1], &(*p)->[lindex $uName 0], name))"
843 lappend l "\tif (!odr_constructed_begin(o, p, $tagtype, $tag, 0))"
844 lappend l "\t\treturn odr_missing(o, opt, name);"
845 lappend l "\tif (!odr_initmember(o, p, sizeof(**p)))"
846 lappend l "\t\treturn odr_missing(o, opt, name);"
847 lappend l "\tif (odr_choice(o, arm, &(*p)->[lindex $uName 1], &(*p)->[lindex $uName 0], name) &&"
848 lappend l "\t\todr_constructed_end(o))"
850 lappend l "\t\treturn 1;"
852 lappend l "\tif(o->direction == ODR_DECODE)"
853 lappend l "\t\t*p = 0;"
855 lappend l "\treturn odr_missing(o, opt, name);"
856 return [list [join $l \n] [join $j \n]]
859 # asnImports: parses i-list in "IMPORTS {i-list}"
860 # On return inf(import,..)-array is updated.
861 # inf(import,"module") is a list of {C-handler, C-type} elements.
862 # The {C-handler, C-type} is compatible with the $tname as is used by the
863 # asnType procedure to solve external references.
865 global type val inf file
868 if {[string compare $type n]} {
869 asnError "Missing name in IMPORTS list"
873 if {![string compare $type n] && ![string compare $val FROM]} {
876 if {[info exists inf(filename,$val)]} {
877 set fname $inf(filename,$val)
881 puts $file(outh) "\#include <$inf(h-dir)${fname}.h>"
883 if {[info exists inf(prefix,$val)]} {
884 set prefix $inf(prefix,$val)
886 set prefix $inf(prefix)
889 if {[info exists inf(map,$val,$n)]} {
890 set v $inf(map,$val,$n)
894 set w [join [split $v -] _]
895 set inf(imports,$n) [list [lindex $prefix 0]$w \
896 [lindex $prefix 1]$w]
900 if {[string compare $type n]} break
901 } elseif {![string compare $type ,]} {
905 if {[string compare $type \;]} {
906 asnError "Missing ; after IMPORTS list - got $type '$val'"
911 # asnExports: parses e-list in "EXPORTS {e-list}"
912 # This function does nothing with elements in the list.
917 if {[string compare $type n]} {
918 asnError "Missing name in EXPORTS list"
920 set inf(exports,$val) 1
922 if {[string compare $type ,]} break
925 if {[string compare $type \;]} {
926 asnError "Missing ; after EXPORTS list - got $type ($val)"
931 # asnModuleBody: parses a module specification and generates C code.
932 # Exports lists, imports lists, and type definitions are handled;
933 # other things are silently ignored.
934 proc asnModuleBody {} {
935 global type val file inf
937 if {[info exists inf(prefix,$inf(module))]} {
938 set prefix $inf(prefix,$inf(module))
940 set prefix $inf(prefix)
942 set inf(fprefix) [lindex $prefix 0]
943 set inf(vprefix) [lindex $prefix 1]
944 set inf(dprefix) [lindex $prefix 2]
945 if {[llength $prefix] > 3} {
946 set inf(cprefix) [lindex $prefix 3]
948 set inf(cprefix) {YAZ_EXPORT }
952 puts "Module $inf(module), $inf(lineno)"
956 if {[info exists inf(init,$inf(module),c)]} {
957 puts $file(outc) $inf(init,$inf(module),c)
959 if {[info exists inf(init,$inf(module),h)]} {
960 puts $file(outh) "\#ifdef __cplusplus"
961 puts $file(outh) "extern \"C\" \{"
962 puts $file(outh) "\#endif"
964 puts $file(outh) $inf(init,$inf(module),h)
966 if {[info exists inf(init,$inf(module),p)]} {
967 puts $file(outp) $inf(init,$inf(module),p)
970 while {[string length $type]} {
971 if {[string compare $type n]} {
975 if {![string compare $val END]} {
977 } elseif {![string compare $val EXPORTS]} {
980 } elseif {![string compare $val IMPORTS]} {
982 puts $file(outh) "\#ifdef __cplusplus"
983 puts $file(outh) "\}"
984 puts $file(outh) "\#endif"
991 puts $file(outh) "\#ifdef __cplusplus"
992 puts $file(outh) "extern \"C\" \{"
993 puts $file(outh) "\#endif"
996 set inf(asndef) $inf(nodef)
999 if {![string compare $type :]} {
1003 } elseif {![string compare $type n]} {
1005 if {[string length $type]} {
1012 puts $file(outh) "\#ifdef __cplusplus"
1013 puts $file(outh) "\}"
1014 puts $file(outh) "\#endif"
1017 foreach x [array names inf imports,*] {
1022 # asnTagDefault: parses TagDefault section
1023 proc asnTagDefault {} {
1024 global type val inf file
1026 set inf(implicit-tags) 0
1027 while {[string length $type]} {
1028 if {[lex-name-move EXPLICIT]} {
1030 set inf(implicit-tags) 0
1031 } elseif {[lex-name-move IMPLICIT]} {
1033 set inf(implicit-tags) 1
1040 # asnModules: parses a collection of module specifications.
1041 # Depending on the module pattern, $inf(moduleP), a module is either
1042 # skipped or processed.
1043 proc asnModules {} {
1044 global type val inf file yc_version
1049 while {![string compare $type n]} {
1050 set inf(module) $val
1051 if {[info exists inf(moduleP)] && ![string match $inf(moduleP) $val]} {
1052 if {$inf(verbose)} {
1055 while {![lex-name-move END]} {
1062 while {![lex-name-move DEFINITIONS]} {
1064 if {![string length $type]} return
1066 if {[info exists inf(filename,$inf(module))]} {
1067 set fname $inf(filename,$inf(module))
1069 set fname $inf(module)
1071 set ppname [join [split $fname -] _]
1073 if {![info exists inf(c-file)]} {
1074 set inf(c-file) ${fname}.c
1076 set file(outc) [open $inf(c-file) w]
1078 if {![info exists inf(h-file)]} {
1079 set inf(h-file) ${fname}.h
1081 set file(outh) [open $inf(h-path)/$inf(h-dir)$inf(h-file) w]
1084 if {![info exists inf(p-file)]} {
1085 set inf(p-file) ${fname}-p.h
1087 set file(outp) [open $inf(h-path)/$inf(h-dir)$inf(p-file) w]
1090 set greeting {Generated automatically by YAZ ASN.1 Compiler}
1092 puts $file(outc) "/** \\file $inf(c-file)"
1093 puts $file(outc) " \\brief ASN.1 Module $inf(module)"
1095 puts $file(outc) " ${greeting} ${yc_version}"
1096 puts $file(outc) "*/"
1099 puts $file(outh) "/** \\file $inf(h-file)"
1100 puts $file(outh) " \\brief ASN.1 Module $inf(module)"
1102 puts $file(outh) " ${greeting} ${yc_version}"
1103 puts $file(outh) "*/"
1106 if {[info exists file(outp)]} {
1107 puts $file(outp) "/** \\file $inf(p-file)"
1108 puts $file(outp) " \\brief ASN.1 Module $inf(module)"
1110 puts $file(outp) " ${greeting} ${yc_version}"
1111 puts $file(outp) "*/"
1115 if {[info exists inf(p-file)]} {
1116 puts $file(outc) "\#include <$inf(h-dir)$inf(p-file)>"
1118 puts $file(outc) "\#include <$inf(h-dir)$inf(h-file)>"
1120 puts $file(outh) "\#ifndef ${ppname}_H"
1121 puts $file(outh) "\#define ${ppname}_H"
1123 puts $file(outh) "\#include <yaz/odr.h>"
1125 if {[info exists file(outp)]} {
1126 puts $file(outp) "\#ifndef ${ppname}_P_H"
1127 puts $file(outp) "\#define ${ppname}_P_H"
1129 puts $file(outp) "\#include <$inf(h-dir)$inf(h-file)>"
1134 if {[string compare $type :]} {
1135 asnError "::= expected got $type '$val'"
1138 if {![lex-name-move BEGIN]} {
1139 asnError "BEGIN expected"
1144 if {[info exists file(outp)]} {
1149 puts $f "\#ifdef __cplusplus"
1150 puts $f "extern \"C\" \{"
1152 for {set i 1} {$i < $inf(nodef)} {incr i} {
1153 puts $f $inf(var,$i)
1154 if {[info exists inf(asn,$i)]} {
1157 foreach comment $inf(asn,$i) {
1167 puts $f "\#ifdef __cplusplus"
1171 if {[info exists inf(body,$inf(module),h)]} {
1172 puts $file(outh) $inf(body,$inf(module),h)
1174 if {[info exists inf(body,$inf(module),c)]} {
1175 puts $file(outc) $inf(body,$inf(module),c)
1177 if {[info exists inf(body,$inf(module),p)]} {
1178 if {[info exists file(outp)]} {
1179 puts $file(outp) $inf(body,$inf(module),p)
1182 puts $file(outh) "\#endif"
1183 if {[info exists file(outp)]} {
1184 puts $file(outp) "\#endif"
1186 foreach f [array names file] {
1191 catch {unset inf(p-file)}
1196 # asnFile: parses an ASN.1 specification file as specified in $inf(iname).
1200 if {$inf(verbose) > 1} {
1201 puts "Reading ASN.1 file $inf(iname)"
1205 set inf(inf) [open $inf(iname) r]
1211 # The following procedures are invoked by the asnType function.
1212 # Each procedure takes the form: asnBasic<TYPE> and they must return
1213 # two elements: the C function handler and the C type.
1214 # On entry upvar $name is the type we are defining and global, $inf(module), is
1215 # the current module name.
1217 proc asnBasicEXTERNAL {} {
1218 return {odr_external {Odr_external}}
1221 proc asnBasicINTEGER {} {
1222 return {odr_integer {int}}
1225 proc asnBasicENUMERATED {} {
1226 return {odr_enum {int}}
1229 proc asnBasicNULL {} {
1230 return {odr_null {Odr_null}}
1233 proc asnBasicBOOLEAN {} {
1234 return {odr_bool {bool_t}}
1237 proc asnBasicOCTET {} {
1239 lex-name-move STRING
1240 return {odr_octetstring {Odr_oct}}
1243 proc asnBasicBIT {} {
1245 lex-name-move STRING
1246 return {odr_bitstring {Odr_bitmask}}
1249 proc asnBasicOBJECT {} {
1251 lex-name-move IDENTIFIER
1252 return {odr_oid {Odr_oid}}
1255 proc asnBasicGeneralString {} {
1256 return {odr_generalstring char}
1259 proc asnBasicVisibleString {} {
1260 return {odr_visiblestring char}
1263 proc asnBasicGeneralizedTime {} {
1264 return {odr_generalizedtime char}
1267 proc asnBasicANY {} {
1270 return [list $inf(fprefix)ANY_$name void]
1273 # userDef: reads user definitions file $name
1274 proc userDef {name} {
1277 if {$inf(verbose) > 1} {
1278 puts "Reading definitions file $name"
1282 if {[info exists default-prefix]} {
1283 set inf(prefix) ${default-prefix}
1285 if {[info exists h-path]} {
1286 set inf(h-path) ${h-path}
1288 foreach m [array names prefix] {
1289 set inf(prefix,$m) $prefix($m)
1291 foreach m [array names body] {
1292 set inf(body,$m) $body($m)
1294 foreach m [array names init] {
1295 set inf(init,$m) $init($m)
1297 foreach m [array names filename] {
1298 set inf(filename,$m) $filename($m)
1300 foreach m [array names map] {
1301 set inf(map,$m) $map($m)
1303 foreach m [array names membermap] {
1304 set inf(membermap,$m) $membermap($m)
1306 foreach m [array names unionmap] {
1307 set inf(unionmap,$m) $unionmap($m)
1312 set inf(prefix) {yc_ Yc_ YC_}
1316 # Parse command line
1317 set l [llength $argv]
1320 set arg [lindex $argv $i]
1321 switch -glob -- $arg {
1326 set p [string range $arg 2 end]
1327 if {![string length $p]} {
1328 set p [lindex $argv [incr i]]
1333 set p [string range $arg 2 end]
1334 if {![string length $p]} {
1335 set p [lindex $argv [incr i]]
1340 set p [string range $arg 2 end]
1341 if {![string length $p]} {
1342 set p [lindex $argv [incr i]]
1344 set inf(h-dir) [string trim $p \\/]/
1347 set p [string range $arg 2 end]
1348 if {![string length $p]} {
1349 set p [lindex $argv [incr i]]
1354 set p [string range $arg 2 end]
1355 if {![string length $p]} {
1356 set p [lindex $argv [incr i]]
1361 set p [string range $arg 2 end]
1362 if {![string length $p]} {
1363 set p [lindex $argv [incr i]]
1368 set p [string range $arg 2 end]
1369 if {![string length $p]} {
1370 set p [lindex $argv [incr i]]
1375 set p [string range $arg 2 end]
1376 if {![string length $p]} {
1377 set p [lindex $argv [incr i]]
1379 if {[llength $p] == 1} {
1380 set inf(prefix) [list [string tolower $p] \
1381 [string toupper $p] [string toupper $p]]
1382 } elseif {[llength $p] == 3} {
1396 if {![info exists inf(iname)]} {
1397 puts "YAZ ASN.1 Compiler ${yc_version}"
1399 puts -nonewline ${argv0}
1400 puts { [-v] [-c cfile] [-h hfile] [-p hfile] [-d dfile] [-I iout]}
1401 puts { [-i idir] [-m module] file}