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.2 1999-06-09 09:43:11 adam
12 # Added option -I and variable h-path to specify path for header files.
14 # Revision 1.1 1999/06/08 10:10:16 adam
15 # New sub directory zutil. Moved YAZ Compiler to be part of YAZ tree.
17 # Revision 1.8 1999/04/20 10:37:04 adam
18 # Updated for ODR - added name parameter.
20 # Revision 1.7 1998/04/03 14:44:20 adam
23 # Revision 1.6 1998/04/03 13:21:17 adam
26 # Revision 1.5 1998/04/03 12:48:17 adam
27 # Fixed bug: missed handling of constructed tags for CHOICE.
29 # Revision 1.4 1998/03/31 15:47:45 adam
30 # First compiled ASN.1 code for YAZ.
32 # Revision 1.3 1998/03/23 17:13:20 adam
33 # Implemented SET OF and ENUM. The Compiler now eats ILL (ISO10161) and
36 # Revision 1.2 1997/10/07 10:31:01 adam
37 # Added facility to specify tag type (CONTEXT, APPLICATION, ...).
39 # Revision 1.1.1.1 1996/10/31 14:04:40 adam
40 # First version of the compiler for YAZ.
46 # Syntax for the ASN.1 supported:
49 # module -> name skip DEFINITIONS ::= mbody END
50 # mbody -> EXPORTS { nlist }
51 # | IMPORTS { imlist }
55 # type -> SEQUENCE { sqlist }
66 # sqlist -> sqlist , name tmt opt
68 # chlist -> chlist , name tmt
70 # enlist -> enlist , name (n)
72 # imlist -> nlist FROM name
73 # imlist nlist FROM name
76 # mod -> IMPLICIT | EXPLICIT | e
77 # tag -> [tagtype n] | [n] | e
80 # name identifier/token
82 # skip one token skipped
84 # tagtype APPLICATION, CONTEXT, etc.
86 # lex: moves input file pointer and returns type of token.
87 # The globals $type and $val are set. $val holds name if token
88 # is normal identifier name.
89 # sets global var type to one of:
92 # \} right curly brace
101 while {![string length $inf(str)]} {
103 set inf(cnt) [gets $inf(inf) inf(str)]
108 lappend inf(asn,$inf(asndef)) $inf(str)
109 set l [string first -- $inf(str)]
112 set inf(str) [string range $inf(str) 0 $l]
114 set inf(str) [string trim $inf(str)]
116 set s [string index $inf(str) 0]
126 \[ { regexp {^\[[ ]*(.+)[ ]*\]} $inf(str) s val }
127 : { regexp {^::=} $inf(str) s }
129 regexp "^\[^,\t :\{\}();\]+" $inf(str) s
134 set off [string length $s]
135 set inf(str) [string trim [string range $inf(str) $off end]]
139 # lex-expect: move pointer and expect token $t
140 proc lex-expect {t} {
143 if {[string compare $t $type]} {
144 asnError "Got $type '$val', expected $t"
148 # lex-name-move: see if token is $name; moves pointer and returns
149 # 1 if it is; returns 0 otherwise.
150 proc lex-name-move {name} {
152 if {![string compare $type n] && ![string compare $val $name]} {
159 # asnError: Report error and die
160 proc asnError {msg} {
163 puts "Error in line $inf(lineno) in module $inf(module)"
169 # asnWarning: Report warning and return
170 proc asnWarning {msg} {
173 puts "Warning in line $inf(lineno) in module $inf(module)"
177 # asnEnum: parses enumerated list - { name1 (n), name2 (n), ... }
178 # Uses $name as prefix. If there really is a list, $lx holds the C
179 # preprocessor definitions on return; otherwise lx isn't set.
180 proc asnEnum {name lx} {
183 if {[string compare $type \{]} return
186 set pq [asnName $name]
187 set id [lindex $pq 0]
190 lappend l "#define $inf(dprefix)$id $val"
193 if {[string compare $type ,]} break
195 if {[string compare $type \}]} {
196 asnError "Missing \} in enum list got $type '$val'"
201 # asnMod: parses tag and modifier.
202 # $xtag and $ximplicit holds tag and implicit-indication on return.
203 # $xtag is empty if no tag was specified. $ximplicit is 1 on implicit
204 # tagging; 0 otherwise.
205 proc asnMod {xtag ximplicit xtagtype} {
209 upvar $ximplicit implicit
210 upvar $xtagtype tagtype
214 if {![string compare $type \[]} {
215 if {[regexp {^([a-zA-Z]+)[ ]+([0-9]+)$} $val x tagtype tag]} {
216 set tagtype ODR_$tagtype
217 } elseif {[regexp {^([0-9]+)$} $val x tag]} {
218 set tagtype ODR_CONTEXT
220 asnError "bad tag specification: $val"
224 set implicit $inf(implicit-tags)
225 if {![string compare $type n]} {
226 if {![string compare $val EXPLICIT]} {
229 } elseif {![string compare $val IMPLICIT]} {
236 # asnName: moves pointer and expects name. Returns C-validated name.
237 proc asnName {name} {
240 if {[info exists inf(membermap,$inf(module),$name,$val)]} {
241 set nval $inf(membermap,$inf(module),$name,$val)
243 puts " mapping member $name,$val to $nval"
248 if {![string match {[A-Z]*} $val]} {
252 return [join [split $nval -] _]
255 # asnOptional: parses optional modifier. Returns 1 if OPTIONAL was
256 # specified; 0 otherwise.
257 proc asnOptional {} {
259 if {[lex-name-move OPTIONAL]} {
261 } elseif {[lex-name-move DEFAULT]} {
268 # asnSizeConstraint: parses the optional SizeConstraint.
269 # Currently not used for anything.
270 proc asnSizeConstraint {} {
272 if {[lex-name-move SIZE]} {
277 # asnSubtypeSpec: parses the SubtypeSpec ...
278 # Currently not used for anything. We now it's balanced however, i.e.
280 proc asnSubtypeSpec {} {
283 if {[string compare $type "("]} {
289 if {![string compare $type "("]} {
291 } elseif {![string compare $type ")"]} {
298 # asnType: parses ASN.1 type.
299 # On entry $name should hold the name we are currently defining.
300 # Returns type indicator:
301 # SequenceOf SEQUENCE OF
306 # Simple Basic types.
307 # In this casecalling procedure's $tname variable is a list holding:
308 # {C-Function C-Type} if the type is IMPORTed or ODR defined.
310 # {C-Function C-Type 1} if the type should be defined in this module
311 proc asnType {name} {
316 if {[string compare $type n]} {
317 asnError "Expects type specifier, but got $type"
324 if {[lex-name-move OF]} {
334 if {[lex-name-move OF]} {
347 if {[string length [info commands asnBasic$v]]} {
348 set tname [asnBasic$v]
350 if {[info exists inf(map,$inf(module),$v)]} {
351 set v $inf(map,$inf(module),$v)
353 if {[info exists inf(imports,$v)]} {
354 set tname $inf(imports,$v)
356 set w [join [split $v -] _]
357 set tname [list $inf(fprefix)$w $inf(vprefix)$w 1]
360 if {[lex-name-move DEFINED]} {
361 if {[lex-name-move BY]} {
369 proc mapName {name} {
371 if {[info exists inf(map,$inf(module),$name)]} {
372 set name $inf(map,$inf(module),$name)
374 puts -nonewline " $name ($inf(lineno))"
375 puts " mapping to $name"
379 puts " $name ($inf(lineno))"
385 # asnDef: parses type definition (top-level) and generates C code
386 # On entry $name holds the type we are defining.
390 set name [mapName $name]
391 if {[info exist inf(defined,$inf(fprefix)$name)]} {
392 incr inf(definedl,$name)
393 if {$inf(verbose) > 1} {
394 puts "set map($inf(module),$name) $name$inf(definedl,$name)"
397 set inf(definedl,$name) 0
399 set mname [join [split $name -] _]
400 asnMod tag implicit tagtype
401 set t [asnType $mname]
402 asnSub $mname $t $tname $tag $implicit $tagtype
406 # asnSub: parses type and generates C-code
408 # $name holds the type we are defining.
409 # $t is the type returned by the asnType procedure.
410 # $tname is the $tname set by the asnType procedure.
411 # $tag is the tag as returned by asnMod
412 # $implicit is the implicit indicator as returned by asnMod
413 proc asnSub {name t tname tag implicit tagtype} {
417 set defname defined,$inf(fprefix)$name
418 if {[info exist inf($defname)]} {
419 asnWarning "$name already defined in line $inf($defname)"
422 set inf($defname) $inf(lineno)
424 Sequence { set l [asnSequence $name $tag $implicit $tagtype] }
425 SequenceOf { set l [asnOf $name $tag $implicit $tagtype 0] }
426 SetOf { set l [asnOf $name $tag $implicit $tagtype 1] }
427 Choice { set l [asnChoice $name $tag $implicit $tagtype] }
428 Simple { set l [asnSimple $name $tname $tag $implicit $tagtype] }
429 default { asnError "switch asnType case not handled" }
434 puts $file(outc) "int $inf(fprefix)$name (ODR o, $inf(vprefix)$name **p, int opt, const char *name)"
436 puts $file(outc) [lindex $l 0]
439 set fdef "$inf(cprefix)int $inf(fprefix)$name (ODR o, $inf(vprefix)$name **p, int opt, const char *name);"
442 set decl "typedef [lindex $l 1] $inf(vprefix)$name;"
443 if {![string compare [lindex $tname 2] 1]} {
444 if {![info exist inf(defined,[lindex $tname 0])]} {
448 set inf(var,$inf(nodef)) [join [lindex $l 2] \n]
452 set decl "typedef struct $inf(vprefix)$name $inf(vprefix)$name;"
453 set inf(var,$inf(nodef)) "[lindex $l 1];"
459 puts $file(outh) $decl
460 puts $file(outh) $fdef
461 asnForwardTypes $name
463 lappend inf(forward,code,[lindex $tname 0]) {} $decl $fdef
464 lappend inf(forward,ref,[lindex $tname 0]) $name
468 proc asnForwardTypes {name} {
471 if {![info exists inf(forward,code,$inf(fprefix)$name)]} {
474 foreach r $inf(forward,code,$inf(fprefix)$name) {
477 unset inf(forward,code,$inf(fprefix)$name)
479 while {[info exists inf(forward,ref,$inf(fprefix)$name)]} {
480 set n $inf(forward,ref,$inf(fprefix)$name)
481 set m [lrange $n 1 end]
483 set inf(forward,ref,$inf(fprefix)$name) $m
485 unset inf(forward,ref,$inf(fprefix)$name)
487 asnForwardTypes [lindex $n 0]
491 # asnSimple: parses simple type definition and generates C code
493 # $name is the name we are defining
494 # $tname is the tname as returned by asnType
495 # $tag is the tag as returned by asnMod
496 # $implicit is the implicit indicator as returned by asnMod
499 # Note: Doesn't take care of enum lists yet.
500 proc asnSimple {name tname tag implicit tagtype} {
503 set j "[lindex $tname 1] "
505 if {[info exists inf(unionmap,$inf(module),$name)]} {
506 set uName $inf(unionmap,$inf(module),$name)
512 if {![string length $tag]} {
513 set l "\treturn [lindex $tname 0] (o, p, opt, name);"
514 } elseif {$implicit} {
516 "\treturn odr_implicit_tag (o, [lindex $tname 0], p, $tagtype, $tag, opt, name);"
519 "\treturn odr_explicit_tag (o, [lindex $tname 0], p, $tagtype, $tag, opt, name);" \
521 if {[info exists jj]} {
522 return [list $l $j $jj]
528 # asnSequence: parses "SEQUENCE { s-list }" and generates C code.
530 # $name is the type we are defining
535 proc asnSequence {name tag implicit tagtype} {
538 lappend j "struct $inf(vprefix)$name \{"
541 if {![string length $tag]} {
542 lappend l "\tif (!odr_sequence_begin (o, p, sizeof(**p), name))"
543 lappend l "\t\treturn opt && odr_ok (o);"
544 } elseif {$implicit} {
545 lappend l "\tif (!odr_implicit_settag (o, $tagtype, $tag) ||"
546 lappend l "\t\t!odr_sequence_begin (o, p, sizeof(**p), name))"
547 lappend l "\t\treturn opt && odr_ok(o);"
549 lappend l "\tif (!odr_constructed_begin (o, p, $tagtype, $tag, name)"
550 lappend l "\t\treturn opt && odr_ok(o);"
551 lappend l "\tif (o->direction == ODR_DECODE)"
552 lappend l "\t\t*p = odr_malloc (o, sizeof(**p));"
554 lappend l "\tif (!odr_sequence_begin (o, p, sizeof(**p), 0))"
556 lappend l "\t\t*p = 0;"
557 lappend l "\t\treturn 0;"
562 set p [lindex [asnName $name] 0]
563 asnMod ltag limplicit ltagtype
567 if {[info exists inf(unionmap,$inf(module),$name,$p)]} {
568 set uName $inf(unionmap,$inf(module),$name,$p)
571 if {![string compare $t Simple]} {
572 if {[string compare $uName { }]} {
578 set opt [asnOptional]
579 if {![string length $ltag]} {
580 lappend l "\t\t[lindex $tname 0](o, &(*p)->$p, $opt, \"$p\") &&"
581 } elseif {$limplicit} {
582 lappend l "\t\todr_implicit_tag (o, [lindex $tname 0],"
583 lappend l "\t\t\t&(*p)->$p, $ltagtype, $ltag, $opt, \"$p\") &&"
585 lappend l "\t\todr_explicit_tag (o, [lindex $tname 0],"
586 lappend l "\t\t\t&(*p)->$p, $ltagtype, $ltag, $opt, \"$p\") &&"
588 set dec "\t[lindex $tname 1] *$p;"
589 } elseif {![string compare $t SequenceOf] && [string length $uName] &&\
590 (![string length $ltag] || $limplicit)} {
593 if {[llength $uName] < 2} {
594 set uName [list num_$p $p]
596 if {[string length $ltag]} {
600 lappend l "\t\todr_implicit_settag (o, $ltagtype, $ltag) &&"
605 set tmpa "odr_sequence_of(o, (Odr_fun) [lindex $tname 0], &(*p)->$p,"
606 set tmpb "&(*p)->[lindex $uName 0], \"$p\")"
607 lappend j "\tint [lindex $uName 0];"
608 set dec "\t[lindex $tname 1] **[lindex $uName 1];"
611 set subName [mapName ${name}_$level]
612 asnSub $subName $u {} {} 0 {}
614 set tmpa "odr_sequence_of(o, (Odr_fun) $inf(fprefix)$subName, &(*p)->$p,"
615 set tmpb "&(*p)->[lindex $uName 0], \"$p\")"
616 lappend j "\tint [lindex $uName 0];"
617 set dec "\t$inf(vprefix)$subName **[lindex $uName 1];"
621 set opt [asnOptional]
623 lappend l "\t\t($tmpa"
624 lappend l "\t\t $tmpb || odr_ok(o)) &&"
626 lappend l "\t\t$tmpa"
627 lappend l "\t\t $tmpb &&"
629 } elseif {!$nchoice && ![string compare $t Choice] && \
630 [string length $uName]} {
631 if {[llength $uName] < 3} {
632 set uName [list which u $name]
635 lappend j "\tint [lindex $uName 0];"
636 lappend j "\tunion \{"
637 lappend v "\tstatic Odr_arm arm\[\] = \{"
638 asnArm $name [lindex $uName 2] v j
640 set dec "\t\} [lindex $uName 1];"
641 set opt [asnOptional]
644 if {[string length $ltag]} {
646 lappend l "\t\todr_implicit_settag (o, $ltagtype, $ltag) &&"
648 asnWarning "optional handling missing in CHOICE in SEQUENCE"
649 asnWarning " set unionmap($inf(module),$name,$p) to {}"
657 lappend l "\t\t${la}odr_constructed_begin (o, &(*p)->[lindex $uName 1], $ltagtype, $ltag, \"$p\") &&"
662 set ob " || odr_ok(o))"
665 lappend l "\t\t${oa}odr_choice (o, arm, &(*p)->[lindex $uName 1], &(*p)->[lindex $uName 0], 0)${ob} &&"
666 if {[string length $ltag]} {
669 set lb ") || odr_ok(o))"
673 lappend l "\t\todr_constructed_end (o)${lb} &&"
677 set subName [mapName ${name}_$level]
678 asnSub $subName $t {} {} 0 {}
679 set opt [asnOptional]
680 if {![string length $ltag]} {
681 lappend l "\t\t$inf(fprefix)${subName} (o, &(*p)->$p, $opt, \"$p\") &&"
682 } elseif {$limplicit} {
683 lappend l "\t\todr_implicit_tag (o, $inf(fprefix)${subName},"
684 lappend l "\t\t\t&(*p)->$p, $ltagtype, $ltag, $opt, \"$p\") &&"
686 lappend l "\t\todr_explicit_tag (o, $inf(fprefix)${subName},"
687 lappend l "\t\t\t&(*p)->$p, $ltagtype, $ltag, $opt, \"$p\") &&"
689 set dec "\t$inf(vprefix)${subName} *$p;"
693 lappend j "$dec /* OPT */"
697 if {[string compare $type ,]} break
700 if {[string length $tag] && !$implicit} {
701 lappend l "\t\todr_sequence_end (o) &&"
702 lappend l "\t\todr_constructed_end (o);"
704 lappend l "\t\todr_sequence_end (o);"
706 if {[string compare $type \}]} {
707 asnError "Missing \} got $type '$val'"
710 if {[info exists v]} {
713 return [list [join $l \n] [join $j \n]]
716 # asnOf: parses "SEQUENCE/SET OF type" and generates C code.
718 # $name is the type we are defining
723 proc asnOf {name tag implicit tagtype isset} {
729 set func odr_sequence_of
732 if {[info exists inf(unionmap,$inf(module),$name)]} {
733 set numName $inf(unionmap,$inf(module),$name)
735 set numName {num elements}
738 lappend j "struct $inf(vprefix)$name \{"
739 lappend j "\tint [lindex $numName 0];"
741 lappend l "\tif (!odr_initmember (o, p, sizeof(**p)))"
742 lappend l "\t\treturn opt && odr_ok(o);"
743 if {[string length $tag]} {
745 lappend l "\todr_implicit_settag (o, $tagtype, $tag);"
747 asnWarning "Constructed SEQUENCE/SET OF not handled"
750 set t [asnType $name]
754 lappend l "\tif ($func (o, (Odr_fun) [lindex $tname 0], &(*p)->[lindex $numName 1],"
755 lappend l "\t\t&(*p)->[lindex $numName 0], name))"
756 lappend j "\t[lindex $tname 1] **[lindex $numName 1];"
759 set subName [mapName ${name}_s]
760 lappend l "\tif ($func (o, (Odr_fun) $inf(fprefix)$subName, &(*p)->[lindex $numName 1],"
761 lappend l "\t\t&(*p)->[lindex $numName 0], name))"
762 lappend j "\t$inf(vprefix)$subName **[lindex $numName 1];"
763 asnSub $subName $t {} {} 0 {}
767 lappend l "\t\treturn 1;"
768 lappend l "\t*p = 0;"
769 lappend l "\treturn opt && odr_ok(o);"
770 return [list [join $l \n] [join $j \n]]
773 # asnArm: parses c-list in choice
774 proc asnArm {name defname lx jx} {
780 set pq [asnName $name]
783 if {![string length $q]} {
787 asnMod ltag limplicit ltagtype
790 lappend enums "$inf(dprefix)$p"
791 if {![string compare $t Simple]} {
793 if {![string length $ltag]} {
794 lappend l "\t\t\{-1, -1, -1, $inf(dprefix)$p,"
795 lappend l "\t\t (Odr_fun) [lindex $tname 0], \"$q\"\},"
796 } elseif {$limplicit} {
797 lappend l "\t\t\{ODR_IMPLICIT, $ltagtype, $ltag, $inf(dprefix)$p,"
798 lappend l "\t\t(Odr_fun) [lindex $tname 0], \"$q\"\},"
800 lappend l "\t\t\{ODR_EXPLICIT, $ltagtype, $ltag, $inf(dprefix)$p,"
801 lappend l "\t\t(Odr_fun) [lindex $tname 0], \"$q\"\},"
803 lappend j "\t\t[lindex $tname 1] *$q;"
805 set subName [mapName ${name}_$q]
806 if {![string compare $inf(dprefix)${name}_$q \
807 $inf(vprefix)$subName]} {
808 set po [string toupper [string index $q 0]][string \
810 set subName [mapName ${name}${po}]
812 asnSub $subName $t $tname {} 0 {}
813 if {![string length $ltag]} {
814 lappend l "\t\t\{-1, -1, -1, $inf(dprefix)$p,"
815 lappend l "\t\t (Odr_fun) $inf(fprefix)$subName, \"$q\"\},"
816 } elseif {$limplicit} {
817 lappend l "\t\t\{ODR_IMPLICIT, $ltagtype, $ltag, $inf(dprefix)$p,"
818 lappend l "\t\t(Odr_fun) $inf(fprefix)$subName, \"$q\"\},"
820 lappend l "\t\t\{ODR_EXPLICIT, $ltagtype, $ltag, $inf(dprefix)$p,"
821 lappend l "\t\t(Odr_fun) $inf(fprefix)$subName, \"$q\"\},"
823 lappend j "\t\t$inf(vprefix)$subName *$q;"
825 if {[string compare $type ,]} break
827 if {[string compare $type \}]} {
828 asnError "Missing \} got $type '$val'"
833 lappend j "#define $e $level"
836 lappend l "\t\t\{-1, -1, -1, -1, (Odr_fun) 0, 0\}"
839 # asnChoice: parses "CHOICE {c-list}" and generates C code.
841 # $name is the type we are defining
846 proc asnChoice {name tag implicit tagtype} {
849 if {[info exists inf(unionmap,$inf(module),$name)]} {
850 set uName $inf(unionmap,$inf(module),$name)
852 set uName [list which u $name]
855 lappend j "struct $inf(vprefix)$name \{"
856 lappend j "\tint [lindex $uName 0];"
857 lappend j "\tunion \{"
858 lappend l "\tstatic Odr_arm arm\[\] = \{"
859 asnArm $name [lindex $uName 2] l j
860 lappend j "\t\} [lindex $uName 1];"
863 if {![string length $tag]} {
864 lappend l "\tif (!odr_initmember(o, p, sizeof(**p)))"
865 lappend l "\t\treturn opt && odr_ok(o);"
866 lappend l "\tif (odr_choice(o, arm, &(*p)->[lindex $uName 1], &(*p)->[lindex $uName 0], name))"
867 } elseif {$implicit} {
868 lappend l "\tif (!odr_initmember(o, p, sizeof(**p)))"
869 lappend l "\t\treturn opt && odr_ok(o);"
870 lappend l "\todr_implicit_settag(o, $tagtype, $tag);"
871 lappend l "\tif (odr_choice(o, arm, &(*p)->[lindex $uName 1], &(*p)->[lindex $uName 0], name))"
873 lappend l "\tif (!*p && o->direction != ODR_DECODE)"
874 lappend l "\t\treturn opt;"
875 lappend l "\tif (!odr_constructed_begin(o, p, $tagtype, $tag, 0))"
876 lappend l "\t\treturn opt && odr_ok(o);"
877 lappend l "\tif (!odr_initmember(o, p, sizeof(**p)))"
878 lappend l "\t\treturn opt && odr_ok(o);"
879 lappend l "\tif (odr_choice(o, arm, &(*p)->[lindex $uName 1], &(*p)->[lindex $uName 0], name) &&"
880 lappend l "\t\todr_constructed_end(o))"
882 lappend l "\t\treturn 1;"
883 lappend l "\t*p = 0;"
884 lappend l "\treturn opt && odr_ok(o);"
885 return [list [join $l \n] [join $j \n]]
888 # asnImports: parses i-list in "IMPORTS {i-list}"
889 # On return inf(import,..)-array is updated.
890 # inf(import,"module") is a list of {C-handler, C-type} elements.
891 # The {C-handler, C-type} is compatible with the $tname as is used by the
892 # asnType procedure to solve external references.
894 global type val inf file
897 if {[string compare $type n]} {
898 asnError "Missing name in IMPORTS list"
902 if {![string compare $type n] && ![string compare $val FROM]} {
905 if {[info exists inf(filename,$val)]} {
906 set fname $inf(filename,$val)
910 puts $file(outh) "\#include \"${fname}.h\""
912 if {[info exists inf(prefix,$val)]} {
913 set prefix $inf(prefix,$val)
915 set prefix $inf(prefix)
918 set m [join [split $n -] _]
919 set inf(imports,$n) [list [lindex $prefix 0]$m \
920 [lindex $prefix 1]$m]
924 if {[string compare $type n]} break
925 } elseif {![string compare $type ,]} {
929 if {[string compare $type \;]} {
930 asnError "Missing ; after IMPORTS list - got $type '$val'"
935 # asnExports: parses e-list in "EXPORTS {e-list}"
936 # This function does nothing with elements in the list.
941 if {[string compare $type n]} {
942 asnError "Missing name in EXPORTS list"
944 set inf(exports,$val) 1
946 if {[string compare $type ,]} break
949 if {[string compare $type \;]} {
950 asnError "Missing ; after EXPORTS list - got $type ($val)"
955 # asnModuleBody: parses a module specification and generates C code.
956 # Exports lists, imports lists, and type definitions are handled;
957 # other things are silently ignored.
958 proc asnModuleBody {} {
959 global type val file inf
961 if {[info exists inf(prefix,$inf(module))]} {
962 set prefix $inf(prefix,$inf(module))
964 set prefix $inf(prefix)
966 set inf(fprefix) [lindex $prefix 0]
967 set inf(vprefix) [lindex $prefix 1]
968 set inf(dprefix) [lindex $prefix 2]
969 if {[llength $prefix] > 3} {
970 set inf(cprefix) [lindex $prefix 3]
972 set inf(cprefix) {YAZ_EXPORT }
976 puts "Module $inf(module), $inf(lineno)"
980 if {[info exists inf(init,$inf(module),c)]} {
981 puts $file(outc) $inf(init,$inf(module),c)
983 if {[info exists inf(init,$inf(module),h)]} {
984 puts $file(outh) "\#ifdef __cplusplus"
985 puts $file(outh) "extern \"C\" \{"
986 puts $file(outh) "\#endif"
988 puts $file(outh) $inf(init,$inf(module),h)
990 if {[info exists inf(init,$inf(module),p)]} {
991 puts $file(outp) $inf(init,$inf(module),p)
994 while {[string length $type]} {
995 if {[string compare $type n]} {
999 if {![string compare $val END]} {
1001 } elseif {![string compare $val EXPORTS]} {
1004 } elseif {![string compare $val IMPORTS]} {
1006 puts $file(outh) "\#ifdef __cplusplus"
1007 puts $file(outh) "\}"
1008 puts $file(outh) "\#endif"
1015 puts $file(outh) "\#ifdef __cplusplus"
1016 puts $file(outh) "extern \"C\" \{"
1017 puts $file(outh) "\#endif"
1020 set inf(asndef) $inf(nodef)
1023 if {![string compare $type :]} {
1027 } elseif {![string compare $type n]} {
1029 if {[string length $type]} {
1036 puts $file(outh) "\#ifdef __cplusplus"
1037 puts $file(outh) "\}"
1038 puts $file(outh) "\#endif"
1041 foreach x [array names inf imports,*] {
1046 # asnTagDefault: parses TagDefault section
1047 proc asnTagDefault {} {
1048 global type val inf file
1050 set inf(implicit-tags) 0
1051 while {[string length $type]} {
1052 if {[lex-name-move EXPLICIT]} {
1054 set inf(implicit-tags) 0
1055 } elseif {[lex-name-move IMPLICIT]} {
1057 set inf(implicit-tags) 1
1064 # asnModules: parses a collection of module specifications.
1065 # Depending on the module pattern, $inf(moduleP), a module is either
1066 # skipped or processed.
1067 proc asnModules {} {
1068 global type val inf file yc_version
1073 while {![string compare $type n]} {
1074 set inf(module) $val
1075 if {[info exists inf(moduleP)] && ![string match $inf(moduleP) $val]} {
1076 if {$inf(verbose)} {
1079 while {![lex-name-move END]} {
1086 while {![lex-name-move DEFINITIONS]} {
1088 if {![string length $type]} return
1092 if {[info exists inf(filename,$inf(module))]} {
1093 set fname $inf(filename,$inf(module))
1095 set fname $inf(module)
1097 set ppname [join [split $fname -] _]
1099 if {![info exists inf(c-file)]} {
1100 set inf(c-file) ${fname}.c
1102 set file(outc) [open $inf(c-file) w]
1104 if {![info exists inf(h-file)]} {
1105 set inf(h-file) ${fname}.h
1107 set file(outh) [open $inf(h-path)/$inf(h-file) w]
1109 if {![info exists inf(p-file)]} {
1110 set inf(p-file) ${fname}-p.h
1112 set file(outp) [open $inf(h-path)/$inf(p-file) w]
1114 set md [clock format [clock seconds]]
1116 puts $file(outc) "/* YC ${yc_version} $md */"
1117 puts $file(outc) "/* Module-C: $inf(module) */"
1120 puts $file(outh) "/* YC ${yc_version}: $md */"
1121 puts $file(outh) "/* Module-H $inf(module) */"
1124 puts $file(outp) "/* YC ${yc_version}: $md */"
1125 puts $file(outp) "/* Module-P: $inf(module) */"
1128 puts $file(outc) "\#include \"$inf(p-file)\""
1130 puts $file(outh) "\#ifndef ${ppname}_H"
1131 puts $file(outh) "\#define ${ppname}_H"
1133 puts $file(outh) "\#include <odr.h>"
1135 puts $file(outp) "\#ifndef ${ppname}_P_H"
1136 puts $file(outp) "\#define ${ppname}_P_H"
1138 puts $file(outp) "\#include \"$inf(h-file)\""
1141 puts $file(outp) "\#ifdef __cplusplus"
1142 puts $file(outp) "extern \"C\" \{"
1143 puts $file(outp) "\#endif"
1146 if {[string compare $type :]} {
1147 asnError "::= expected got $type '$val'"
1150 if {![lex-name-move BEGIN]} {
1151 asnError "BEGIN expected"
1156 if {[info exists file(outp)]} {
1161 for {set i 1} {$i < $inf(nodef)} {incr i} {
1162 puts $f $inf(var,$i)
1163 if {[info exists inf(asn,$i)]} {
1166 foreach comment $inf(asn,$i) {
1176 puts $file(outp) "\#ifdef __cplusplus"
1177 puts $file(outp) "\}"
1178 puts $file(outp) "\#endif"
1180 if {[info exists inf(body,$inf(module),h)]} {
1181 puts $file(outh) $inf(body,$inf(module),h)
1183 if {[info exists inf(body,$inf(module),c)]} {
1184 puts $file(outc) $inf(body,$inf(module),c)
1186 if {[info exists inf(body,$inf(module),p)]} {
1187 puts $file(outp) $inf(body,$inf(module),p)
1189 puts $file(outh) "\#endif"
1190 puts $file(outp) "\#endif"
1191 foreach f [array names file] {
1201 # asnFile: parses an ASN.1 specification file as specified in $inf(iname).
1205 if {$inf(verbose) > 1} {
1206 puts "Reading ASN.1 file $inf(iname)"
1210 set inf(inf) [open $inf(iname) r]
1216 # The following procedures are invoked by the asnType function.
1217 # Each procedure takes the form: asnBasic<TYPE> and they must return
1218 # two elements: the C function handler and the C type.
1219 # On entry upvar $name is the type we are defining and global, $inf(module), is
1220 # the current module name.
1222 proc asnBasicEXTERNAL {} {
1223 return {odr_external {Odr_external}}
1226 proc asnBasicINTEGER {} {
1227 return {odr_integer {int}}
1230 proc asnBasicENUMERATED {} {
1231 return {odr_enum {int}}
1234 proc asnBasicNULL {} {
1235 return {odr_null {Odr_null}}
1238 proc asnBasicBOOLEAN {} {
1239 return {odr_bool {bool_t}}
1242 proc asnBasicOCTET {} {
1244 lex-name-move STRING
1245 return {odr_octetstring {Odr_oct}}
1248 proc asnBasicBIT {} {
1250 lex-name-move STRING
1251 return {odr_bitstring {Odr_bitmask}}
1254 proc asnBasicOBJECT {} {
1256 lex-name-move IDENTIFIER
1257 return {odr_oid {Odr_oid}}
1260 proc asnBasicANY {} {
1263 return [list $inf(fprefix)ANY_$name void]
1266 # userDef: reads user definitions file $name
1267 proc userDef {name} {
1270 if {$inf(verbose) > 1} {
1271 puts "Reading definitions file $name"
1275 if {[info exists default-prefix]} {
1276 set inf(prefix) ${default-prefix}
1278 if {[info exists h-path]} {
1279 set inf(h-path) ${h-path}
1281 foreach m [array names prefix] {
1282 set inf(prefix,$m) $prefix($m)
1284 foreach m [array names body] {
1285 set inf(body,$m) $body($m)
1287 foreach m [array names init] {
1288 set inf(init,$m) $init($m)
1290 foreach m [array names filename] {
1291 set inf(filename,$m) $filename($m)
1293 foreach m [array names map] {
1294 set inf(map,$m) $map($m)
1296 foreach m [array names membermap] {
1297 set inf(membermap,$m) $membermap($m)
1299 foreach m [array names unionmap] {
1300 set inf(unionmap,$m) $unionmap($m)
1305 set inf(prefix) {yc_ Yc_ YC_}
1308 # Parse command line
1309 set l [llength $argv]
1312 set arg [lindex $argv $i]
1313 switch -glob -- $arg {
1318 set p [string range $arg 2 end]
1319 if {![string length $p]} {
1320 set p [lindex $argv [incr i]]
1325 set p [string range $arg 2 end]
1326 if {![string length $p]} {
1327 set p [lindex $argv [incr i]]
1332 set p [string range $arg 2 end]
1333 if {![string length $p]} {
1334 set p [lindex $argv [incr i]]
1339 set p [string range $arg 2 end]
1340 if {![string length $p]} {
1341 set p [lindex $argv [incr i]]
1346 set p [string range $arg 2 end]
1347 if {![string length $p]} {
1348 set p [lindex $argv [incr i]]
1353 set p [string range $arg 2 end]
1354 if {![string length $p]} {
1355 set p [lindex $argv [incr i]]
1360 set p [string range $arg 2 end]
1361 if {![string length $p]} {
1362 set p [lindex $argv [incr i]]
1364 if {[llength $p] == 1} {
1365 set inf(prefix) [list [string tolower $p] \
1366 [string toupper $p] [string toupper $p]]
1367 } elseif {[llength $p] == 3} {
1381 if {![info exists inf(iname)]} {
1382 puts "YAZ ODR Compiler ${yc_version}"
1383 puts -nonewline "Usage: ${argv0}"
1384 puts { [-v] [-c cfile] [-h hfile] [-p hfile] [-d dfile] [-I path]}
1385 puts { [-x prefix] [-m module] file}