2 # the next line restarts using tclsh \
5 # YC: ASN.1 Compiler for YAZ
6 # (c) Index Data 1996-1999
7 # See the file LICENSE for details.
8 # Sebastian Hammer, Adam Dickmeiss
11 # Revision 1.4 1999-12-16 23:36:19 adam
12 # Implemented ILL protocol. Minor updates ASN.1 compiler.
14 # Revision 1.3 1999/11/30 13:47:12 adam
15 # Improved installation. Moved header files to include/yaz.
17 # Revision 1.2 1999/06/09 09:43:11 adam
18 # Added option -I and variable h-path to specify path for header files.
20 # Revision 1.1 1999/06/08 10:10:16 adam
21 # New sub directory zutil. Moved YAZ Compiler to be part of YAZ tree.
23 # Revision 1.8 1999/04/20 10:37:04 adam
24 # Updated for ODR - added name parameter.
26 # Revision 1.7 1998/04/03 14:44:20 adam
29 # Revision 1.6 1998/04/03 13:21:17 adam
32 # Revision 1.5 1998/04/03 12:48:17 adam
33 # Fixed bug: missed handling of constructed tags for CHOICE.
35 # Revision 1.4 1998/03/31 15:47:45 adam
36 # First compiled ASN.1 code for YAZ.
38 # Revision 1.3 1998/03/23 17:13:20 adam
39 # Implemented SET OF and ENUM. The Compiler now eats ILL (ISO10161) and
42 # Revision 1.2 1997/10/07 10:31:01 adam
43 # Added facility to specify tag type (CONTEXT, APPLICATION, ...).
45 # Revision 1.1.1.1 1996/10/31 14:04:40 adam
46 # First version of the compiler for YAZ.
52 # Syntax for the ASN.1 supported:
55 # module -> name skip DEFINITIONS ::= mbody END
56 # mbody -> EXPORTS { nlist }
57 # | IMPORTS { imlist }
61 # type -> SEQUENCE { sqlist }
72 # sqlist -> sqlist , name tmt opt
74 # chlist -> chlist , name tmt
76 # enlist -> enlist , name (n)
78 # imlist -> nlist FROM name
79 # imlist nlist FROM name
82 # mod -> IMPLICIT | EXPLICIT | e
83 # tag -> [tagtype n] | [n] | e
86 # name identifier/token
88 # skip one token skipped
90 # tagtype APPLICATION, CONTEXT, etc.
92 # lex: moves input file pointer and returns type of token.
93 # The globals $type and $val are set. $val holds name if token
94 # is normal identifier name.
95 # sets global var type to one of:
98 # \} right curly brace
107 while {![string length $inf(str)]} {
109 set inf(cnt) [gets $inf(inf) inf(str)]
114 lappend inf(asn,$inf(asndef)) $inf(str)
115 set l [string first -- $inf(str)]
118 set inf(str) [string range $inf(str) 0 $l]
120 set inf(str) [string trim $inf(str)]
122 set s [string index $inf(str) 0]
132 \[ { regexp {^\[[ ]*(.+)[ ]*\]} $inf(str) s val }
133 : { regexp {^::=} $inf(str) s }
135 regexp "^\[^,\t :\{\}();\]+" $inf(str) s
140 set off [string length $s]
141 set inf(str) [string trim [string range $inf(str) $off end]]
145 # lex-expect: move pointer and expect token $t
146 proc lex-expect {t} {
149 if {[string compare $t $type]} {
150 asnError "Got $type '$val', expected $t"
154 # lex-name-move: see if token is $name; moves pointer and returns
155 # 1 if it is; returns 0 otherwise.
156 proc lex-name-move {name} {
158 if {![string compare $type n] && ![string compare $val $name]} {
165 # asnError: Report error and die
166 proc asnError {msg} {
169 puts "Error in line $inf(lineno) in module $inf(module)"
175 # asnWarning: Report warning and return
176 proc asnWarning {msg} {
179 puts "Warning in line $inf(lineno) in module $inf(module)"
183 # asnEnum: parses enumerated list - { name1 (n), name2 (n), ... }
184 # Uses $name as prefix. If there really is a list, $lx holds the C
185 # preprocessor definitions on return; otherwise lx isn't set.
186 proc asnEnum {name lx} {
189 if {[string compare $type \{]} return
192 set pq [asnName $name]
193 set id [lindex $pq 0]
196 lappend l "#define $inf(dprefix)$id $val"
199 if {[string compare $type ,]} break
201 if {[string compare $type \}]} {
202 asnError "Missing \} in enum list got $type '$val'"
207 # asnMod: parses tag and modifier.
208 # $xtag and $ximplicit holds tag and implicit-indication on return.
209 # $xtag is empty if no tag was specified. $ximplicit is 1 on implicit
210 # tagging; 0 otherwise.
211 proc asnMod {xtag ximplicit xtagtype} {
215 upvar $ximplicit implicit
216 upvar $xtagtype tagtype
220 if {![string compare $type \[]} {
221 if {[regexp {^([a-zA-Z]+)[ ]+([0-9]+)$} $val x tagtype tag]} {
222 set tagtype ODR_$tagtype
223 } elseif {[regexp {^([0-9]+)$} $val x tag]} {
224 set tagtype ODR_CONTEXT
226 asnError "bad tag specification: $val"
230 set implicit $inf(implicit-tags)
231 if {![string compare $type n]} {
232 if {![string compare $val EXPLICIT]} {
235 } elseif {![string compare $val IMPLICIT]} {
242 # asnName: moves pointer and expects name. Returns C-validated name.
243 proc asnName {name} {
246 if {[info exists inf(membermap,$inf(module),$name,$val)]} {
247 set nval $inf(membermap,$inf(module),$name,$val)
249 puts " mapping member $name,$val to $nval"
254 if {![string match {[A-Z]*} $val]} {
258 return [join [split $nval -] _]
261 # asnOptional: parses optional modifier. Returns 1 if OPTIONAL was
262 # specified; 0 otherwise.
263 proc asnOptional {} {
265 if {[lex-name-move OPTIONAL]} {
267 } elseif {[lex-name-move DEFAULT]} {
274 # asnSizeConstraint: parses the optional SizeConstraint.
275 # Currently not used for anything.
276 proc asnSizeConstraint {} {
278 if {[lex-name-move SIZE]} {
283 # asnSubtypeSpec: parses the SubtypeSpec ...
284 # Currently not used for anything. We now it's balanced however, i.e.
286 proc asnSubtypeSpec {} {
289 if {[string compare $type "("]} {
295 if {![string compare $type "("]} {
297 } elseif {![string compare $type ")"]} {
304 # asnType: parses ASN.1 type.
305 # On entry $name should hold the name we are currently defining.
306 # Returns type indicator:
307 # SequenceOf SEQUENCE OF
312 # Simple Basic types.
313 # In this casecalling procedure's $tname variable is a list holding:
314 # {C-Function C-Type} if the type is IMPORTed or ODR defined.
316 # {C-Function C-Type 1} if the type should be defined in this module
317 proc asnType {name} {
322 if {[string compare $type n]} {
323 asnError "Expects type specifier, but got $type"
330 if {[lex-name-move OF]} {
340 if {[lex-name-move OF]} {
353 if {[string length [info commands asnBasic$v]]} {
354 set tname [asnBasic$v]
356 if {[info exists inf(map,$inf(module),$v)]} {
357 set v $inf(map,$inf(module),$v)
359 if {[info exists inf(imports,$v)]} {
360 set tname $inf(imports,$v)
362 set w [join [split $v -] _]
363 set tname [list $inf(fprefix)$w $inf(vprefix)$w 1]
366 if {[lex-name-move DEFINED]} {
367 if {[lex-name-move BY]} {
375 proc mapName {name} {
377 if {[info exists inf(map,$inf(module),$name)]} {
378 set name $inf(map,$inf(module),$name)
380 puts -nonewline " $name ($inf(lineno))"
381 puts " mapping to $name"
385 puts " $name ($inf(lineno))"
391 # asnDef: parses type definition (top-level) and generates C code
392 # On entry $name holds the type we are defining.
396 set name [mapName $name]
397 if {[info exist inf(defined,$inf(fprefix)$name)]} {
398 incr inf(definedl,$name)
399 if {$inf(verbose) > 1} {
400 puts "set map($inf(module),$name) $name$inf(definedl,$name)"
403 set inf(definedl,$name) 0
405 set mname [join [split $name -] _]
406 asnMod tag implicit tagtype
407 set t [asnType $mname]
408 asnSub $mname $t $tname $tag $implicit $tagtype
412 # asnSub: parses type and generates C-code
414 # $name holds the type we are defining.
415 # $t is the type returned by the asnType procedure.
416 # $tname is the $tname set by the asnType procedure.
417 # $tag is the tag as returned by asnMod
418 # $implicit is the implicit indicator as returned by asnMod
419 proc asnSub {name t tname tag implicit tagtype} {
423 set defname defined,$inf(fprefix)$name
424 if {[info exist inf($defname)]} {
425 asnWarning "$name already defined in line $inf($defname)"
428 set inf($defname) $inf(lineno)
430 Sequence { set l [asnSequence $name $tag $implicit $tagtype] }
431 SequenceOf { set l [asnOf $name $tag $implicit $tagtype 0] }
432 SetOf { set l [asnOf $name $tag $implicit $tagtype 1] }
433 Choice { set l [asnChoice $name $tag $implicit $tagtype] }
434 Simple { set l [asnSimple $name $tname $tag $implicit $tagtype] }
435 default { asnError "switch asnType case not handled" }
440 puts $file(outc) "int $inf(fprefix)$name (ODR o, $inf(vprefix)$name **p, int opt, const char *name)"
442 puts $file(outc) [lindex $l 0]
445 set fdef "$inf(cprefix)int $inf(fprefix)$name (ODR o, $inf(vprefix)$name **p, int opt, const char *name);"
448 set decl "typedef [lindex $l 1] $inf(vprefix)$name;"
449 if {![string compare [lindex $tname 2] 1]} {
450 if {![info exist inf(defined,[lindex $tname 0])]} {
454 set inf(var,$inf(nodef)) [join [lindex $l 2] \n]
458 set decl "typedef struct $inf(vprefix)$name $inf(vprefix)$name;"
459 set inf(var,$inf(nodef)) "[lindex $l 1];"
465 puts $file(outh) $decl
466 puts $file(outh) $fdef
467 asnForwardTypes $name
469 lappend inf(forward,code,[lindex $tname 0]) {} $decl $fdef
470 lappend inf(forward,ref,[lindex $tname 0]) $name
474 proc asnForwardTypes {name} {
477 if {![info exists inf(forward,code,$inf(fprefix)$name)]} {
480 foreach r $inf(forward,code,$inf(fprefix)$name) {
483 unset inf(forward,code,$inf(fprefix)$name)
485 while {[info exists inf(forward,ref,$inf(fprefix)$name)]} {
486 set n $inf(forward,ref,$inf(fprefix)$name)
487 set m [lrange $n 1 end]
489 set inf(forward,ref,$inf(fprefix)$name) $m
491 unset inf(forward,ref,$inf(fprefix)$name)
493 asnForwardTypes [lindex $n 0]
497 # asnSimple: parses simple type definition and generates C code
499 # $name is the name we are defining
500 # $tname is the tname as returned by asnType
501 # $tag is the tag as returned by asnMod
502 # $implicit is the implicit indicator as returned by asnMod
505 # Note: Doesn't take care of enum lists yet.
506 proc asnSimple {name tname tag implicit tagtype} {
509 set j "[lindex $tname 1] "
511 if {[info exists inf(unionmap,$inf(module),$name)]} {
512 set uName $inf(unionmap,$inf(module),$name)
518 if {![string length $tag]} {
519 set l "\treturn [lindex $tname 0] (o, p, opt, name);"
520 } elseif {$implicit} {
522 "\treturn odr_implicit_tag (o, [lindex $tname 0], p, $tagtype, $tag, opt, name);"
525 "\treturn odr_explicit_tag (o, [lindex $tname 0], p, $tagtype, $tag, opt, name);" \
527 if {[info exists jj]} {
528 return [list $l $j $jj]
534 # asnSequence: parses "SEQUENCE { s-list }" and generates C code.
536 # $name is the type we are defining
541 proc asnSequence {name tag implicit tagtype} {
544 lappend j "struct $inf(vprefix)$name \{"
547 if {![string length $tag]} {
548 lappend l "\tif (!odr_sequence_begin (o, p, sizeof(**p), name))"
549 lappend l "\t\treturn opt && odr_ok (o);"
550 } elseif {$implicit} {
551 lappend l "\tif (!odr_implicit_settag (o, $tagtype, $tag) ||"
552 lappend l "\t\t!odr_sequence_begin (o, p, sizeof(**p), name))"
553 lappend l "\t\treturn opt && odr_ok(o);"
555 lappend l "\tif (!odr_constructed_begin (o, p, $tagtype, $tag, name))"
556 lappend l "\t\treturn opt && odr_ok(o);"
557 lappend l "\tif (o->direction == ODR_DECODE)"
558 lappend l "\t\t*p = odr_malloc (o, sizeof(**p));"
560 lappend l "\tif (!odr_sequence_begin (o, p, sizeof(**p), 0))"
562 lappend l "\t\t*p = 0;"
563 lappend l "\t\treturn 0;"
568 set p [lindex [asnName $name] 0]
569 asnMod ltag limplicit ltagtype
573 if {[info exists inf(unionmap,$inf(module),$name,$p)]} {
574 set uName $inf(unionmap,$inf(module),$name,$p)
577 if {![string compare $t Simple]} {
578 if {[string compare $uName { }]} {
584 set opt [asnOptional]
585 if {![string length $ltag]} {
586 lappend l "\t\t[lindex $tname 0](o, &(*p)->$p, $opt, \"$p\") &&"
587 } elseif {$limplicit} {
588 lappend l "\t\todr_implicit_tag (o, [lindex $tname 0],"
589 lappend l "\t\t\t&(*p)->$p, $ltagtype, $ltag, $opt, \"$p\") &&"
591 lappend l "\t\todr_explicit_tag (o, [lindex $tname 0],"
592 lappend l "\t\t\t&(*p)->$p, $ltagtype, $ltag, $opt, \"$p\") &&"
594 set dec "\t[lindex $tname 1] *$p;"
595 } elseif {![string compare $t SequenceOf] && [string length $uName] &&\
596 (![string length $ltag] || $limplicit)} {
599 if {[llength $uName] < 2} {
600 set uName [list num_$p $p]
602 if {[string length $ltag]} {
606 lappend l "\t\todr_implicit_settag (o, $ltagtype, $ltag) &&"
611 set tmpa "odr_sequence_of(o, (Odr_fun) [lindex $tname 0], &(*p)->$p,"
612 set tmpb "&(*p)->[lindex $uName 0], \"$p\")"
613 lappend j "\tint [lindex $uName 0];"
614 set dec "\t[lindex $tname 1] **[lindex $uName 1];"
617 set subName [mapName ${name}_$level]
618 asnSub $subName $u {} {} 0 {}
620 set tmpa "odr_sequence_of(o, (Odr_fun) $inf(fprefix)$subName, &(*p)->$p,"
621 set tmpb "&(*p)->[lindex $uName 0], \"$p\")"
622 lappend j "\tint [lindex $uName 0];"
623 set dec "\t$inf(vprefix)$subName **[lindex $uName 1];"
627 set opt [asnOptional]
629 lappend l "\t\t($tmpa"
630 lappend l "\t\t $tmpb || odr_ok(o)) &&"
632 lappend l "\t\t$tmpa"
633 lappend l "\t\t $tmpb &&"
635 } elseif {!$nchoice && ![string compare $t Choice] && \
636 [string length $uName]} {
637 if {[llength $uName] < 3} {
638 set uName [list which u $name]
641 lappend j "\tint [lindex $uName 0];"
642 lappend j "\tunion \{"
643 lappend v "\tstatic Odr_arm arm\[\] = \{"
644 asnArm $name [lindex $uName 2] v j
646 set dec "\t\} [lindex $uName 1];"
647 set opt [asnOptional]
650 if {[string length $ltag]} {
652 lappend l "\t\todr_implicit_settag (o, $ltagtype, $ltag) &&"
654 asnWarning "optional handling missing in CHOICE in SEQUENCE"
655 asnWarning " set unionmap($inf(module),$name,$p) to {}"
663 lappend l "\t\t${la}odr_constructed_begin (o, &(*p)->[lindex $uName 1], $ltagtype, $ltag, \"$p\") &&"
668 set ob " || odr_ok(o))"
671 lappend l "\t\t${oa}odr_choice (o, arm, &(*p)->[lindex $uName 1], &(*p)->[lindex $uName 0], 0)${ob} &&"
672 if {[string length $ltag]} {
675 set lb ") || odr_ok(o))"
679 lappend l "\t\todr_constructed_end (o)${lb} &&"
683 set subName [mapName ${name}_$level]
684 asnSub $subName $t {} {} 0 {}
685 set opt [asnOptional]
686 if {![string length $ltag]} {
687 lappend l "\t\t$inf(fprefix)${subName} (o, &(*p)->$p, $opt, \"$p\") &&"
688 } elseif {$limplicit} {
689 lappend l "\t\todr_implicit_tag (o, $inf(fprefix)${subName},"
690 lappend l "\t\t\t&(*p)->$p, $ltagtype, $ltag, $opt, \"$p\") &&"
692 lappend l "\t\todr_explicit_tag (o, $inf(fprefix)${subName},"
693 lappend l "\t\t\t&(*p)->$p, $ltagtype, $ltag, $opt, \"$p\") &&"
695 set dec "\t$inf(vprefix)${subName} *$p;"
699 lappend j "$dec /* OPT */"
703 if {[string compare $type ,]} break
706 if {[string length $tag] && !$implicit} {
707 lappend l "\t\todr_sequence_end (o) &&"
708 lappend l "\t\todr_constructed_end (o);"
710 lappend l "\t\todr_sequence_end (o);"
712 if {[string compare $type \}]} {
713 asnError "Missing \} got $type '$val'"
716 if {[info exists v]} {
719 return [list [join $l \n] [join $j \n]]
722 # asnOf: parses "SEQUENCE/SET OF type" and generates C code.
724 # $name is the type we are defining
729 proc asnOf {name tag implicit tagtype isset} {
735 set func odr_sequence_of
738 if {[info exists inf(unionmap,$inf(module),$name)]} {
739 set numName $inf(unionmap,$inf(module),$name)
741 set numName {num elements}
744 lappend j "struct $inf(vprefix)$name \{"
745 lappend j "\tint [lindex $numName 0];"
747 lappend l "\tif (!odr_initmember (o, p, sizeof(**p)))"
748 lappend l "\t\treturn opt && odr_ok(o);"
749 if {[string length $tag]} {
751 lappend l "\todr_implicit_settag (o, $tagtype, $tag);"
753 asnWarning "Constructed SEQUENCE/SET OF not handled"
756 set t [asnType $name]
760 lappend l "\tif ($func (o, (Odr_fun) [lindex $tname 0], &(*p)->[lindex $numName 1],"
761 lappend l "\t\t&(*p)->[lindex $numName 0], name))"
762 lappend j "\t[lindex $tname 1] **[lindex $numName 1];"
765 set subName [mapName ${name}_s]
766 lappend l "\tif ($func (o, (Odr_fun) $inf(fprefix)$subName, &(*p)->[lindex $numName 1],"
767 lappend l "\t\t&(*p)->[lindex $numName 0], name))"
768 lappend j "\t$inf(vprefix)$subName **[lindex $numName 1];"
769 asnSub $subName $t {} {} 0 {}
773 lappend l "\t\treturn 1;"
774 lappend l "\t*p = 0;"
775 lappend l "\treturn opt && odr_ok(o);"
776 return [list [join $l \n] [join $j \n]]
779 # asnArm: parses c-list in choice
780 proc asnArm {name defname lx jx} {
786 set pq [asnName $name]
789 if {![string length $q]} {
793 asnMod ltag limplicit ltagtype
796 lappend enums "$inf(dprefix)$p"
797 if {![string compare $t Simple]} {
799 if {![string length $ltag]} {
800 lappend l "\t\t\{-1, -1, -1, $inf(dprefix)$p,"
801 lappend l "\t\t (Odr_fun) [lindex $tname 0], \"$q\"\},"
802 } elseif {$limplicit} {
803 lappend l "\t\t\{ODR_IMPLICIT, $ltagtype, $ltag, $inf(dprefix)$p,"
804 lappend l "\t\t(Odr_fun) [lindex $tname 0], \"$q\"\},"
806 lappend l "\t\t\{ODR_EXPLICIT, $ltagtype, $ltag, $inf(dprefix)$p,"
807 lappend l "\t\t(Odr_fun) [lindex $tname 0], \"$q\"\},"
809 lappend j "\t\t[lindex $tname 1] *$q;"
811 set subName [mapName ${name}_$q]
812 if {![string compare $inf(dprefix)${name}_$q \
813 $inf(vprefix)$subName]} {
814 set po [string toupper [string index $q 0]][string \
816 set subName [mapName ${name}${po}]
818 asnSub $subName $t $tname {} 0 {}
819 if {![string length $ltag]} {
820 lappend l "\t\t\{-1, -1, -1, $inf(dprefix)$p,"
821 lappend l "\t\t (Odr_fun) $inf(fprefix)$subName, \"$q\"\},"
822 } elseif {$limplicit} {
823 lappend l "\t\t\{ODR_IMPLICIT, $ltagtype, $ltag, $inf(dprefix)$p,"
824 lappend l "\t\t(Odr_fun) $inf(fprefix)$subName, \"$q\"\},"
826 lappend l "\t\t\{ODR_EXPLICIT, $ltagtype, $ltag, $inf(dprefix)$p,"
827 lappend l "\t\t(Odr_fun) $inf(fprefix)$subName, \"$q\"\},"
829 lappend j "\t\t$inf(vprefix)$subName *$q;"
831 if {[string compare $type ,]} break
833 if {[string compare $type \}]} {
834 asnError "Missing \} got $type '$val'"
839 lappend j "#define $e $level"
842 lappend l "\t\t\{-1, -1, -1, -1, (Odr_fun) 0, 0\}"
845 # asnChoice: parses "CHOICE {c-list}" and generates C code.
847 # $name is the type we are defining
852 proc asnChoice {name tag implicit tagtype} {
855 if {[info exists inf(unionmap,$inf(module),$name)]} {
856 set uName $inf(unionmap,$inf(module),$name)
858 set uName [list which u $name]
861 lappend j "struct $inf(vprefix)$name \{"
862 lappend j "\tint [lindex $uName 0];"
863 lappend j "\tunion \{"
864 lappend l "\tstatic Odr_arm arm\[\] = \{"
865 asnArm $name [lindex $uName 2] l j
866 lappend j "\t\} [lindex $uName 1];"
869 if {![string length $tag]} {
870 lappend l "\tif (!odr_initmember(o, p, sizeof(**p)))"
871 lappend l "\t\treturn opt && odr_ok(o);"
872 lappend l "\tif (odr_choice(o, arm, &(*p)->[lindex $uName 1], &(*p)->[lindex $uName 0], name))"
873 } elseif {$implicit} {
874 lappend l "\tif (!odr_initmember(o, p, sizeof(**p)))"
875 lappend l "\t\treturn opt && odr_ok(o);"
876 lappend l "\todr_implicit_settag(o, $tagtype, $tag);"
877 lappend l "\tif (odr_choice(o, arm, &(*p)->[lindex $uName 1], &(*p)->[lindex $uName 0], name))"
879 lappend l "\tif (!*p && o->direction != ODR_DECODE)"
880 lappend l "\t\treturn opt;"
881 lappend l "\tif (!odr_constructed_begin(o, p, $tagtype, $tag, 0))"
882 lappend l "\t\treturn opt && odr_ok(o);"
883 lappend l "\tif (!odr_initmember(o, p, sizeof(**p)))"
884 lappend l "\t\treturn opt && odr_ok(o);"
885 lappend l "\tif (odr_choice(o, arm, &(*p)->[lindex $uName 1], &(*p)->[lindex $uName 0], name) &&"
886 lappend l "\t\todr_constructed_end(o))"
888 lappend l "\t\treturn 1;"
889 lappend l "\t*p = 0;"
890 lappend l "\treturn opt && odr_ok(o);"
891 return [list [join $l \n] [join $j \n]]
894 # asnImports: parses i-list in "IMPORTS {i-list}"
895 # On return inf(import,..)-array is updated.
896 # inf(import,"module") is a list of {C-handler, C-type} elements.
897 # The {C-handler, C-type} is compatible with the $tname as is used by the
898 # asnType procedure to solve external references.
900 global type val inf file
903 if {[string compare $type n]} {
904 asnError "Missing name in IMPORTS list"
908 if {![string compare $type n] && ![string compare $val FROM]} {
911 if {[info exists inf(filename,$val)]} {
912 set fname $inf(filename,$val)
916 puts $file(outh) "\#include <$inf(h-dir)${fname}.h>"
918 if {[info exists inf(prefix,$val)]} {
919 set prefix $inf(prefix,$val)
921 set prefix $inf(prefix)
924 if {[info exists inf(map,$val,$n)]} {
925 set v $inf(map,$val,$n)
929 set w [join [split $v -] _]
930 set inf(imports,$n) [list [lindex $prefix 0]$w \
931 [lindex $prefix 1]$w]
935 if {[string compare $type n]} break
936 } elseif {![string compare $type ,]} {
940 if {[string compare $type \;]} {
941 asnError "Missing ; after IMPORTS list - got $type '$val'"
946 # asnExports: parses e-list in "EXPORTS {e-list}"
947 # This function does nothing with elements in the list.
952 if {[string compare $type n]} {
953 asnError "Missing name in EXPORTS list"
955 set inf(exports,$val) 1
957 if {[string compare $type ,]} break
960 if {[string compare $type \;]} {
961 asnError "Missing ; after EXPORTS list - got $type ($val)"
966 # asnModuleBody: parses a module specification and generates C code.
967 # Exports lists, imports lists, and type definitions are handled;
968 # other things are silently ignored.
969 proc asnModuleBody {} {
970 global type val file inf
972 if {[info exists inf(prefix,$inf(module))]} {
973 set prefix $inf(prefix,$inf(module))
975 set prefix $inf(prefix)
977 set inf(fprefix) [lindex $prefix 0]
978 set inf(vprefix) [lindex $prefix 1]
979 set inf(dprefix) [lindex $prefix 2]
980 if {[llength $prefix] > 3} {
981 set inf(cprefix) [lindex $prefix 3]
983 set inf(cprefix) {YAZ_EXPORT }
987 puts "Module $inf(module), $inf(lineno)"
991 if {[info exists inf(init,$inf(module),c)]} {
992 puts $file(outc) $inf(init,$inf(module),c)
994 if {[info exists inf(init,$inf(module),h)]} {
995 puts $file(outh) "\#ifdef __cplusplus"
996 puts $file(outh) "extern \"C\" \{"
997 puts $file(outh) "\#endif"
999 puts $file(outh) $inf(init,$inf(module),h)
1001 if {[info exists inf(init,$inf(module),p)]} {
1002 puts $file(outp) $inf(init,$inf(module),p)
1005 while {[string length $type]} {
1006 if {[string compare $type n]} {
1010 if {![string compare $val END]} {
1012 } elseif {![string compare $val EXPORTS]} {
1015 } elseif {![string compare $val IMPORTS]} {
1017 puts $file(outh) "\#ifdef __cplusplus"
1018 puts $file(outh) "\}"
1019 puts $file(outh) "\#endif"
1026 puts $file(outh) "\#ifdef __cplusplus"
1027 puts $file(outh) "extern \"C\" \{"
1028 puts $file(outh) "\#endif"
1031 set inf(asndef) $inf(nodef)
1034 if {![string compare $type :]} {
1038 } elseif {![string compare $type n]} {
1040 if {[string length $type]} {
1047 puts $file(outh) "\#ifdef __cplusplus"
1048 puts $file(outh) "\}"
1049 puts $file(outh) "\#endif"
1052 foreach x [array names inf imports,*] {
1057 # asnTagDefault: parses TagDefault section
1058 proc asnTagDefault {} {
1059 global type val inf file
1061 set inf(implicit-tags) 0
1062 while {[string length $type]} {
1063 if {[lex-name-move EXPLICIT]} {
1065 set inf(implicit-tags) 0
1066 } elseif {[lex-name-move IMPLICIT]} {
1068 set inf(implicit-tags) 1
1075 # asnModules: parses a collection of module specifications.
1076 # Depending on the module pattern, $inf(moduleP), a module is either
1077 # skipped or processed.
1078 proc asnModules {} {
1079 global type val inf file yc_version
1084 while {![string compare $type n]} {
1085 set inf(module) $val
1086 if {[info exists inf(moduleP)] && ![string match $inf(moduleP) $val]} {
1087 if {$inf(verbose)} {
1090 while {![lex-name-move END]} {
1097 while {![lex-name-move DEFINITIONS]} {
1099 if {![string length $type]} return
1101 if {[info exists inf(filename,$inf(module))]} {
1102 set fname $inf(filename,$inf(module))
1104 set fname $inf(module)
1106 set ppname [join [split $fname -] _]
1108 if {![info exists inf(c-file)]} {
1109 set inf(c-file) ${fname}.c
1111 set file(outc) [open $inf(c-file) w]
1113 if {![info exists inf(h-file)]} {
1114 set inf(h-file) ${fname}.h
1116 set file(outh) [open $inf(h-path)/$inf(h-dir)$inf(h-file) w]
1119 if {![info exists inf(p-file)]} {
1120 set inf(p-file) ${fname}-p.h
1122 set file(outp) [open $inf(h-path)/$inf(h-dir)$inf(p-file) w]
1125 set md [clock format [clock seconds]]
1127 puts $file(outc) "/* YC ${yc_version} $md */"
1128 puts $file(outc) "/* Module-C: $inf(module) */"
1131 puts $file(outh) "/* YC ${yc_version}: $md */"
1132 puts $file(outh) "/* Module-H $inf(module) */"
1135 if {[info exists file(outp)]} {
1136 puts $file(outp) "/* YC ${yc_version}: $md */"
1137 puts $file(outp) "/* Module-P: $inf(module) */"
1141 if {[info exists inf(p-file)]} {
1142 puts $file(outc) "\#include <$inf(h-dir)$inf(p-file)>"
1144 puts $file(outc) "\#include <$inf(h-dir)$inf(h-file)>"
1146 puts $file(outh) "\#ifndef ${ppname}_H"
1147 puts $file(outh) "\#define ${ppname}_H"
1149 puts $file(outh) "\#include <$inf(h-dir)odr.h>"
1151 if {[info exists file(outp)]} {
1152 puts $file(outp) "\#ifndef ${ppname}_P_H"
1153 puts $file(outp) "\#define ${ppname}_P_H"
1155 puts $file(outp) "\#include <$inf(h-dir)$inf(h-file)>"
1160 if {[string compare $type :]} {
1161 asnError "::= expected got $type '$val'"
1164 if {![lex-name-move BEGIN]} {
1165 asnError "BEGIN expected"
1170 if {[info exists file(outp)]} {
1175 puts $f "\#ifdef __cplusplus"
1176 puts $f "extern \"C\" \{"
1178 for {set i 1} {$i < $inf(nodef)} {incr i} {
1179 puts $f $inf(var,$i)
1180 if {[info exists inf(asn,$i)]} {
1183 foreach comment $inf(asn,$i) {
1193 puts $f "\#ifdef __cplusplus"
1197 if {[info exists inf(body,$inf(module),h)]} {
1198 puts $file(outh) $inf(body,$inf(module),h)
1200 if {[info exists inf(body,$inf(module),c)]} {
1201 puts $file(outc) $inf(body,$inf(module),c)
1203 if {[info exists inf(body,$inf(module),p)]} {
1204 if {[info exists file(outp)]} {
1205 puts $file(outp) $inf(body,$inf(module),p)
1208 puts $file(outh) "\#endif"
1209 if {[info exists file(outp)]} {
1210 puts $file(outp) "\#endif"
1212 foreach f [array names file] {
1217 catch {unset inf(p-file)}
1222 # asnFile: parses an ASN.1 specification file as specified in $inf(iname).
1226 if {$inf(verbose) > 1} {
1227 puts "Reading ASN.1 file $inf(iname)"
1231 set inf(inf) [open $inf(iname) r]
1237 # The following procedures are invoked by the asnType function.
1238 # Each procedure takes the form: asnBasic<TYPE> and they must return
1239 # two elements: the C function handler and the C type.
1240 # On entry upvar $name is the type we are defining and global, $inf(module), is
1241 # the current module name.
1243 proc asnBasicEXTERNAL {} {
1244 return {odr_external {Odr_external}}
1247 proc asnBasicINTEGER {} {
1248 return {odr_integer {int}}
1251 proc asnBasicENUMERATED {} {
1252 return {odr_enum {int}}
1255 proc asnBasicNULL {} {
1256 return {odr_null {Odr_null}}
1259 proc asnBasicBOOLEAN {} {
1260 return {odr_bool {bool_t}}
1263 proc asnBasicOCTET {} {
1265 lex-name-move STRING
1266 return {odr_octetstring {Odr_oct}}
1269 proc asnBasicBIT {} {
1271 lex-name-move STRING
1272 return {odr_bitstring {Odr_bitmask}}
1275 proc asnBasicOBJECT {} {
1277 lex-name-move IDENTIFIER
1278 return {odr_oid {Odr_oid}}
1281 proc asnBasicGeneralString {} {
1282 return {odr_generalstring char}
1285 proc asnBasicVisibleString {} {
1286 return {odr_visiblestring char}
1289 proc asnBasicGeneralizedTime {} {
1290 return {odr_generalizedtime char}
1293 proc asnBasicANY {} {
1296 return [list $inf(fprefix)ANY_$name void]
1299 # userDef: reads user definitions file $name
1300 proc userDef {name} {
1303 if {$inf(verbose) > 1} {
1304 puts "Reading definitions file $name"
1308 if {[info exists default-prefix]} {
1309 set inf(prefix) ${default-prefix}
1311 if {[info exists h-path]} {
1312 set inf(h-path) ${h-path}
1314 foreach m [array names prefix] {
1315 set inf(prefix,$m) $prefix($m)
1317 foreach m [array names body] {
1318 set inf(body,$m) $body($m)
1320 foreach m [array names init] {
1321 set inf(init,$m) $init($m)
1323 foreach m [array names filename] {
1324 set inf(filename,$m) $filename($m)
1326 foreach m [array names map] {
1327 set inf(map,$m) $map($m)
1329 foreach m [array names membermap] {
1330 set inf(membermap,$m) $membermap($m)
1332 foreach m [array names unionmap] {
1333 set inf(unionmap,$m) $unionmap($m)
1338 set inf(prefix) {yc_ Yc_ YC_}
1342 # Parse command line
1343 set l [llength $argv]
1346 set arg [lindex $argv $i]
1347 switch -glob -- $arg {
1352 set p [string range $arg 2 end]
1353 if {![string length $p]} {
1354 set p [lindex $argv [incr i]]
1359 set p [string range $arg 2 end]
1360 if {![string length $p]} {
1361 set p [lindex $argv [incr i]]
1366 set p [string range $arg 2 end]
1367 if {![string length $p]} {
1368 set p [lindex $argv [incr i]]
1370 set inf(h-dir) [string trim $p \\/]/
1373 set p [string range $arg 2 end]
1374 if {![string length $p]} {
1375 set p [lindex $argv [incr i]]
1380 set p [string range $arg 2 end]
1381 if {![string length $p]} {
1382 set p [lindex $argv [incr i]]
1387 set p [string range $arg 2 end]
1388 if {![string length $p]} {
1389 set p [lindex $argv [incr i]]
1394 set p [string range $arg 2 end]
1395 if {![string length $p]} {
1396 set p [lindex $argv [incr i]]
1401 set p [string range $arg 2 end]
1402 if {![string length $p]} {
1403 set p [lindex $argv [incr i]]
1405 if {[llength $p] == 1} {
1406 set inf(prefix) [list [string tolower $p] \
1407 [string toupper $p] [string toupper $p]]
1408 } elseif {[llength $p] == 3} {
1422 if {![info exists inf(iname)]} {
1423 puts "YAZ ASN.1 Compiler ${yc_version}"
1424 puts -nonewline "Usage: ${argv0}"
1425 puts { [-v] [-c cfile] [-h hfile] [-p hfile] [-d dfile] [-I path]}
1426 puts { [-x prefix] [-m module] file}