2 # the next line restarts using tclsh \
5 # YC: ASN.1 Compiler for YAZ
6 # (c) Index Data 1996-2000
7 # See the file LICENSE for details.
10 # Revision 1.5 2000-01-15 09:18:42 adam
11 # Bug fix: some elements where treated as OPTIONAL when they shouldn't.
13 # Revision 1.4 1999/12/16 23:36:19 adam
14 # Implemented ILL protocol. Minor updates ASN.1 compiler.
16 # Revision 1.3 1999/11/30 13:47:12 adam
17 # Improved installation. Moved header files to include/yaz.
19 # Revision 1.2 1999/06/09 09:43:11 adam
20 # Added option -I and variable h-path to specify path for header files.
22 # Revision 1.1 1999/06/08 10:10:16 adam
23 # New sub directory zutil. Moved YAZ Compiler to be part of YAZ tree.
25 # Revision 1.8 1999/04/20 10:37:04 adam
26 # Updated for ODR - added name parameter.
28 # Revision 1.7 1998/04/03 14:44:20 adam
31 # Revision 1.6 1998/04/03 13:21:17 adam
34 # Revision 1.5 1998/04/03 12:48:17 adam
35 # Fixed bug: missed handling of constructed tags for CHOICE.
37 # Revision 1.4 1998/03/31 15:47:45 adam
38 # First compiled ASN.1 code for YAZ.
40 # Revision 1.3 1998/03/23 17:13:20 adam
41 # Implemented SET OF and ENUM. The Compiler now eats ILL (ISO10161) and
44 # Revision 1.2 1997/10/07 10:31:01 adam
45 # Added facility to specify tag type (CONTEXT, APPLICATION, ...).
47 # Revision 1.1.1.1 1996/10/31 14:04:40 adam
48 # First version of the compiler for YAZ.
54 # Syntax for the ASN.1 supported:
57 # module -> name skip DEFINITIONS ::= mbody END
58 # mbody -> EXPORTS { nlist }
59 # | IMPORTS { imlist }
63 # type -> SEQUENCE { sqlist }
74 # sqlist -> sqlist , name tmt opt
76 # chlist -> chlist , name tmt
78 # enlist -> enlist , name (n)
80 # imlist -> nlist FROM name
81 # imlist nlist FROM name
84 # mod -> IMPLICIT | EXPLICIT | e
85 # tag -> [tagtype n] | [n] | e
88 # name identifier/token
90 # skip one token skipped
92 # tagtype APPLICATION, CONTEXT, etc.
94 # lex: moves input file pointer and returns type of token.
95 # The globals $type and $val are set. $val holds name if token
96 # is normal identifier name.
97 # sets global var type to one of:
100 # \} right curly brace
109 while {![string length $inf(str)]} {
111 set inf(cnt) [gets $inf(inf) inf(str)]
116 lappend inf(asn,$inf(asndef)) $inf(str)
117 set l [string first -- $inf(str)]
120 set inf(str) [string range $inf(str) 0 $l]
122 set inf(str) [string trim $inf(str)]
124 set s [string index $inf(str) 0]
134 \[ { regexp {^\[[ ]*(.+)[ ]*\]} $inf(str) s val }
135 : { regexp {^::=} $inf(str) s }
137 regexp "^\[^,\t :\{\}();\]+" $inf(str) s
142 set off [string length $s]
143 set inf(str) [string trim [string range $inf(str) $off end]]
147 # lex-expect: move pointer and expect token $t
148 proc lex-expect {t} {
151 if {[string compare $t $type]} {
152 asnError "Got $type '$val', expected $t"
156 # lex-name-move: see if token is $name; moves pointer and returns
157 # 1 if it is; returns 0 otherwise.
158 proc lex-name-move {name} {
160 if {![string compare $type n] && ![string compare $val $name]} {
167 # asnError: Report error and die
168 proc asnError {msg} {
171 puts "Error in line $inf(lineno) in module $inf(module)"
177 # asnWarning: Report warning and return
178 proc asnWarning {msg} {
181 puts "Warning in line $inf(lineno) in module $inf(module)"
185 # asnEnum: parses enumerated list - { name1 (n), name2 (n), ... }
186 # Uses $name as prefix. If there really is a list, $lx holds the C
187 # preprocessor definitions on return; otherwise lx isn't set.
188 proc asnEnum {name lx} {
191 if {[string compare $type \{]} return
194 set pq [asnName $name]
195 set id [lindex $pq 0]
198 lappend l "#define $inf(dprefix)$id $val"
201 if {[string compare $type ,]} break
203 if {[string compare $type \}]} {
204 asnError "Missing \} in enum list got $type '$val'"
209 # asnMod: parses tag and modifier.
210 # $xtag and $ximplicit holds tag and implicit-indication on return.
211 # $xtag is empty if no tag was specified. $ximplicit is 1 on implicit
212 # tagging; 0 otherwise.
213 proc asnMod {xtag ximplicit xtagtype} {
217 upvar $ximplicit implicit
218 upvar $xtagtype tagtype
222 if {![string compare $type \[]} {
223 if {[regexp {^([a-zA-Z]+)[ ]+([0-9]+)$} $val x tagtype tag]} {
224 set tagtype ODR_$tagtype
225 } elseif {[regexp {^([0-9]+)$} $val x tag]} {
226 set tagtype ODR_CONTEXT
228 asnError "bad tag specification: $val"
232 set implicit $inf(implicit-tags)
233 if {![string compare $type n]} {
234 if {![string compare $val EXPLICIT]} {
237 } elseif {![string compare $val IMPLICIT]} {
244 # asnName: moves pointer and expects name. Returns C-validated name.
245 proc asnName {name} {
248 if {[info exists inf(membermap,$inf(module),$name,$val)]} {
249 set nval $inf(membermap,$inf(module),$name,$val)
251 puts " mapping member $name,$val to $nval"
256 if {![string match {[A-Z]*} $val]} {
260 return [join [split $nval -] _]
263 # asnOptional: parses optional modifier. Returns 1 if OPTIONAL was
264 # specified; 0 otherwise.
265 proc asnOptional {} {
267 if {[lex-name-move OPTIONAL]} {
269 } elseif {[lex-name-move DEFAULT]} {
276 # asnSizeConstraint: parses the optional SizeConstraint.
277 # Currently not used for anything.
278 proc asnSizeConstraint {} {
280 if {[lex-name-move SIZE]} {
285 # asnSubtypeSpec: parses the SubtypeSpec ...
286 # Currently not used for anything. We now it's balanced however, i.e.
288 proc asnSubtypeSpec {} {
291 if {[string compare $type "("]} {
297 if {![string compare $type "("]} {
299 } elseif {![string compare $type ")"]} {
306 # asnType: parses ASN.1 type.
307 # On entry $name should hold the name we are currently defining.
308 # Returns type indicator:
309 # SequenceOf SEQUENCE OF
314 # Simple Basic types.
315 # In this casecalling procedure's $tname variable is a list holding:
316 # {C-Function C-Type} if the type is IMPORTed or ODR defined.
318 # {C-Function C-Type 1} if the type should be defined in this module
319 proc asnType {name} {
324 if {[string compare $type n]} {
325 asnError "Expects type specifier, but got $type"
332 if {[lex-name-move OF]} {
342 if {[lex-name-move OF]} {
355 if {[string length [info commands asnBasic$v]]} {
356 set tname [asnBasic$v]
358 if {[info exists inf(map,$inf(module),$v)]} {
359 set v $inf(map,$inf(module),$v)
361 if {[info exists inf(imports,$v)]} {
362 set tname $inf(imports,$v)
364 set w [join [split $v -] _]
365 set tname [list $inf(fprefix)$w $inf(vprefix)$w 1]
368 if {[lex-name-move DEFINED]} {
369 if {[lex-name-move BY]} {
377 proc mapName {name} {
379 if {[info exists inf(map,$inf(module),$name)]} {
380 set name $inf(map,$inf(module),$name)
382 puts -nonewline " $name ($inf(lineno))"
383 puts " mapping to $name"
387 puts " $name ($inf(lineno))"
393 # asnDef: parses type definition (top-level) and generates C code
394 # On entry $name holds the type we are defining.
398 set name [mapName $name]
399 if {[info exist inf(defined,$inf(fprefix)$name)]} {
400 incr inf(definedl,$name)
401 if {$inf(verbose) > 1} {
402 puts "set map($inf(module),$name) $name$inf(definedl,$name)"
405 set inf(definedl,$name) 0
407 set mname [join [split $name -] _]
408 asnMod tag implicit tagtype
409 set t [asnType $mname]
410 asnSub $mname $t $tname $tag $implicit $tagtype
414 # asnSub: parses type and generates C-code
416 # $name holds the type we are defining.
417 # $t is the type returned by the asnType procedure.
418 # $tname is the $tname set by the asnType procedure.
419 # $tag is the tag as returned by asnMod
420 # $implicit is the implicit indicator as returned by asnMod
421 proc asnSub {name t tname tag implicit tagtype} {
425 set defname defined,$inf(fprefix)$name
426 if {[info exist inf($defname)]} {
427 asnWarning "$name already defined in line $inf($defname)"
430 set inf($defname) $inf(lineno)
432 Sequence { set l [asnSequence $name $tag $implicit $tagtype] }
433 SequenceOf { set l [asnOf $name $tag $implicit $tagtype 0] }
434 SetOf { set l [asnOf $name $tag $implicit $tagtype 1] }
435 Choice { set l [asnChoice $name $tag $implicit $tagtype] }
436 Simple { set l [asnSimple $name $tname $tag $implicit $tagtype] }
437 default { asnError "switch asnType case not handled" }
442 puts $file(outc) "int $inf(fprefix)$name (ODR o, $inf(vprefix)$name **p, int opt, const char *name)"
444 puts $file(outc) [lindex $l 0]
447 set fdef "$inf(cprefix)int $inf(fprefix)$name (ODR o, $inf(vprefix)$name **p, int opt, const char *name);"
450 set decl "typedef [lindex $l 1] $inf(vprefix)$name;"
451 if {![string compare [lindex $tname 2] 1]} {
452 if {![info exist inf(defined,[lindex $tname 0])]} {
456 set inf(var,$inf(nodef)) [join [lindex $l 2] \n]
460 set decl "typedef struct $inf(vprefix)$name $inf(vprefix)$name;"
461 set inf(var,$inf(nodef)) "[lindex $l 1];"
467 puts $file(outh) $decl
468 puts $file(outh) $fdef
469 asnForwardTypes $name
471 lappend inf(forward,code,[lindex $tname 0]) {} $decl $fdef
472 lappend inf(forward,ref,[lindex $tname 0]) $name
476 proc asnForwardTypes {name} {
479 if {![info exists inf(forward,code,$inf(fprefix)$name)]} {
482 foreach r $inf(forward,code,$inf(fprefix)$name) {
485 unset inf(forward,code,$inf(fprefix)$name)
487 while {[info exists inf(forward,ref,$inf(fprefix)$name)]} {
488 set n $inf(forward,ref,$inf(fprefix)$name)
489 set m [lrange $n 1 end]
491 set inf(forward,ref,$inf(fprefix)$name) $m
493 unset inf(forward,ref,$inf(fprefix)$name)
495 asnForwardTypes [lindex $n 0]
499 # asnSimple: parses simple type definition and generates C code
501 # $name is the name we are defining
502 # $tname is the tname as returned by asnType
503 # $tag is the tag as returned by asnMod
504 # $implicit is the implicit indicator as returned by asnMod
507 # Note: Doesn't take care of enum lists yet.
508 proc asnSimple {name tname tag implicit tagtype} {
511 set j "[lindex $tname 1] "
513 if {[info exists inf(unionmap,$inf(module),$name)]} {
514 set uName $inf(unionmap,$inf(module),$name)
520 if {![string length $tag]} {
521 set l "\treturn [lindex $tname 0] (o, p, opt, name);"
522 } elseif {$implicit} {
524 "\treturn odr_implicit_tag (o, [lindex $tname 0], p, $tagtype, $tag, opt, name);"
527 "\treturn odr_explicit_tag (o, [lindex $tname 0], p, $tagtype, $tag, opt, name);" \
529 if {[info exists jj]} {
530 return [list $l $j $jj]
536 # asnSequence: parses "SEQUENCE { s-list }" and generates C code.
538 # $name is the type we are defining
543 proc asnSequence {name tag implicit tagtype} {
546 lappend j "struct $inf(vprefix)$name \{"
549 if {![string length $tag]} {
550 lappend l "\tif (!odr_sequence_begin (o, p, sizeof(**p), name))"
551 lappend l "\t\treturn opt && odr_ok (o);"
552 } elseif {$implicit} {
553 lappend l "\tif (!odr_implicit_settag (o, $tagtype, $tag) ||"
554 lappend l "\t\t!odr_sequence_begin (o, p, sizeof(**p), name))"
555 lappend l "\t\treturn opt && odr_ok(o);"
557 lappend l "\tif (!odr_constructed_begin (o, p, $tagtype, $tag, name))"
558 lappend l "\t\treturn opt && odr_ok(o);"
559 lappend l "\tif (o->direction == ODR_DECODE)"
560 lappend l "\t\t*p = odr_malloc (o, sizeof(**p));"
562 lappend l "\tif (!odr_sequence_begin (o, p, sizeof(**p), 0))"
564 lappend l "\t\t*p = 0;"
565 lappend l "\t\treturn 0;"
570 set p [lindex [asnName $name] 0]
571 asnMod ltag limplicit ltagtype
575 if {[info exists inf(unionmap,$inf(module),$name,$p)]} {
576 set uName $inf(unionmap,$inf(module),$name,$p)
579 if {![string compare $t Simple]} {
580 if {[string compare $uName { }]} {
586 set opt [asnOptional]
587 if {![string length $ltag]} {
588 lappend l "\t\t[lindex $tname 0](o, &(*p)->$p, $opt, \"$p\") &&"
589 } elseif {$limplicit} {
590 lappend l "\t\todr_implicit_tag (o, [lindex $tname 0],"
591 lappend l "\t\t\t&(*p)->$p, $ltagtype, $ltag, $opt, \"$p\") &&"
593 lappend l "\t\todr_explicit_tag (o, [lindex $tname 0],"
594 lappend l "\t\t\t&(*p)->$p, $ltagtype, $ltag, $opt, \"$p\") &&"
596 set dec "\t[lindex $tname 1] *$p;"
597 } elseif {![string compare $t SequenceOf] && [string length $uName] &&\
598 (![string length $ltag] || $limplicit)} {
601 if {[llength $uName] < 2} {
602 set uName [list num_$p $p]
604 if {[string length $ltag]} {
608 lappend l "\t\todr_implicit_settag (o, $ltagtype, $ltag) &&"
613 set tmpa "odr_sequence_of(o, (Odr_fun) [lindex $tname 0], &(*p)->$p,"
614 set tmpb "&(*p)->[lindex $uName 0], \"$p\")"
615 lappend j "\tint [lindex $uName 0];"
616 set dec "\t[lindex $tname 1] **[lindex $uName 1];"
619 set subName [mapName ${name}_$level]
620 asnSub $subName $u {} {} 0 {}
622 set tmpa "odr_sequence_of(o, (Odr_fun) $inf(fprefix)$subName, &(*p)->$p,"
623 set tmpb "&(*p)->[lindex $uName 0], \"$p\")"
624 lappend j "\tint [lindex $uName 0];"
625 set dec "\t$inf(vprefix)$subName **[lindex $uName 1];"
629 set opt [asnOptional]
631 lappend l "\t\t($tmpa"
632 lappend l "\t\t $tmpb || odr_ok(o)) &&"
634 lappend l "\t\t$tmpa"
635 lappend l "\t\t $tmpb &&"
637 } elseif {!$nchoice && ![string compare $t Choice] && \
638 [string length $uName]} {
639 if {[llength $uName] < 3} {
640 set uName [list which u $name]
643 lappend j "\tint [lindex $uName 0];"
644 lappend j "\tunion \{"
645 lappend v "\tstatic Odr_arm arm\[\] = \{"
646 asnArm $name [lindex $uName 2] v j
648 set dec "\t\} [lindex $uName 1];"
649 set opt [asnOptional]
652 if {[string length $ltag]} {
654 lappend l "\t\todr_implicit_settag (o, $ltagtype, $ltag) &&"
656 asnWarning "optional handling missing in CHOICE in SEQUENCE"
657 asnWarning " set unionmap($inf(module),$name,$p) to {}"
665 lappend l "\t\t${la}odr_constructed_begin (o, &(*p)->[lindex $uName 1], $ltagtype, $ltag, \"$p\") &&"
670 set ob " || odr_ok(o))"
673 lappend l "\t\t${oa}odr_choice (o, arm, &(*p)->[lindex $uName 1], &(*p)->[lindex $uName 0], 0)${ob} &&"
674 if {[string length $ltag]} {
677 set lb ") || odr_ok(o))"
681 lappend l "\t\todr_constructed_end (o)${lb} &&"
685 set subName [mapName ${name}_$level]
686 asnSub $subName $t {} {} 0 {}
687 set opt [asnOptional]
688 if {![string length $ltag]} {
689 lappend l "\t\t$inf(fprefix)${subName} (o, &(*p)->$p, $opt, \"$p\") &&"
690 } elseif {$limplicit} {
691 lappend l "\t\todr_implicit_tag (o, $inf(fprefix)${subName},"
692 lappend l "\t\t\t&(*p)->$p, $ltagtype, $ltag, $opt, \"$p\") &&"
694 lappend l "\t\todr_explicit_tag (o, $inf(fprefix)${subName},"
695 lappend l "\t\t\t&(*p)->$p, $ltagtype, $ltag, $opt, \"$p\") &&"
697 set dec "\t$inf(vprefix)${subName} *$p;"
701 lappend j "$dec /* OPT */"
705 if {[string compare $type ,]} break
708 if {[string length $tag] && !$implicit} {
709 lappend l "\t\todr_sequence_end (o) &&"
710 lappend l "\t\todr_constructed_end (o);"
712 lappend l "\t\todr_sequence_end (o);"
714 if {[string compare $type \}]} {
715 asnError "Missing \} got $type '$val'"
718 if {[info exists v]} {
721 return [list [join $l \n] [join $j \n]]
724 # asnOf: parses "SEQUENCE/SET OF type" and generates C code.
726 # $name is the type we are defining
731 proc asnOf {name tag implicit tagtype isset} {
737 set func odr_sequence_of
740 if {[info exists inf(unionmap,$inf(module),$name)]} {
741 set numName $inf(unionmap,$inf(module),$name)
743 set numName {num elements}
746 lappend j "struct $inf(vprefix)$name \{"
747 lappend j "\tint [lindex $numName 0];"
749 lappend l "\tif (!odr_initmember (o, p, sizeof(**p)))"
750 lappend l "\t\treturn opt && odr_ok(o);"
751 if {[string length $tag]} {
753 lappend l "\todr_implicit_settag (o, $tagtype, $tag);"
755 asnWarning "Constructed SEQUENCE/SET OF not handled"
758 set t [asnType $name]
762 lappend l "\tif ($func (o, (Odr_fun) [lindex $tname 0], &(*p)->[lindex $numName 1],"
763 lappend l "\t\t&(*p)->[lindex $numName 0], name))"
764 lappend j "\t[lindex $tname 1] **[lindex $numName 1];"
767 set subName [mapName ${name}_s]
768 lappend l "\tif ($func (o, (Odr_fun) $inf(fprefix)$subName, &(*p)->[lindex $numName 1],"
769 lappend l "\t\t&(*p)->[lindex $numName 0], name))"
770 lappend j "\t$inf(vprefix)$subName **[lindex $numName 1];"
771 asnSub $subName $t {} {} 0 {}
775 lappend l "\t\treturn 1;"
776 lappend l "\t*p = 0;"
777 lappend l "\treturn opt && odr_ok(o);"
778 return [list [join $l \n] [join $j \n]]
781 # asnArm: parses c-list in choice
782 proc asnArm {name defname lx jx} {
788 set pq [asnName $name]
791 if {![string length $q]} {
795 asnMod ltag limplicit ltagtype
798 lappend enums "$inf(dprefix)$p"
799 if {![string compare $t Simple]} {
801 if {![string length $ltag]} {
802 lappend l "\t\t\{-1, -1, -1, $inf(dprefix)$p,"
803 lappend l "\t\t (Odr_fun) [lindex $tname 0], \"$q\"\},"
804 } elseif {$limplicit} {
805 lappend l "\t\t\{ODR_IMPLICIT, $ltagtype, $ltag, $inf(dprefix)$p,"
806 lappend l "\t\t(Odr_fun) [lindex $tname 0], \"$q\"\},"
808 lappend l "\t\t\{ODR_EXPLICIT, $ltagtype, $ltag, $inf(dprefix)$p,"
809 lappend l "\t\t(Odr_fun) [lindex $tname 0], \"$q\"\},"
811 lappend j "\t\t[lindex $tname 1] *$q;"
813 set subName [mapName ${name}_$q]
814 if {![string compare $inf(dprefix)${name}_$q \
815 $inf(vprefix)$subName]} {
816 set po [string toupper [string index $q 0]][string \
818 set subName [mapName ${name}${po}]
820 asnSub $subName $t $tname {} 0 {}
821 if {![string length $ltag]} {
822 lappend l "\t\t\{-1, -1, -1, $inf(dprefix)$p,"
823 lappend l "\t\t (Odr_fun) $inf(fprefix)$subName, \"$q\"\},"
824 } elseif {$limplicit} {
825 lappend l "\t\t\{ODR_IMPLICIT, $ltagtype, $ltag, $inf(dprefix)$p,"
826 lappend l "\t\t(Odr_fun) $inf(fprefix)$subName, \"$q\"\},"
828 lappend l "\t\t\{ODR_EXPLICIT, $ltagtype, $ltag, $inf(dprefix)$p,"
829 lappend l "\t\t(Odr_fun) $inf(fprefix)$subName, \"$q\"\},"
831 lappend j "\t\t$inf(vprefix)$subName *$q;"
833 if {[string compare $type ,]} break
835 if {[string compare $type \}]} {
836 asnError "Missing \} got $type '$val'"
841 lappend j "#define $e $level"
844 lappend l "\t\t\{-1, -1, -1, -1, (Odr_fun) 0, 0\}"
847 # asnChoice: parses "CHOICE {c-list}" and generates C code.
849 # $name is the type we are defining
854 proc asnChoice {name tag implicit tagtype} {
857 if {[info exists inf(unionmap,$inf(module),$name)]} {
858 set uName $inf(unionmap,$inf(module),$name)
860 set uName [list which u $name]
863 lappend j "struct $inf(vprefix)$name \{"
864 lappend j "\tint [lindex $uName 0];"
865 lappend j "\tunion \{"
866 lappend l "\tstatic Odr_arm arm\[\] = \{"
867 asnArm $name [lindex $uName 2] l j
868 lappend j "\t\} [lindex $uName 1];"
871 if {![string length $tag]} {
872 lappend l "\tif (!odr_initmember(o, p, sizeof(**p)))"
873 lappend l "\t\treturn opt && odr_ok(o);"
874 lappend l "\tif (odr_choice(o, arm, &(*p)->[lindex $uName 1], &(*p)->[lindex $uName 0], name))"
875 } elseif {$implicit} {
876 lappend l "\tif (!odr_initmember(o, p, sizeof(**p)))"
877 lappend l "\t\treturn opt && odr_ok(o);"
878 lappend l "\todr_implicit_settag(o, $tagtype, $tag);"
879 lappend l "\tif (odr_choice(o, arm, &(*p)->[lindex $uName 1], &(*p)->[lindex $uName 0], name))"
881 lappend l "\tif (!*p && o->direction != ODR_DECODE)"
882 lappend l "\t\treturn opt;"
883 lappend l "\tif (!odr_constructed_begin(o, p, $tagtype, $tag, 0))"
884 lappend l "\t\treturn opt && odr_ok(o);"
885 lappend l "\tif (!odr_initmember(o, p, sizeof(**p)))"
886 lappend l "\t\treturn opt && odr_ok(o);"
887 lappend l "\tif (odr_choice(o, arm, &(*p)->[lindex $uName 1], &(*p)->[lindex $uName 0], name) &&"
888 lappend l "\t\todr_constructed_end(o))"
890 lappend l "\t\treturn 1;"
891 lappend l "\t*p = 0;"
892 lappend l "\treturn opt && odr_ok(o);"
893 return [list [join $l \n] [join $j \n]]
896 # asnImports: parses i-list in "IMPORTS {i-list}"
897 # On return inf(import,..)-array is updated.
898 # inf(import,"module") is a list of {C-handler, C-type} elements.
899 # The {C-handler, C-type} is compatible with the $tname as is used by the
900 # asnType procedure to solve external references.
902 global type val inf file
905 if {[string compare $type n]} {
906 asnError "Missing name in IMPORTS list"
910 if {![string compare $type n] && ![string compare $val FROM]} {
913 if {[info exists inf(filename,$val)]} {
914 set fname $inf(filename,$val)
918 puts $file(outh) "\#include <$inf(h-dir)${fname}.h>"
920 if {[info exists inf(prefix,$val)]} {
921 set prefix $inf(prefix,$val)
923 set prefix $inf(prefix)
926 if {[info exists inf(map,$val,$n)]} {
927 set v $inf(map,$val,$n)
931 set w [join [split $v -] _]
932 set inf(imports,$n) [list [lindex $prefix 0]$w \
933 [lindex $prefix 1]$w]
937 if {[string compare $type n]} break
938 } elseif {![string compare $type ,]} {
942 if {[string compare $type \;]} {
943 asnError "Missing ; after IMPORTS list - got $type '$val'"
948 # asnExports: parses e-list in "EXPORTS {e-list}"
949 # This function does nothing with elements in the list.
954 if {[string compare $type n]} {
955 asnError "Missing name in EXPORTS list"
957 set inf(exports,$val) 1
959 if {[string compare $type ,]} break
962 if {[string compare $type \;]} {
963 asnError "Missing ; after EXPORTS list - got $type ($val)"
968 # asnModuleBody: parses a module specification and generates C code.
969 # Exports lists, imports lists, and type definitions are handled;
970 # other things are silently ignored.
971 proc asnModuleBody {} {
972 global type val file inf
974 if {[info exists inf(prefix,$inf(module))]} {
975 set prefix $inf(prefix,$inf(module))
977 set prefix $inf(prefix)
979 set inf(fprefix) [lindex $prefix 0]
980 set inf(vprefix) [lindex $prefix 1]
981 set inf(dprefix) [lindex $prefix 2]
982 if {[llength $prefix] > 3} {
983 set inf(cprefix) [lindex $prefix 3]
985 set inf(cprefix) {YAZ_EXPORT }
989 puts "Module $inf(module), $inf(lineno)"
993 if {[info exists inf(init,$inf(module),c)]} {
994 puts $file(outc) $inf(init,$inf(module),c)
996 if {[info exists inf(init,$inf(module),h)]} {
997 puts $file(outh) "\#ifdef __cplusplus"
998 puts $file(outh) "extern \"C\" \{"
999 puts $file(outh) "\#endif"
1001 puts $file(outh) $inf(init,$inf(module),h)
1003 if {[info exists inf(init,$inf(module),p)]} {
1004 puts $file(outp) $inf(init,$inf(module),p)
1007 while {[string length $type]} {
1008 if {[string compare $type n]} {
1012 if {![string compare $val END]} {
1014 } elseif {![string compare $val EXPORTS]} {
1017 } elseif {![string compare $val IMPORTS]} {
1019 puts $file(outh) "\#ifdef __cplusplus"
1020 puts $file(outh) "\}"
1021 puts $file(outh) "\#endif"
1028 puts $file(outh) "\#ifdef __cplusplus"
1029 puts $file(outh) "extern \"C\" \{"
1030 puts $file(outh) "\#endif"
1033 set inf(asndef) $inf(nodef)
1036 if {![string compare $type :]} {
1040 } elseif {![string compare $type n]} {
1042 if {[string length $type]} {
1049 puts $file(outh) "\#ifdef __cplusplus"
1050 puts $file(outh) "\}"
1051 puts $file(outh) "\#endif"
1054 foreach x [array names inf imports,*] {
1059 # asnTagDefault: parses TagDefault section
1060 proc asnTagDefault {} {
1061 global type val inf file
1063 set inf(implicit-tags) 0
1064 while {[string length $type]} {
1065 if {[lex-name-move EXPLICIT]} {
1067 set inf(implicit-tags) 0
1068 } elseif {[lex-name-move IMPLICIT]} {
1070 set inf(implicit-tags) 1
1077 # asnModules: parses a collection of module specifications.
1078 # Depending on the module pattern, $inf(moduleP), a module is either
1079 # skipped or processed.
1080 proc asnModules {} {
1081 global type val inf file yc_version
1086 while {![string compare $type n]} {
1087 set inf(module) $val
1088 if {[info exists inf(moduleP)] && ![string match $inf(moduleP) $val]} {
1089 if {$inf(verbose)} {
1092 while {![lex-name-move END]} {
1099 while {![lex-name-move DEFINITIONS]} {
1101 if {![string length $type]} return
1103 if {[info exists inf(filename,$inf(module))]} {
1104 set fname $inf(filename,$inf(module))
1106 set fname $inf(module)
1108 set ppname [join [split $fname -] _]
1110 if {![info exists inf(c-file)]} {
1111 set inf(c-file) ${fname}.c
1113 set file(outc) [open $inf(c-file) w]
1115 if {![info exists inf(h-file)]} {
1116 set inf(h-file) ${fname}.h
1118 set file(outh) [open $inf(h-path)/$inf(h-dir)$inf(h-file) w]
1121 if {![info exists inf(p-file)]} {
1122 set inf(p-file) ${fname}-p.h
1124 set file(outp) [open $inf(h-path)/$inf(h-dir)$inf(p-file) w]
1127 set md [clock format [clock seconds]]
1129 puts $file(outc) "/* YC ${yc_version} $md */"
1130 puts $file(outc) "/* Module-C: $inf(module) */"
1133 puts $file(outh) "/* YC ${yc_version}: $md */"
1134 puts $file(outh) "/* Module-H $inf(module) */"
1137 if {[info exists file(outp)]} {
1138 puts $file(outp) "/* YC ${yc_version}: $md */"
1139 puts $file(outp) "/* Module-P: $inf(module) */"
1143 if {[info exists inf(p-file)]} {
1144 puts $file(outc) "\#include <$inf(h-dir)$inf(p-file)>"
1146 puts $file(outc) "\#include <$inf(h-dir)$inf(h-file)>"
1148 puts $file(outh) "\#ifndef ${ppname}_H"
1149 puts $file(outh) "\#define ${ppname}_H"
1151 puts $file(outh) "\#include <$inf(h-dir)odr.h>"
1153 if {[info exists file(outp)]} {
1154 puts $file(outp) "\#ifndef ${ppname}_P_H"
1155 puts $file(outp) "\#define ${ppname}_P_H"
1157 puts $file(outp) "\#include <$inf(h-dir)$inf(h-file)>"
1162 if {[string compare $type :]} {
1163 asnError "::= expected got $type '$val'"
1166 if {![lex-name-move BEGIN]} {
1167 asnError "BEGIN expected"
1172 if {[info exists file(outp)]} {
1177 puts $f "\#ifdef __cplusplus"
1178 puts $f "extern \"C\" \{"
1180 for {set i 1} {$i < $inf(nodef)} {incr i} {
1181 puts $f $inf(var,$i)
1182 if {[info exists inf(asn,$i)]} {
1185 foreach comment $inf(asn,$i) {
1195 puts $f "\#ifdef __cplusplus"
1199 if {[info exists inf(body,$inf(module),h)]} {
1200 puts $file(outh) $inf(body,$inf(module),h)
1202 if {[info exists inf(body,$inf(module),c)]} {
1203 puts $file(outc) $inf(body,$inf(module),c)
1205 if {[info exists inf(body,$inf(module),p)]} {
1206 if {[info exists file(outp)]} {
1207 puts $file(outp) $inf(body,$inf(module),p)
1210 puts $file(outh) "\#endif"
1211 if {[info exists file(outp)]} {
1212 puts $file(outp) "\#endif"
1214 foreach f [array names file] {
1219 catch {unset inf(p-file)}
1224 # asnFile: parses an ASN.1 specification file as specified in $inf(iname).
1228 if {$inf(verbose) > 1} {
1229 puts "Reading ASN.1 file $inf(iname)"
1233 set inf(inf) [open $inf(iname) r]
1239 # The following procedures are invoked by the asnType function.
1240 # Each procedure takes the form: asnBasic<TYPE> and they must return
1241 # two elements: the C function handler and the C type.
1242 # On entry upvar $name is the type we are defining and global, $inf(module), is
1243 # the current module name.
1245 proc asnBasicEXTERNAL {} {
1246 return {odr_external {Odr_external}}
1249 proc asnBasicINTEGER {} {
1250 return {odr_integer {int}}
1253 proc asnBasicENUMERATED {} {
1254 return {odr_enum {int}}
1257 proc asnBasicNULL {} {
1258 return {odr_null {Odr_null}}
1261 proc asnBasicBOOLEAN {} {
1262 return {odr_bool {bool_t}}
1265 proc asnBasicOCTET {} {
1267 lex-name-move STRING
1268 return {odr_octetstring {Odr_oct}}
1271 proc asnBasicBIT {} {
1273 lex-name-move STRING
1274 return {odr_bitstring {Odr_bitmask}}
1277 proc asnBasicOBJECT {} {
1279 lex-name-move IDENTIFIER
1280 return {odr_oid {Odr_oid}}
1283 proc asnBasicGeneralString {} {
1284 return {odr_generalstring char}
1287 proc asnBasicVisibleString {} {
1288 return {odr_visiblestring char}
1291 proc asnBasicGeneralizedTime {} {
1292 return {odr_generalizedtime char}
1295 proc asnBasicANY {} {
1298 return [list $inf(fprefix)ANY_$name void]
1301 # userDef: reads user definitions file $name
1302 proc userDef {name} {
1305 if {$inf(verbose) > 1} {
1306 puts "Reading definitions file $name"
1310 if {[info exists default-prefix]} {
1311 set inf(prefix) ${default-prefix}
1313 if {[info exists h-path]} {
1314 set inf(h-path) ${h-path}
1316 foreach m [array names prefix] {
1317 set inf(prefix,$m) $prefix($m)
1319 foreach m [array names body] {
1320 set inf(body,$m) $body($m)
1322 foreach m [array names init] {
1323 set inf(init,$m) $init($m)
1325 foreach m [array names filename] {
1326 set inf(filename,$m) $filename($m)
1328 foreach m [array names map] {
1329 set inf(map,$m) $map($m)
1331 foreach m [array names membermap] {
1332 set inf(membermap,$m) $membermap($m)
1334 foreach m [array names unionmap] {
1335 set inf(unionmap,$m) $unionmap($m)
1340 set inf(prefix) {yc_ Yc_ YC_}
1344 # Parse command line
1345 set l [llength $argv]
1348 set arg [lindex $argv $i]
1349 switch -glob -- $arg {
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]]
1372 set inf(h-dir) [string trim $p \\/]/
1375 set p [string range $arg 2 end]
1376 if {![string length $p]} {
1377 set p [lindex $argv [incr i]]
1382 set p [string range $arg 2 end]
1383 if {![string length $p]} {
1384 set p [lindex $argv [incr i]]
1389 set p [string range $arg 2 end]
1390 if {![string length $p]} {
1391 set p [lindex $argv [incr i]]
1396 set p [string range $arg 2 end]
1397 if {![string length $p]} {
1398 set p [lindex $argv [incr i]]
1403 set p [string range $arg 2 end]
1404 if {![string length $p]} {
1405 set p [lindex $argv [incr i]]
1407 if {[llength $p] == 1} {
1408 set inf(prefix) [list [string tolower $p] \
1409 [string toupper $p] [string toupper $p]]
1410 } elseif {[llength $p] == 3} {
1424 if {![info exists inf(iname)]} {
1425 puts "YAZ ASN.1 Compiler ${yc_version}"
1426 puts -nonewline "Usage: ${argv0}"
1427 puts { [-v] [-c cfile] [-h hfile] [-p hfile] [-d dfile] [-I path]}
1428 puts { [-x prefix] [-m module] file}