2 # the next line restarts using tclsh \
3 if [ -f /usr/local/bin/tclsh8.4 ]; then exec tclsh8.4 "$0" "$@"; else exec tclsh "$0" "$@"; fi
5 # yaz-comp: ASN.1 Compiler for YAZ
6 # (c) Index Data 1996-2007
7 # See the file LICENSE for details.
9 # $Id: yaz-asncomp,v 1.8 2007-01-03 08:42:16 adam Exp $
14 # Syntax for the ASN.1 supported:
17 # module -> name skip DEFINITIONS ::= mbody END
18 # mbody -> EXPORTS { nlist }
19 # | IMPORTS { imlist }
23 # type -> SEQUENCE { sqlist }
34 # sqlist -> sqlist , name tmt opt
36 # chlist -> chlist , name tmt
38 # enlist -> enlist , name (n)
40 # imlist -> nlist FROM name
41 # imlist nlist FROM name
44 # mod -> IMPLICIT | EXPLICIT | e
45 # tag -> [tagtype n] | [n] | e
48 # name identifier/token
50 # skip one token skipped
52 # tagtype APPLICATION, CONTEXT, etc.
54 # lex: moves input file pointer and returns type of token.
55 # The globals $type and $val are set. $val holds name if token
56 # is normal identifier name.
57 # sets global var type to one of:
60 # \} right curly brace
69 while {![string length $inf(str)]} {
71 set inf(cnt) [gets $inf(inf) inf(str)]
76 lappend inf(asn,$inf(asndef)) $inf(str)
77 set l [string first -- $inf(str)]
80 set inf(str) [string range $inf(str) 0 $l]
82 set inf(str) [string trim $inf(str)]
84 set s [string index $inf(str) 0]
94 \[ { regexp {^\[[ ]*(.+)[ ]*\]} $inf(str) s val }
95 : { regexp {^::=} $inf(str) s }
97 regexp "^\[^,\t :\{\}();\]+" $inf(str) s
102 set off [string length $s]
103 set inf(str) [string trim [string range $inf(str) $off end]]
107 # lex-expect: move pointer and expect token $t
108 proc lex-expect {t} {
111 if {[string compare $t $type]} {
112 asnError "Got $type '$val', expected $t"
116 # lex-name-move: see if token is $name; moves pointer and returns
117 # 1 if it is; returns 0 otherwise.
118 proc lex-name-move {name} {
120 if {![string compare $type n] && ![string compare $val $name]} {
127 # asnError: Report error and die
128 proc asnError {msg} {
131 puts "Error in line $inf(lineno) in module $inf(module)"
137 # asnWarning: Report warning and return
138 proc asnWarning {msg} {
141 puts "Warning in line $inf(lineno) in module $inf(module)"
145 # asnEnum: parses enumerated list - { name1 (n), name2 (n), ... }
146 # Uses $name as prefix. If there really is a list, $lx holds the C
147 # preprocessor definitions on return; otherwise lx isn't set.
148 proc asnEnum {name lx} {
151 if {[string compare $type \{]} return
154 set pq [asnName $name]
155 set id [lindex $pq 0]
158 lappend l "#define $inf(dprefix)$id $val"
161 if {[string compare $type ,]} break
163 if {[string compare $type \}]} {
164 asnError "Missing \} in enum list got $type '$val'"
169 # asnMod: parses tag and modifier.
170 # $xtag and $ximplicit holds tag and implicit-indication on return.
171 # $xtag is empty if no tag was specified. $ximplicit is 1 on implicit
172 # tagging; 0 otherwise.
173 proc asnMod {xtag ximplicit xtagtype} {
177 upvar $ximplicit implicit
178 upvar $xtagtype tagtype
182 if {![string compare $type \[]} {
183 if {[regexp {^([a-zA-Z]+)[ ]+([0-9]+)$} $val x tagtype tag]} {
184 set tagtype ODR_$tagtype
185 } elseif {[regexp {^([0-9]+)$} $val x tag]} {
186 set tagtype ODR_CONTEXT
188 asnError "bad tag specification: $val"
192 set implicit $inf(implicit-tags)
193 if {![string compare $type n]} {
194 if {![string compare $val EXPLICIT]} {
197 } elseif {![string compare $val IMPLICIT]} {
204 # asnName: moves pointer and expects name. Returns C-validated name.
205 proc asnName {name} {
208 if {[info exists inf(membermap,$inf(module),$name,$val)]} {
209 set nval $inf(membermap,$inf(module),$name,$val)
211 puts " mapping member $name,$val to $nval"
213 if {![string match {[A-Z]*} $val]} {
218 if {![string match {[A-Z]*} $val]} {
222 return [join [split $nval -] _]
225 # asnOptional: parses optional modifier. Returns 1 if OPTIONAL was
226 # specified; 0 otherwise.
227 proc asnOptional {} {
229 if {[lex-name-move OPTIONAL]} {
231 } elseif {[lex-name-move DEFAULT]} {
238 # asnSizeConstraint: parses the optional SizeConstraint.
239 # Currently not used for anything.
240 proc asnSizeConstraint {} {
242 if {[lex-name-move SIZE]} {
247 # asnSubtypeSpec: parses the SubtypeSpec ...
248 # Currently not used for anything. We now it's balanced however, i.e.
250 proc asnSubtypeSpec {} {
253 if {[string compare $type "("]} {
259 if {![string compare $type "("]} {
261 } elseif {![string compare $type ")"]} {
268 # asnType: parses ASN.1 type.
269 # On entry $name should hold the name we are currently defining.
270 # Returns type indicator:
271 # SequenceOf SEQUENCE OF
276 # Simple Basic types.
277 # In this casecalling procedure's $tname variable is a list holding:
278 # {C-Function C-Type} if the type is IMPORTed or ODR defined.
280 # {C-Function C-Type 1} if the type should be defined in this module
281 proc asnType {name} {
286 if {[string compare $type n]} {
287 asnError "Expects type specifier, but got $type"
294 if {[lex-name-move OF]} {
304 if {[lex-name-move OF]} {
317 if {[string length [info commands asnBasic$v]]} {
318 set tname [asnBasic$v]
320 if {[info exists inf(map,$inf(module),$v)]} {
321 set v $inf(map,$inf(module),$v)
323 if {[info exists inf(imports,$v)]} {
324 set tname $inf(imports,$v)
326 set w [join [split $v -] _]
327 set tname [list $inf(fprefix)$w $inf(vprefix)$w 1]
330 if {[lex-name-move DEFINED]} {
331 if {[lex-name-move BY]} {
339 proc mapName {name} {
341 if {[info exists inf(map,$inf(module),$name)]} {
342 set name $inf(map,$inf(module),$name)
344 puts -nonewline " $name ($inf(lineno))"
345 puts " mapping to $name"
349 puts " $name ($inf(lineno))"
355 # asnDef: parses type definition (top-level) and generates C code
356 # On entry $name holds the type we are defining.
360 set name [mapName $name]
361 if {[info exist inf(defined,$inf(fprefix)$name)]} {
362 incr inf(definedl,$name)
363 if {$inf(verbose) > 1} {
364 puts "set map($inf(module),$name) $name$inf(definedl,$name)"
367 set inf(definedl,$name) 0
369 set mname [join [split $name -] _]
370 asnMod tag implicit tagtype
371 set t [asnType $mname]
372 asnSub $mname $t $tname $tag $implicit $tagtype
376 # asnSub: parses type and generates C-code
378 # $name holds the type we are defining.
379 # $t is the type returned by the asnType procedure.
380 # $tname is the $tname set by the asnType procedure.
381 # $tag is the tag as returned by asnMod
382 # $implicit is the implicit indicator as returned by asnMod
383 proc asnSub {name t tname tag implicit tagtype} {
387 set defname defined,$inf(fprefix)$name
388 if {[info exist inf($defname)]} {
389 asnWarning "$name already defined in line $inf($defname)"
392 set inf($defname) $inf(lineno)
394 Sequence { set l [asnSequence $name $tag $implicit $tagtype] }
395 SequenceOf { set l [asnOf $name $tag $implicit $tagtype 0] }
396 SetOf { set l [asnOf $name $tag $implicit $tagtype 1] }
397 Choice { set l [asnChoice $name $tag $implicit $tagtype] }
398 Simple { set l [asnSimple $name $tname $tag $implicit $tagtype] }
399 default { asnError "switch asnType case not handled" }
404 puts $file(outc) "int $inf(fprefix)$name (ODR o, $inf(vprefix)$name **p, int opt, const char *name)"
406 puts $file(outc) [lindex $l 0]
409 set fdef "$inf(cprefix)int $inf(fprefix)$name (ODR o, $inf(vprefix)$name **p, int opt, const char *name);"
412 set decl "typedef [lindex $l 1] $inf(vprefix)$name;"
413 if {![string compare [lindex $tname 2] 1]} {
414 if {![info exist inf(defined,[lindex $tname 0])]} {
418 set inf(var,$inf(nodef)) [join [lindex $l 2] \n]
422 set decl "typedef struct $inf(vprefix)$name $inf(vprefix)$name;"
423 set inf(var,$inf(nodef)) "[lindex $l 1];"
429 puts $file(outh) $decl
430 puts $file(outh) $fdef
431 asnForwardTypes $name
433 lappend inf(forward,code,[lindex $tname 0]) {} $decl $fdef
434 lappend inf(forward,ref,[lindex $tname 0]) $name
438 proc asnForwardTypes {name} {
441 if {![info exists inf(forward,code,$inf(fprefix)$name)]} {
444 foreach r $inf(forward,code,$inf(fprefix)$name) {
447 unset inf(forward,code,$inf(fprefix)$name)
449 while {[info exists inf(forward,ref,$inf(fprefix)$name)]} {
450 set n $inf(forward,ref,$inf(fprefix)$name)
451 set m [lrange $n 1 end]
453 set inf(forward,ref,$inf(fprefix)$name) $m
455 unset inf(forward,ref,$inf(fprefix)$name)
457 asnForwardTypes [lindex $n 0]
461 # asnSimple: parses simple type definition and generates C code
463 # $name is the name we are defining
464 # $tname is the tname as returned by asnType
465 # $tag is the tag as returned by asnMod
466 # $implicit is the implicit indicator as returned by asnMod
469 # Note: Doesn't take care of enum lists yet.
470 proc asnSimple {name tname tag implicit tagtype} {
473 set j "[lindex $tname 1] "
475 if {[info exists inf(unionmap,$inf(module),$name)]} {
476 set uName $inf(unionmap,$inf(module),$name)
482 if {![string length $tag]} {
483 set l "\treturn [lindex $tname 0] (o, p, opt, name);"
484 } elseif {$implicit} {
486 "\treturn odr_implicit_tag (o, [lindex $tname 0], p, $tagtype, $tag, opt, name);"
489 "\treturn odr_explicit_tag (o, [lindex $tname 0], p, $tagtype, $tag, opt, name);" \
491 if {[info exists jj]} {
492 return [list $l $j $jj]
498 # asnSequence: parses "SEQUENCE { s-list }" and generates C code.
500 # $name is the type we are defining
505 proc asnSequence {name tag implicit tagtype} {
508 lappend j "struct $inf(vprefix)$name \{"
511 if {![string length $tag]} {
512 lappend l "\tif (!odr_sequence_begin (o, p, sizeof(**p), name))"
513 lappend l "\t\treturn odr_missing(o, opt, name) && odr_ok (o);"
514 } elseif {$implicit} {
515 lappend l "\tif (!odr_implicit_settag (o, $tagtype, $tag) ||"
516 lappend l "\t\t!odr_sequence_begin (o, p, sizeof(**p), name))"
517 lappend l "\t\treturn odr_missing(o, opt, name);"
519 lappend l "\tif (!odr_constructed_begin (o, p, $tagtype, $tag, name))"
520 lappend l "\t\treturn odr_missing(o, opt, name);"
521 lappend l "\tif (o->direction == ODR_DECODE)"
522 lappend l "\t\t*p = ($inf(vprefix)$name *) odr_malloc (o, sizeof(**p));"
524 lappend l "\tif (!odr_sequence_begin (o, p, sizeof(**p), 0))"
526 lappend l "\t\tif(o->direction == ODR_DECODE)"
527 lappend l "\t\t\t*p = 0;"
528 lappend l "\t\treturn 0;"
533 set p [lindex [asnName $name] 0]
534 asnMod ltag limplicit ltagtype
538 if {[info exists inf(unionmap,$inf(module),$name,$p)]} {
539 set uName $inf(unionmap,$inf(module),$name,$p)
542 if {![string compare $t Simple]} {
543 if {[string compare $uName { }]} {
549 set opt [asnOptional]
550 if {![string length $ltag]} {
551 lappend l "\t\t[lindex $tname 0](o, &(*p)->$p, $opt, \"$p\") &&"
552 } elseif {$limplicit} {
553 lappend l "\t\todr_implicit_tag (o, [lindex $tname 0],"
554 lappend l "\t\t\t&(*p)->$p, $ltagtype, $ltag, $opt, \"$p\") &&"
556 lappend l "\t\todr_explicit_tag (o, [lindex $tname 0],"
557 lappend l "\t\t\t&(*p)->$p, $ltagtype, $ltag, $opt, \"$p\") &&"
559 set dec "\t[lindex $tname 1] *$p;"
560 } elseif {![string compare $t SequenceOf] && [string length $uName] &&\
561 (![string length $ltag] || $limplicit)} {
564 if {[llength $uName] < 2} {
565 set uName [list num_$p $p]
567 if {[string length $ltag]} {
571 lappend l "\t\todr_implicit_settag (o, $ltagtype, $ltag) &&"
576 set tmpa "odr_sequence_of(o, (Odr_fun) [lindex $tname 0], &(*p)->$p,"
577 set tmpb "&(*p)->[lindex $uName 0], \"$p\")"
578 lappend j "\tint [lindex $uName 0];"
579 set dec "\t[lindex $tname 1] **[lindex $uName 1];"
582 set subName [mapName ${name}_$level]
583 asnSub $subName $u {} {} 0 {}
585 set tmpa "odr_sequence_of(o, (Odr_fun) $inf(fprefix)$subName, &(*p)->$p,"
586 set tmpb "&(*p)->[lindex $uName 0], \"$p\")"
587 lappend j "\tint [lindex $uName 0];"
588 set dec "\t$inf(vprefix)$subName **[lindex $uName 1];"
592 set opt [asnOptional]
594 lappend l "\t\t($tmpa"
595 lappend l "\t\t $tmpb || odr_ok(o)) &&"
597 lappend l "\t\t$tmpa"
598 lappend l "\t\t $tmpb &&"
600 } elseif {!$nchoice && ![string compare $t Choice] && \
601 [string length $uName]} {
602 if {[llength $uName] < 3} {
603 set uName [list which u $name]
606 lappend j "\tint [lindex $uName 0];"
607 lappend j "\tunion \{"
608 lappend v "\tstatic Odr_arm arm\[\] = \{"
609 asnArm $name [lindex $uName 2] v j
611 set dec "\t\} [lindex $uName 1];"
612 set opt [asnOptional]
615 if {[string length $ltag]} {
617 lappend l "\t\todr_implicit_settag (o, $ltagtype, $ltag) &&"
619 asnWarning "optional handling missing in CHOICE in SEQUENCE"
620 asnWarning " set unionmap($inf(module),$name,$p) to {}"
628 lappend l "\t\t${la}odr_constructed_begin (o, &(*p)->[lindex $uName 1], $ltagtype, $ltag, \"$p\") &&"
633 set ob " || odr_ok(o))"
636 lappend l "\t\t${oa}odr_choice (o, arm, &(*p)->[lindex $uName 1], &(*p)->[lindex $uName 0], 0)${ob} &&"
637 if {[string length $ltag]} {
640 set lb ") || odr_ok(o))"
644 lappend l "\t\todr_constructed_end (o)${lb} &&"
648 set subName [mapName ${name}_$level]
649 asnSub $subName $t {} {} 0 {}
650 set opt [asnOptional]
651 if {![string length $ltag]} {
652 lappend l "\t\t$inf(fprefix)${subName} (o, &(*p)->$p, $opt, \"$p\") &&"
653 } elseif {$limplicit} {
654 lappend l "\t\todr_implicit_tag (o, $inf(fprefix)${subName},"
655 lappend l "\t\t\t&(*p)->$p, $ltagtype, $ltag, $opt, \"$p\") &&"
657 lappend l "\t\todr_explicit_tag (o, $inf(fprefix)${subName},"
658 lappend l "\t\t\t&(*p)->$p, $ltagtype, $ltag, $opt, \"$p\") &&"
660 set dec "\t$inf(vprefix)${subName} *$p;"
664 lappend j "$dec /* OPT */"
668 if {[string compare $type ,]} break
671 if {[string length $tag] && !$implicit} {
672 lappend l "\t\todr_sequence_end (o) &&"
673 lappend l "\t\todr_constructed_end (o);"
675 lappend l "\t\todr_sequence_end (o);"
677 if {[string compare $type \}]} {
678 asnError "Missing \} got $type '$val'"
681 if {[info exists v]} {
684 return [list [join $l \n] [join $j \n]]
687 # asnOf: parses "SEQUENCE/SET OF type" and generates C code.
689 # $name is the type we are defining
694 proc asnOf {name tag implicit tagtype isset} {
700 set func odr_sequence_of
703 if {[info exists inf(unionmap,$inf(module),$name)]} {
704 set numName $inf(unionmap,$inf(module),$name)
706 set numName {num elements}
709 lappend j "struct $inf(vprefix)$name \{"
710 lappend j "\tint [lindex $numName 0];"
712 lappend l "\tif (!odr_initmember (o, p, sizeof(**p)))"
713 lappend l "\t\treturn odr_missing(o, opt, name);"
714 if {[string length $tag]} {
716 lappend l "\todr_implicit_settag (o, $tagtype, $tag);"
718 asnWarning "Constructed SEQUENCE/SET OF not handled"
721 set t [asnType $name]
725 lappend l "\tif ($func (o, (Odr_fun) [lindex $tname 0], &(*p)->[lindex $numName 1],"
726 lappend l "\t\t&(*p)->[lindex $numName 0], name))"
727 lappend j "\t[lindex $tname 1] **[lindex $numName 1];"
730 set subName [mapName ${name}_s]
731 lappend l "\tif ($func (o, (Odr_fun) $inf(fprefix)$subName, &(*p)->[lindex $numName 1],"
732 lappend l "\t\t&(*p)->[lindex $numName 0], name))"
733 lappend j "\t$inf(vprefix)$subName **[lindex $numName 1];"
734 asnSub $subName $t {} {} 0 {}
738 lappend l "\t\treturn 1;"
739 lappend l "\tif(o->direction == ODR_DECODE)"
740 lappend l "\t\t*p = 0;"
741 lappend l "\treturn odr_missing(o, opt, name);"
742 return [list [join $l \n] [join $j \n]]
745 # asnArm: parses c-list in choice
746 proc asnArm {name defname lx jx} {
752 set pq [asnName $name]
755 if {![string length $q]} {
759 asnMod ltag limplicit ltagtype
762 lappend enums "$inf(dprefix)$p"
763 if {![string compare $t Simple]} {
765 if {![string length $ltag]} {
766 lappend l "\t\t\{-1, -1, -1, $inf(dprefix)$p,"
767 lappend l "\t\t (Odr_fun) [lindex $tname 0], \"$q\"\},"
768 } elseif {$limplicit} {
769 lappend l "\t\t\{ODR_IMPLICIT, $ltagtype, $ltag, $inf(dprefix)$p,"
770 lappend l "\t\t(Odr_fun) [lindex $tname 0], \"$q\"\},"
772 lappend l "\t\t\{ODR_EXPLICIT, $ltagtype, $ltag, $inf(dprefix)$p,"
773 lappend l "\t\t(Odr_fun) [lindex $tname 0], \"$q\"\},"
775 lappend j "\t\t[lindex $tname 1] *$q;"
777 set subName [mapName ${name}_$q]
778 if {![string compare $inf(dprefix)${name}_$q \
779 $inf(vprefix)$subName]} {
780 set po [string toupper [string index $q 0]][string \
782 set subName [mapName ${name}${po}]
784 asnSub $subName $t $tname {} 0 {}
785 if {![string length $ltag]} {
786 lappend l "\t\t\{-1, -1, -1, $inf(dprefix)$p,"
787 lappend l "\t\t (Odr_fun) $inf(fprefix)$subName, \"$q\"\},"
788 } elseif {$limplicit} {
789 lappend l "\t\t\{ODR_IMPLICIT, $ltagtype, $ltag, $inf(dprefix)$p,"
790 lappend l "\t\t(Odr_fun) $inf(fprefix)$subName, \"$q\"\},"
792 lappend l "\t\t\{ODR_EXPLICIT, $ltagtype, $ltag, $inf(dprefix)$p,"
793 lappend l "\t\t(Odr_fun) $inf(fprefix)$subName, \"$q\"\},"
795 lappend j "\t\t$inf(vprefix)$subName *$q;"
797 if {[string compare $type ,]} break
799 if {[string compare $type \}]} {
800 asnError "Missing \} got $type '$val'"
805 lappend j "#define $e $level"
808 lappend l "\t\t\{-1, -1, -1, -1, (Odr_fun) 0, 0\}"
811 # asnChoice: parses "CHOICE {c-list}" and generates C code.
813 # $name is the type we are defining
818 proc asnChoice {name tag implicit tagtype} {
821 if {[info exists inf(unionmap,$inf(module),$name)]} {
822 set uName $inf(unionmap,$inf(module),$name)
824 set uName [list which u $name]
827 lappend j "struct $inf(vprefix)$name \{"
828 lappend j "\tint [lindex $uName 0];"
829 lappend j "\tunion \{"
830 lappend l "\tstatic Odr_arm arm\[\] = \{"
831 asnArm $name [lindex $uName 2] l j
832 lappend j "\t\} [lindex $uName 1];"
835 if {![string length $tag]} {
836 lappend l "\tif (!odr_initmember(o, p, sizeof(**p)))"
837 lappend l "\t\treturn odr_missing(o, opt, name);"
838 lappend l "\tif (odr_choice(o, arm, &(*p)->[lindex $uName 1], &(*p)->[lindex $uName 0], name))"
839 } elseif {$implicit} {
840 lappend l "\tif (!odr_initmember(o, p, sizeof(**p)))"
841 lappend l "\t\treturn odr_missing(o, opt, name);"
842 lappend l "\todr_implicit_settag(o, $tagtype, $tag);"
843 lappend l "\tif (odr_choice(o, arm, &(*p)->[lindex $uName 1], &(*p)->[lindex $uName 0], name))"
845 lappend l "\tif (!odr_constructed_begin(o, p, $tagtype, $tag, 0))"
846 lappend l "\t\treturn odr_missing(o, opt, name);"
847 lappend l "\tif (!odr_initmember(o, p, sizeof(**p)))"
848 lappend l "\t\treturn odr_missing(o, opt, name);"
849 lappend l "\tif (odr_choice(o, arm, &(*p)->[lindex $uName 1], &(*p)->[lindex $uName 0], name) &&"
850 lappend l "\t\todr_constructed_end(o))"
852 lappend l "\t\treturn 1;"
854 lappend l "\tif(o->direction == ODR_DECODE)"
855 lappend l "\t\t*p = 0;"
857 lappend l "\treturn odr_missing(o, opt, name);"
858 return [list [join $l \n] [join $j \n]]
861 # asnImports: parses i-list in "IMPORTS {i-list}"
862 # On return inf(import,..)-array is updated.
863 # inf(import,"module") is a list of {C-handler, C-type} elements.
864 # The {C-handler, C-type} is compatible with the $tname as is used by the
865 # asnType procedure to solve external references.
867 global type val inf file
870 if {[string compare $type n]} {
871 asnError "Missing name in IMPORTS list"
875 if {![string compare $type n] && ![string compare $val FROM]} {
878 if {[info exists inf(filename,$val)]} {
879 set fname $inf(filename,$val)
883 puts $file(outh) "\#include <$inf(h-dir)${fname}.h>"
885 if {[info exists inf(prefix,$val)]} {
886 set prefix $inf(prefix,$val)
888 set prefix $inf(prefix)
891 if {[info exists inf(map,$val,$n)]} {
892 set v $inf(map,$val,$n)
896 set w [join [split $v -] _]
897 set inf(imports,$n) [list [lindex $prefix 0]$w \
898 [lindex $prefix 1]$w]
902 if {[string compare $type n]} break
903 } elseif {![string compare $type ,]} {
907 if {[string compare $type \;]} {
908 asnError "Missing ; after IMPORTS list - got $type '$val'"
913 # asnExports: parses e-list in "EXPORTS {e-list}"
914 # This function does nothing with elements in the list.
919 if {[string compare $type n]} {
920 asnError "Missing name in EXPORTS list"
922 set inf(exports,$val) 1
924 if {[string compare $type ,]} break
927 if {[string compare $type \;]} {
928 asnError "Missing ; after EXPORTS list - got $type ($val)"
933 # asnModuleBody: parses a module specification and generates C code.
934 # Exports lists, imports lists, and type definitions are handled;
935 # other things are silently ignored.
936 proc asnModuleBody {} {
937 global type val file inf
939 if {[info exists inf(prefix,$inf(module))]} {
940 set prefix $inf(prefix,$inf(module))
942 set prefix $inf(prefix)
944 set inf(fprefix) [lindex $prefix 0]
945 set inf(vprefix) [lindex $prefix 1]
946 set inf(dprefix) [lindex $prefix 2]
947 if {[llength $prefix] > 3} {
948 set inf(cprefix) [lindex $prefix 3]
950 set inf(cprefix) {YAZ_EXPORT }
954 puts "Module $inf(module), $inf(lineno)"
958 if {[info exists inf(init,$inf(module),c)]} {
959 puts $file(outc) $inf(init,$inf(module),c)
961 if {[info exists inf(init,$inf(module),h)]} {
962 puts $file(outh) "\#ifdef __cplusplus"
963 puts $file(outh) "extern \"C\" \{"
964 puts $file(outh) "\#endif"
966 puts $file(outh) $inf(init,$inf(module),h)
968 if {[info exists inf(init,$inf(module),p)]} {
969 puts $file(outp) $inf(init,$inf(module),p)
972 while {[string length $type]} {
973 if {[string compare $type n]} {
977 if {![string compare $val END]} {
979 } elseif {![string compare $val EXPORTS]} {
982 } elseif {![string compare $val IMPORTS]} {
984 puts $file(outh) "\#ifdef __cplusplus"
985 puts $file(outh) "\}"
986 puts $file(outh) "\#endif"
993 puts $file(outh) "\#ifdef __cplusplus"
994 puts $file(outh) "extern \"C\" \{"
995 puts $file(outh) "\#endif"
998 set inf(asndef) $inf(nodef)
1001 if {![string compare $type :]} {
1005 } elseif {![string compare $type n]} {
1007 if {[string length $type]} {
1014 puts $file(outh) "\#ifdef __cplusplus"
1015 puts $file(outh) "\}"
1016 puts $file(outh) "\#endif"
1019 foreach x [array names inf imports,*] {
1024 # asnTagDefault: parses TagDefault section
1025 proc asnTagDefault {} {
1026 global type val inf file
1028 set inf(implicit-tags) 0
1029 while {[string length $type]} {
1030 if {[lex-name-move EXPLICIT]} {
1032 set inf(implicit-tags) 0
1033 } elseif {[lex-name-move IMPLICIT]} {
1035 set inf(implicit-tags) 1
1042 # asnModules: parses a collection of module specifications.
1043 # Depending on the module pattern, $inf(moduleP), a module is either
1044 # skipped or processed.
1045 proc asnModules {} {
1046 global type val inf file yc_version
1051 while {![string compare $type n]} {
1052 set inf(module) $val
1053 if {[info exists inf(moduleP)] && ![string match $inf(moduleP) $val]} {
1054 if {$inf(verbose)} {
1057 while {![lex-name-move END]} {
1064 while {![lex-name-move DEFINITIONS]} {
1066 if {![string length $type]} return
1068 if {[info exists inf(filename,$inf(module))]} {
1069 set fname $inf(filename,$inf(module))
1071 set fname $inf(module)
1073 set ppname [join [split $fname -] _]
1075 if {![info exists inf(c-file)]} {
1076 set inf(c-file) ${fname}.c
1078 set file(outc) [open $inf(c-file) w]
1080 if {![info exists inf(h-file)]} {
1081 set inf(h-file) ${fname}.h
1083 set file(outh) [open $inf(h-path)/$inf(h-dir)$inf(h-file) w]
1086 if {![info exists inf(p-file)]} {
1087 set inf(p-file) ${fname}-p.h
1089 set file(outp) [open $inf(h-path)/$inf(h-dir)$inf(p-file) w]
1092 set greeting {Generated automatically by YAZ ASN.1 Compiler}
1094 puts $file(outc) "/** \\file $inf(c-file)"
1095 puts $file(outc) " \\brief ASN.1 Module $inf(module)"
1097 puts $file(outc) " ${greeting} ${yc_version}"
1098 puts $file(outc) "*/"
1101 puts $file(outh) "/** \\file $inf(h-file)"
1102 puts $file(outh) " \\brief ASN.1 Module $inf(module)"
1104 puts $file(outh) " ${greeting} ${yc_version}"
1105 puts $file(outh) "*/"
1108 if {[info exists file(outp)]} {
1109 puts $file(outp) "/** \\file $inf(p-file)"
1110 puts $file(outp) " \\brief ASN.1 Module $inf(module)"
1112 puts $file(outp) " ${greeting} ${yc_version}"
1113 puts $file(outp) "*/"
1117 if {[info exists inf(p-file)]} {
1118 puts $file(outc) "\#include <$inf(h-dir)$inf(p-file)>"
1120 puts $file(outc) "\#include <$inf(h-dir)$inf(h-file)>"
1122 puts $file(outh) "\#ifndef ${ppname}_H"
1123 puts $file(outh) "\#define ${ppname}_H"
1125 puts $file(outh) "\#include <yaz/odr.h>"
1127 if {[info exists file(outp)]} {
1128 puts $file(outp) "\#ifndef ${ppname}_P_H"
1129 puts $file(outp) "\#define ${ppname}_P_H"
1131 puts $file(outp) "\#include <$inf(h-dir)$inf(h-file)>"
1136 if {[string compare $type :]} {
1137 asnError "::= expected got $type '$val'"
1140 if {![lex-name-move BEGIN]} {
1141 asnError "BEGIN expected"
1146 if {[info exists file(outp)]} {
1151 puts $f "\#ifdef __cplusplus"
1152 puts $f "extern \"C\" \{"
1154 for {set i 1} {$i < $inf(nodef)} {incr i} {
1155 puts $f $inf(var,$i)
1156 if {[info exists inf(asn,$i)]} {
1159 foreach comment $inf(asn,$i) {
1169 puts $f "\#ifdef __cplusplus"
1173 if {[info exists inf(body,$inf(module),h)]} {
1174 puts $file(outh) $inf(body,$inf(module),h)
1176 if {[info exists inf(body,$inf(module),c)]} {
1177 puts $file(outc) $inf(body,$inf(module),c)
1179 if {[info exists inf(body,$inf(module),p)]} {
1180 if {[info exists file(outp)]} {
1181 puts $file(outp) $inf(body,$inf(module),p)
1184 puts $file(outh) "\#endif"
1185 if {[info exists file(outp)]} {
1186 puts $file(outp) "\#endif"
1188 foreach f [array names file] {
1193 catch {unset inf(p-file)}
1198 # asnFile: parses an ASN.1 specification file as specified in $inf(iname).
1202 if {$inf(verbose) > 1} {
1203 puts "Reading ASN.1 file $inf(iname)"
1207 set inf(inf) [open $inf(iname) r]
1213 # The following procedures are invoked by the asnType function.
1214 # Each procedure takes the form: asnBasic<TYPE> and they must return
1215 # two elements: the C function handler and the C type.
1216 # On entry upvar $name is the type we are defining and global, $inf(module), is
1217 # the current module name.
1219 proc asnBasicEXTERNAL {} {
1220 return {odr_external {Odr_external}}
1223 proc asnBasicINTEGER {} {
1224 return {odr_integer {int}}
1227 proc asnBasicENUMERATED {} {
1228 return {odr_enum {int}}
1231 proc asnBasicNULL {} {
1232 return {odr_null {Odr_null}}
1235 proc asnBasicBOOLEAN {} {
1236 return {odr_bool {bool_t}}
1239 proc asnBasicOCTET {} {
1241 lex-name-move STRING
1242 return {odr_octetstring {Odr_oct}}
1245 proc asnBasicBIT {} {
1247 lex-name-move STRING
1248 return {odr_bitstring {Odr_bitmask}}
1251 proc asnBasicOBJECT {} {
1253 lex-name-move IDENTIFIER
1254 return {odr_oid {Odr_oid}}
1257 proc asnBasicGeneralString {} {
1258 return {odr_generalstring char}
1261 proc asnBasicVisibleString {} {
1262 return {odr_visiblestring char}
1265 proc asnBasicGeneralizedTime {} {
1266 return {odr_generalizedtime char}
1269 proc asnBasicANY {} {
1272 return [list $inf(fprefix)ANY_$name void]
1275 # userDef: reads user definitions file $name
1276 proc userDef {name} {
1279 if {$inf(verbose) > 1} {
1280 puts "Reading definitions file $name"
1284 if {[info exists default-prefix]} {
1285 set inf(prefix) ${default-prefix}
1287 if {[info exists h-path]} {
1288 set inf(h-path) ${h-path}
1290 foreach m [array names prefix] {
1291 set inf(prefix,$m) $prefix($m)
1293 foreach m [array names body] {
1294 set inf(body,$m) $body($m)
1296 foreach m [array names init] {
1297 set inf(init,$m) $init($m)
1299 foreach m [array names filename] {
1300 set inf(filename,$m) $filename($m)
1302 foreach m [array names map] {
1303 set inf(map,$m) $map($m)
1305 foreach m [array names membermap] {
1306 set inf(membermap,$m) $membermap($m)
1308 foreach m [array names unionmap] {
1309 set inf(unionmap,$m) $unionmap($m)
1314 set inf(prefix) {yc_ Yc_ YC_}
1318 # Parse command line
1319 set l [llength $argv]
1322 set arg [lindex $argv $i]
1323 switch -glob -- $arg {
1328 set p [string range $arg 2 end]
1329 if {![string length $p]} {
1330 set p [lindex $argv [incr i]]
1335 set p [string range $arg 2 end]
1336 if {![string length $p]} {
1337 set p [lindex $argv [incr i]]
1342 set p [string range $arg 2 end]
1343 if {![string length $p]} {
1344 set p [lindex $argv [incr i]]
1346 set inf(h-dir) [string trim $p \\/]/
1349 set p [string range $arg 2 end]
1350 if {![string length $p]} {
1351 set p [lindex $argv [incr i]]
1356 set p [string range $arg 2 end]
1357 if {![string length $p]} {
1358 set p [lindex $argv [incr i]]
1363 set p [string range $arg 2 end]
1364 if {![string length $p]} {
1365 set p [lindex $argv [incr i]]
1370 set p [string range $arg 2 end]
1371 if {![string length $p]} {
1372 set p [lindex $argv [incr i]]
1377 set p [string range $arg 2 end]
1378 if {![string length $p]} {
1379 set p [lindex $argv [incr i]]
1381 if {[llength $p] == 1} {
1382 set inf(prefix) [list [string tolower $p] \
1383 [string toupper $p] [string toupper $p]]
1384 } elseif {[llength $p] == 3} {
1398 if {![info exists inf(iname)]} {
1399 puts "YAZ ASN.1 Compiler ${yc_version}"
1401 puts -nonewline ${argv0}
1402 puts { [-v] [-c cfile] [-h hfile] [-p hfile] [-d dfile] [-I iout]}
1403 puts { [-i idir] [-m module] file}