64-bit BER integers. Fixes bug #114.
[yaz-moved-to-github.git] / util / yaz-asncomp
1 #!/usr/bin/tclsh
2 #
3 # yaz-comp: ASN.1 Compiler for YAZ
4 # (c) Index Data 1996-2007
5 # See the file LICENSE for details.
6 #
7
8 set yc_version 0.4
9
10 # Syntax for the ASN.1 supported:
11 # file   -> file module
12 #         | module
13 # module -> name skip DEFINITIONS ::= mbody END
14 # mbody  -> EXPORTS { nlist }
15 #         | IMPORTS { imlist }
16 #         | name ::= tmt
17 #         | skip
18 # tmt    -> tag mod type
19 # type   -> SEQUENCE { sqlist }
20 #         | SEQUENCE OF type
21 #         | CHOICE { chlist }
22 #         | basic enlist
23 #
24 # basic  -> INTEGER
25 #         | BOOLEAN
26 #         | OCTET STRING
27 #         | BIT STRING
28 #         | EXTERNAL
29 #         | name
30 # sqlist -> sqlist , name tmt opt
31 #         | name tmt opt
32 # chlist -> chlist , name tmt 
33 #         | name tmt 
34 # enlist -> enlist , name (n)
35 #         | name (n)
36 # imlist -> nlist FROM name
37 #           imlist nlist FROM name
38 # nlist  -> name
39 #         | nlist , name
40 # mod   -> IMPLICIT | EXPLICIT | e
41 # tag   -> [tagtype n] | [n] | e
42 # opt   -> OPTIONAL | e
43 #
44 # name    identifier/token 
45 # e       epsilon/empty 
46 # skip    one token skipped
47 # n       number
48 # tagtype APPLICATION, CONTEXT, etc.
49
50 # lex: moves input file pointer and returns type of token.
51 # The globals $type and $val are set. $val holds name if token
52 # is normal identifier name.
53 # sets global var type to one of:
54 #     {}     eof-of-file
55 #     \{     left curly brace 
56 #     \}     right curly brace
57 #     ,      comma
58 #     ;      semicolon
59 #     (      (n)
60 #     [      [n]
61 #     :      ::=
62 #     n      other token n
63 proc lex {} {
64     global inf val type
65     while {![string length $inf(str)]} {
66         incr inf(lineno)
67         set inf(cnt) [gets $inf(inf) inf(str)]
68         if {$inf(cnt) < 0} {
69             set type {}
70             return {}
71         }
72         lappend inf(asn,$inf(asndef)) $inf(str)
73         set l [string first -- $inf(str)]
74         if {$l >= 0} {
75             incr l -1
76             set inf(str) [string range $inf(str) 0 $l]
77         }
78         set inf(str) [string trim $inf(str)]
79     }
80     set s [string index $inf(str) 0]
81     set type $s
82     set val {}
83     switch -- $s {
84         \{ { }
85         \} { }
86         ,  { }
87         ;  { }
88         \(  { }
89         \)  { }
90         \[ { regexp {^\[[ ]*(.+)[ ]*\]} $inf(str) s val }
91         :  { regexp {^::=} $inf(str) s }
92         default {
93              regexp "^\[^,\t :\{\}();\]+" $inf(str) s
94              set type n
95              set val $s
96            }
97     }
98     set off [string length $s]
99     set inf(str) [string trim [string range $inf(str) $off end]]
100     return $type
101 }
102
103 # lex-expect: move pointer and expect token $t
104 proc lex-expect {t} {
105     global type val
106     lex
107     if {[string compare $t $type]} {
108         asnError "Got $type '$val', expected $t"
109     }
110 }
111
112 # lex-name-move: see if token is $name; moves pointer and returns
113 # 1 if it is; returns 0 otherwise.
114 proc lex-name-move {name} {
115     global type val
116     if {![string compare $type n] && ![string compare $val $name]} {
117         lex
118         return 1
119     }
120     return 0
121 }
122
123 # asnError: Report error and die
124 proc asnError {msg} {
125     global inf
126    
127     puts "Error in line $inf(lineno) in module $inf(module)"
128     puts " $msg"
129     error
130     exit 1
131 }
132
133 # asnWarning: Report warning and return
134 proc asnWarning {msg} {
135     global inf
136    
137     puts "Warning in line $inf(lineno) in module $inf(module)"
138     puts " $msg"
139 }
140
141 # asnEnum: parses enumerated list - { name1 (n), name2 (n), ... }
142 # Uses $name as prefix. If there really is a list, $lx holds the C
143 # preprocessor definitions on return; otherwise lx isn't set.
144 proc asnEnum {name lx} {
145     global type val inf
146
147     if {[string compare $type \{]} return
148     upvar $lx l
149     while {1} {
150         set pq [asnName $name]
151         set id [lindex $pq 0]
152         set id ${name}_$id
153         lex-expect n
154         lappend l "#define $inf(dprefix)$id $val"
155         lex-expect ")"
156         lex
157         if {[string compare $type ,]} break
158     }
159     if {[string compare $type \}]} {
160         asnError "Missing \} in enum list got $type '$val'"
161     }
162     lex
163 }
164
165 # asnMod: parses tag and modifier.
166 # $xtag and $ximplicit holds tag and implicit-indication on return.
167 # $xtag is empty if no tag was specified. $ximplicit is 1 on implicit
168 # tagging; 0 otherwise.
169 proc asnMod {xtag ximplicit xtagtype} {
170     global type val inf
171
172     upvar $xtag tag
173     upvar $ximplicit implicit
174     upvar $xtagtype tagtype
175
176     set tag {} 
177     set tagtype {}
178     if {![string compare $type \[]} {
179         if {[regexp {^([a-zA-Z]+)[ ]+([0-9]+)$} $val x tagtype tag]} {
180             set tagtype ODR_$tagtype 
181         } elseif {[regexp {^([0-9]+)$} $val x tag]} {
182             set tagtype ODR_CONTEXT
183         } else {
184             asnError "bad tag specification: $val"
185         }
186         lex
187     }
188     set implicit $inf(implicit-tags)
189     if {![string compare $type n]} {
190         if {![string compare $val EXPLICIT]} {
191             lex
192             set implicit 0
193         } elseif {![string compare $val IMPLICIT]} {
194             lex
195             set implicit 1
196         }
197     }
198 }
199
200 # asnName: moves pointer and expects name. Returns C-validated name.
201 proc asnName {name} {
202     global val inf
203     lex-expect n
204     if {[info exists inf(membermap,$inf(module),$name,$val)]} {
205             set nval $inf(membermap,$inf(module),$name,$val)
206         if {$inf(verbose)} {
207             puts " mapping member $name,$val to $nval"
208         }
209         if {![string match {[A-Z]*} $val]} {
210             lex
211         }
212     } else {
213         set nval $val
214         if {![string match {[A-Z]*} $val]} {
215             lex
216         }
217     }
218     return [join [split $nval -] _]
219 }
220
221 # asnOptional: parses optional modifier. Returns 1 if OPTIONAL was 
222 # specified; 0 otherwise.
223 proc asnOptional {} {
224     global type val
225     if {[lex-name-move OPTIONAL]} {
226         return 1
227     } elseif {[lex-name-move DEFAULT]} {
228         lex
229         return 0
230     }
231     return 0
232 }
233
234 # asnSizeConstraint: parses the optional SizeConstraint.
235 # Currently not used for anything.
236 proc asnSizeConstraint {} {
237     global type val
238     if {[lex-name-move SIZE]} {
239         asnSubtypeSpec
240     }
241 }
242
243 # asnSubtypeSpec: parses the SubtypeSpec ...
244 # Currently not used for anything. We now it's balanced however, i.e.
245 # (... ( ... ) .. )
246 proc asnSubtypeSpec {} {
247     global type val
248
249     if {[string compare $type "("]} {
250         return 
251     }
252     lex
253     set level 1
254     while {$level > 0} {
255         if {![string compare $type "("]} {
256             incr level
257         } elseif {![string compare $type ")"]} {
258             incr level -1
259         }
260         lex
261     }
262 }
263
264 # asnType: parses ASN.1 type.
265 # On entry $name should hold the name we are currently defining.
266 # Returns type indicator:
267 #   SequenceOf     SEQUENCE OF
268 #   Sequence       SEQUENCE 
269 #   SetOf          SET OF
270 #   Set            SET
271 #   Choice         CHOICE
272 #   Simple         Basic types.
273 #   In this casecalling procedure's $tname variable is a list holding:
274 #        {C-Function C-Type} if the type is IMPORTed or ODR defined.
275 #      or
276 #        {C-Function C-Type 1} if the type should be defined in this module
277 proc asnType {name} {
278     global type val inf
279     upvar tname tname
280
281     set tname {}
282     if {[string compare $type n]} {
283         asnError "Expects type specifier, but got $type"
284     }
285     set v $val
286     lex
287     switch -- $v {
288         SEQUENCE {
289             asnSizeConstraint
290             if {[lex-name-move OF]} {
291                 asnSubtypeSpec
292                 return SequenceOf
293             } else {
294                 asnSubtypeSpec
295                 return Sequence
296             }
297         }
298         SET {
299             asnSizeConstraint
300             if {[lex-name-move OF]} {
301                 asnSubtypeSpec
302                 return SetOf
303             } else {
304                 asnSubtypeSpec
305                 return Set
306             }
307         }
308         CHOICE {
309             asnSubtypeSpec
310             return Choice
311         }
312     }
313     if {[string length [info commands asnBasic$v]]} {
314         set tname [asnBasic$v]
315     } else {
316         if {[info exists inf(map,$inf(module),$v)]} {
317             set v $inf(map,$inf(module),$v)
318         }
319         if {[info exists inf(imports,$v)]} {
320             set tname $inf(imports,$v)
321         } else {
322             set w [join [split $v -] _]
323             set tname [list $inf(fprefix)$w $inf(vprefix)$w 1]
324         }
325     }
326     if {[lex-name-move DEFINED]} {
327         if {[lex-name-move BY]} {
328             lex
329         }
330     }
331     asnSubtypeSpec
332     return Simple
333 }
334
335 proc mapName {name} {
336     global inf
337     if {[info exists inf(map,$inf(module),$name)]} {
338         set name $inf(map,$inf(module),$name)
339         if {$inf(verbose)} {
340             puts -nonewline " $name ($inf(lineno))"
341             puts " mapping to $name"
342         }
343     } else {
344         if {$inf(verbose)} {
345             puts " $name ($inf(lineno))"
346         }
347     }
348     return $name
349 }
350
351 # asnDef: parses type definition (top-level) and generates C code
352 # On entry $name holds the type we are defining.
353 proc asnDef {name} {
354     global inf file
355
356     set name [mapName $name]
357     if {[info exist inf(defined,$inf(fprefix)$name)]} {
358         incr inf(definedl,$name)
359         if {$inf(verbose) > 1} {
360             puts "set map($inf(module),$name) $name$inf(definedl,$name)"
361         }
362     } else {
363         set inf(definedl,$name) 0
364     }
365     set mname [join [split $name -] _]
366     asnMod tag implicit tagtype
367     set t [asnType $mname]
368     asnSub $mname $t $tname $tag $implicit $tagtype
369 }
370
371
372 # asnSub: parses type and generates C-code
373 # On entry,
374 #   $name holds the type we are defining.
375 #   $t is the type returned by the asnType procedure.
376 #   $tname is the $tname set by the asnType procedure.
377 #   $tag is the tag as returned by asnMod
378 #   $implicit is the implicit indicator as returned by asnMod
379 proc asnSub {name t tname tag implicit tagtype} {
380     global file inf
381    
382     set ignore 0
383     set defname defined,$inf(fprefix)$name
384     if {[info exist inf($defname)]} {
385         asnWarning "$name already defined in line $inf($defname)"
386         set ignore 1
387     }
388     set inf($defname) $inf(lineno)
389     switch -- $t {
390         Sequence   { set l [asnSequence $name $tag $implicit $tagtype] }
391         SequenceOf { set l [asnOf $name $tag $implicit $tagtype 0] }
392         SetOf      { set l [asnOf $name $tag $implicit $tagtype 1] }
393         Choice     { set l [asnChoice $name $tag $implicit $tagtype] }
394         Simple     { set l [asnSimple $name $tname $tag $implicit $tagtype] }
395         default    { asnError "switch asnType case not handled" }
396     }
397     if {$ignore} return
398
399     puts $file(outc) {}
400     puts $file(outc) "int $inf(fprefix)$name (ODR o, $inf(vprefix)$name **p, int opt, const char *name)"
401     puts $file(outc) \{
402     puts $file(outc) [lindex $l 0]
403     puts $file(outc) \}
404     set ok 1
405     set fdef "$inf(cprefix)int $inf(fprefix)$name (ODR o, $inf(vprefix)$name **p, int opt, const char *name);"
406     switch -- $t {
407         Simple {
408             set decl "typedef [lindex $l 1] $inf(vprefix)$name;"
409             if {![string compare [lindex $tname 2] 1]} {
410                 if {![info exist inf(defined,[lindex $tname 0])]} {
411                     set ok 0
412                 }
413             }
414             set inf(var,$inf(nodef)) [join [lindex $l 2] \n]
415             incr inf(nodef)
416         }
417         default {
418             set decl "typedef struct $inf(vprefix)$name $inf(vprefix)$name;"
419             set inf(var,$inf(nodef)) "[lindex $l 1];"
420             incr inf(nodef)
421         }
422     }
423     if {$ok} {
424         puts $file(outh) {}
425         puts $file(outh) $decl
426         puts $file(outh) $fdef
427         asnForwardTypes $name
428     } else {
429         lappend inf(forward,code,[lindex $tname 0]) {} $decl $fdef
430         lappend inf(forward,ref,[lindex $tname 0]) $name
431     }
432 }
433
434 proc asnForwardTypes {name} {
435     global inf file
436
437     if {![info exists inf(forward,code,$inf(fprefix)$name)]} {
438         return 0
439     }
440     foreach r $inf(forward,code,$inf(fprefix)$name) {
441         puts $file(outh) $r
442     }
443     unset inf(forward,code,$inf(fprefix)$name)
444
445     while {[info exists inf(forward,ref,$inf(fprefix)$name)]} {
446         set n $inf(forward,ref,$inf(fprefix)$name)
447         set m [lrange $n 1 end]
448         if {[llength $m]} {
449             set inf(forward,ref,$inf(fprefix)$name) $m
450         } else {
451             unset inf(forward,ref,$inf(fprefix)$name)
452         }
453         asnForwardTypes [lindex $n 0]
454     }
455 }
456
457 # asnSimple: parses simple type definition and generates C code
458 # On entry,
459 #   $name is the name we are defining
460 #   $tname is the tname as returned by asnType
461 #   $tag is the tag as returned by asnMod
462 #   $implicit is the implicit indicator as returned by asnMod
463 # Returns,
464 #   {c-code, h-code}
465 # Note: Doesn't take care of enum lists yet.
466 proc asnSimple {name tname tag implicit tagtype} {
467     global inf
468
469     set j "[lindex $tname 1] "
470
471     if {[info exists inf(unionmap,$inf(module),$name)]} {
472         set uName $inf(unionmap,$inf(module),$name)
473     } else {
474         set uName $name
475     }
476
477     asnEnum $uName jj
478     if {![string length $tag]} {
479         set l "\treturn [lindex $tname 0] (o, p, opt, name);" 
480     } elseif {$implicit} {
481         set l \
482   "\treturn odr_implicit_tag (o, [lindex $tname 0], p, $tagtype, $tag, opt, name);" 
483     } else {
484         set l \
485   "\treturn odr_explicit_tag (o, [lindex $tname 0], p, $tagtype, $tag, opt, name);" \
486     }
487     if {[info exists jj]} {
488         return [list $l $j $jj]
489     } else {
490         return [list $l $j]
491     }
492 }
493
494 # asnSequence: parses "SEQUENCE { s-list }" and generates C code.
495 # On entry,
496 #   $name is the type we are defining
497 #   $tag tag 
498 #   $implicit
499 # Returns,
500 #   {c-code, h-code}
501 proc asnSequence {name tag implicit tagtype} {
502     global val type inf
503
504     lappend j "struct $inf(vprefix)$name \{"
505     set level 0
506     set nchoice 0
507     if {![string length $tag]} {
508         lappend l "\tif (!odr_sequence_begin (o, p, sizeof(**p), name))"
509         lappend l "\t\treturn odr_missing(o, opt, name) && odr_ok (o);"
510     } elseif {$implicit} {
511         lappend l "\tif (!odr_implicit_settag (o, $tagtype, $tag) ||"
512         lappend l "\t\t!odr_sequence_begin (o, p, sizeof(**p), name))"
513         lappend l "\t\treturn odr_missing(o, opt, name);"
514     } else {
515         lappend l "\tif (!odr_constructed_begin (o, p, $tagtype, $tag, name))"
516         lappend l "\t\treturn odr_missing(o, opt, name);"
517         lappend l "\tif (o->direction == ODR_DECODE)"
518         lappend l "\t\t*p = ($inf(vprefix)$name *) odr_malloc (o, sizeof(**p));"
519
520         lappend l "\tif (!odr_sequence_begin (o, p, sizeof(**p), 0))"
521         lappend l "\t\{"
522         lappend l "\t\tif(o->direction == ODR_DECODE)"
523         lappend l "\t\t\t*p = 0;"
524         lappend l "\t\treturn 0;"
525         lappend l "\t\}"
526     }
527     lappend l "\treturn"
528     while {1} {
529         set p [lindex [asnName $name] 0]
530         asnMod ltag limplicit ltagtype
531         set t [asnType $p]
532
533         set uName { }
534         if {[info exists inf(unionmap,$inf(module),$name,$p)]} {
535             set uName $inf(unionmap,$inf(module),$name,$p)
536         }
537
538         if {![string compare $t Simple]} {
539             if {[string compare $uName { }]} {
540                 set enumName $uName
541             } else {
542                 set enumName $name
543             }
544             asnEnum $enumName j
545             set opt [asnOptional]
546             if {![string length $ltag]} {
547                 lappend l "\t\t[lindex $tname 0](o, &(*p)->$p, $opt, \"$p\") &&"
548             } elseif {$limplicit} {
549                 lappend l "\t\todr_implicit_tag (o, [lindex $tname 0],"
550                 lappend l "\t\t\t&(*p)->$p, $ltagtype, $ltag, $opt, \"$p\") &&"
551             } else {
552                 lappend l "\t\todr_explicit_tag (o, [lindex $tname 0],"
553                 lappend l "\t\t\t&(*p)->$p, $ltagtype, $ltag, $opt, \"$p\") &&"
554             }
555             set dec "\t[lindex $tname 1] *$p;"
556         } elseif {![string compare $t SequenceOf] && [string length $uName] &&\
557                       (![string length $ltag] || $limplicit)} {
558             set u [asnType $p]
559            
560             if {[llength $uName] < 2} {
561                 set uName [list num_$p $p]
562             }
563             if {[string length $ltag]} {
564                 if {!$limplicit} {
565                     asnError explicittag
566                 }
567                 lappend l "\t\todr_implicit_settag (o, $ltagtype, $ltag) &&"
568             }
569             switch -- $u {
570                 Simple {
571                     asnEnum $name j
572                     set tmpa "odr_sequence_of(o, (Odr_fun) [lindex $tname 0], &(*p)->$p,"
573                     set tmpb "&(*p)->[lindex $uName 0], \"$p\")"
574                     lappend j "\tint [lindex $uName 0];"
575                     set dec "\t[lindex $tname 1] **[lindex $uName 1];"
576                 }
577                 default {
578                     set subName [mapName ${name}_$level]
579                     asnSub $subName $u {} {} 0 {}
580                     
581                     set tmpa "odr_sequence_of(o, (Odr_fun) $inf(fprefix)$subName, &(*p)->$p,"
582                     set tmpb "&(*p)->[lindex $uName 0], \"$p\")"
583                     lappend j "\tint [lindex $uName 0];"
584                     set dec "\t$inf(vprefix)$subName **[lindex $uName 1];"
585                     incr level
586                 }
587             }
588             set opt [asnOptional]
589             if {$opt} {
590                 lappend l "\t\t($tmpa"
591                 lappend l "\t\t  $tmpb || odr_ok(o)) &&"
592             } else {
593                 lappend l "\t\t$tmpa"
594                 lappend l "\t\t  $tmpb &&"
595             }
596         } elseif {!$nchoice && ![string compare $t Choice] && \
597                       [string length $uName]} {
598             if {[llength $uName] < 3} {
599                 set uName [list which u $name]
600                 incr nchoice
601             }
602             lappend j "\tint [lindex $uName 0];"
603             lappend j "\tunion \{"
604             lappend v "\tstatic Odr_arm arm\[\] = \{"
605             asnArm $name [lindex $uName 2] v j
606             lappend v "\t\};"
607             set dec "\t\} [lindex $uName 1];"
608             set opt [asnOptional]
609             set oa {}
610             set ob {}
611             if {[string length $ltag]} {
612                 if {$limplicit} {
613                     lappend l "\t\todr_implicit_settag (o, $ltagtype, $ltag) &&"
614                     if {$opt} {
615                         asnWarning "optional handling missing in CHOICE in SEQUENCE"
616                         asnWarning " set unionmap($inf(module),$name,$p) to {}"
617                     }
618                 } else {
619                     if {$opt} {
620                         set la "(("
621                     } else {
622                         set la ""
623                     }
624                     lappend l "\t\t${la}odr_constructed_begin (o, &(*p)->[lindex $uName 1], $ltagtype, $ltag, \"$p\") &&"
625                 }
626             } else {
627                 if {$opt} {
628                     set oa "("
629                     set ob " || odr_ok(o))" 
630                 }
631             }
632             lappend l "\t\t${oa}odr_choice (o, arm, &(*p)->[lindex $uName 1], &(*p)->[lindex $uName 0], 0)${ob} &&"
633             if {[string length $ltag]} {
634                 if {!$limplicit} {
635                     if {$opt} {
636                         set lb ") || odr_ok(o))"
637                     } else {
638                         set lb ""
639                     }
640                     lappend l "\t\todr_constructed_end (o)${lb} &&"
641                 } 
642             }
643         } else {
644             set subName [mapName ${name}_$level]
645             asnSub $subName $t {} {} 0 {}
646             set opt [asnOptional]
647             if {![string length $ltag]} {
648                 lappend l "\t\t$inf(fprefix)${subName} (o, &(*p)->$p, $opt, \"$p\") &&"
649             } elseif {$limplicit} {
650                 lappend l "\t\todr_implicit_tag (o, $inf(fprefix)${subName},"
651                 lappend l "\t\t\t&(*p)->$p, $ltagtype, $ltag, $opt, \"$p\") &&"
652             } else {
653                 lappend l "\t\todr_explicit_tag (o, $inf(fprefix)${subName},"
654                 lappend l "\t\t\t&(*p)->$p, $ltagtype, $ltag, $opt, \"$p\") &&"
655             }
656             set dec "\t$inf(vprefix)${subName} *$p;"
657             incr level
658         }
659         if {$opt} {
660             lappend j "$dec /* OPT */"
661         } else {
662             lappend j $dec
663         }
664         if {[string compare $type ,]} break
665     }
666     lappend j "\}"
667     if {[string length $tag] && !$implicit} {
668         lappend l "\t\todr_sequence_end (o) &&"
669         lappend l "\t\todr_constructed_end (o);"
670     } else {
671         lappend l "\t\todr_sequence_end (o);"
672     }
673     if {[string compare $type \}]} {
674         asnError "Missing \} got $type '$val'"
675     }
676     lex
677     if {[info exists v]} {
678         set l [concat $v $l]
679     }
680     return [list [join $l \n] [join $j \n]]
681 }
682
683 # asnOf: parses "SEQUENCE/SET OF type" and generates C code.
684 # On entry,
685 #   $name is the type we are defining
686 #   $tag tag 
687 #   $implicit
688 # Returns,
689 #   {c-code, h-code}
690 proc asnOf {name tag implicit tagtype isset} { 
691     global inf
692
693     if {$isset} {
694         set func odr_set_of
695     } else {
696         set func odr_sequence_of
697     }
698
699     if {[info exists inf(unionmap,$inf(module),$name)]} {
700         set numName $inf(unionmap,$inf(module),$name)
701     } else {
702         set numName {num elements}
703     }
704
705     lappend j "struct $inf(vprefix)$name \{"
706     lappend j "\tint [lindex $numName 0];"
707
708     lappend l "\tif (!odr_initmember (o, p, sizeof(**p)))"
709     lappend l "\t\treturn odr_missing(o, opt, name);"
710     if {[string length $tag]} {
711         if {$implicit} {
712             lappend l "\todr_implicit_settag (o, $tagtype, $tag);"
713         } else {
714             asnWarning "Constructed SEQUENCE/SET OF not handled"
715         }
716     }
717     set t [asnType $name]
718     switch -- $t {
719         Simple {
720             asnEnum $name j
721             lappend l "\tif ($func (o, (Odr_fun) [lindex $tname 0], &(*p)->[lindex $numName 1],"
722             lappend l "\t\t&(*p)->[lindex $numName 0], name))"
723             lappend j "\t[lindex $tname 1] **[lindex $numName 1];"
724         }
725         default {
726             set subName [mapName ${name}_s]
727             lappend l "\tif ($func (o, (Odr_fun) $inf(fprefix)$subName, &(*p)->[lindex $numName 1],"
728             lappend l "\t\t&(*p)->[lindex $numName 0], name))"
729             lappend j "\t$inf(vprefix)$subName **[lindex $numName 1];"
730             asnSub $subName $t {} {} 0 {}
731         }
732     }
733     lappend j "\}"
734     lappend l "\t\treturn 1;"
735     lappend l "\tif(o->direction == ODR_DECODE)"
736     lappend l "\t\t*p = 0;"
737     lappend l "\treturn odr_missing(o, opt, name);"
738     return [list [join $l \n] [join $j \n]]
739 }
740
741 # asnArm: parses c-list in choice
742 proc asnArm {name defname lx jx} {
743     global type val inf
744
745     upvar $lx l
746     upvar $jx j
747     while {1} {
748         set pq [asnName $name]
749         set p [lindex $pq 0]
750         set q [lindex $pq 1]
751         if {![string length $q]} {
752             set q $p
753             set p ${defname}_$p
754         }
755         asnMod ltag limplicit ltagtype
756         set t [asnType $q]
757
758         lappend enums "$inf(dprefix)$p"
759         if {![string compare $t Simple]} {
760             asnEnum $name j
761             if {![string length $ltag]} {
762                 lappend l "\t\t\{-1, -1, -1, $inf(dprefix)$p,"
763                 lappend l "\t\t (Odr_fun) [lindex $tname 0], \"$q\"\},"
764             } elseif {$limplicit} {
765                 lappend l "\t\t\{ODR_IMPLICIT, $ltagtype, $ltag, $inf(dprefix)$p,"
766                 lappend l "\t\t(Odr_fun) [lindex $tname 0], \"$q\"\},"
767             } else {
768                 lappend l "\t\t\{ODR_EXPLICIT, $ltagtype, $ltag, $inf(dprefix)$p,"
769                 lappend l "\t\t(Odr_fun) [lindex $tname 0], \"$q\"\},"
770             }
771             lappend j "\t\t[lindex $tname 1] *$q;"
772         } else {
773             set subName [mapName ${name}_$q]
774             if {![string compare $inf(dprefix)${name}_$q \
775                                  $inf(vprefix)$subName]} {
776                 set po [string toupper [string index $q 0]][string \
777                                                             range $q 1 end]
778                 set subName [mapName ${name}${po}]
779             }
780             asnSub $subName $t $tname {} 0 {}
781             if {![string length $ltag]} {
782                 lappend l "\t\t\{-1, -1, -1, $inf(dprefix)$p,"
783                 lappend l "\t\t (Odr_fun) $inf(fprefix)$subName, \"$q\"\},"
784             } elseif {$limplicit} {
785                 lappend l "\t\t\{ODR_IMPLICIT, $ltagtype, $ltag, $inf(dprefix)$p,"
786                 lappend l "\t\t(Odr_fun) $inf(fprefix)$subName, \"$q\"\},"
787             } else {
788                 lappend l "\t\t\{ODR_EXPLICIT, $ltagtype, $ltag, $inf(dprefix)$p,"
789                 lappend l "\t\t(Odr_fun) $inf(fprefix)$subName, \"$q\"\},"
790             }
791             lappend j "\t\t$inf(vprefix)$subName *$q;"
792         }
793         if {[string compare $type ,]} break
794     }
795     if {[string compare $type \}]} {
796         asnError "Missing \} got $type '$val'"
797     }
798     lex
799     set level 1
800     foreach e $enums {
801         lappend j "#define $e $level"
802         incr level
803     }
804     lappend l "\t\t\{-1, -1, -1, -1, (Odr_fun) 0, 0\}"
805 }
806
807 # asnChoice: parses "CHOICE {c-list}" and generates C code.
808 # On entry,
809 #   $name is the type we are defining
810 #   $tag tag 
811 #   $implicit
812 # Returns,
813 #   {c-code, h-code}
814 proc asnChoice {name tag implicit tagtype} {
815     global type val inf
816
817     if {[info exists inf(unionmap,$inf(module),$name)]} {
818         set uName $inf(unionmap,$inf(module),$name)
819     } else {
820         set uName [list which u $name]
821     }
822
823     lappend j "struct $inf(vprefix)$name \{"
824     lappend j "\tint [lindex $uName 0];"
825     lappend j "\tunion \{"
826     lappend l "\tstatic Odr_arm arm\[\] = \{"
827     asnArm $name [lindex $uName 2] l j
828     lappend j "\t\} [lindex $uName 1];"
829     lappend j "\}"
830     lappend l "\t\};"
831     if {![string length $tag]} {
832         lappend l "\tif (!odr_initmember(o, p, sizeof(**p)))"
833         lappend l "\t\treturn odr_missing(o, opt, name);"
834         lappend l "\tif (odr_choice(o, arm, &(*p)->[lindex $uName 1], &(*p)->[lindex $uName 0], name))"
835     } elseif {$implicit} {
836         lappend l "\tif (!odr_initmember(o, p, sizeof(**p)))"
837         lappend l "\t\treturn odr_missing(o, opt, name);"
838         lappend l "\todr_implicit_settag(o, $tagtype, $tag);"
839         lappend l "\tif (odr_choice(o, arm, &(*p)->[lindex $uName 1], &(*p)->[lindex $uName 0], name))"
840     } else {
841         lappend l "\tif (!odr_constructed_begin(o, p, $tagtype, $tag, 0))"
842         lappend l "\t\treturn odr_missing(o, opt, name);"
843         lappend l "\tif (!odr_initmember(o, p, sizeof(**p)))"
844         lappend l "\t\treturn odr_missing(o, opt, name);"
845         lappend l "\tif (odr_choice(o, arm, &(*p)->[lindex $uName 1], &(*p)->[lindex $uName 0], name) &&"
846         lappend l "\t\todr_constructed_end(o))"
847     }
848     lappend l "\t\treturn 1;"
849
850     lappend l "\tif(o->direction == ODR_DECODE)"
851     lappend l "\t\t*p = 0;"
852
853     lappend l "\treturn odr_missing(o, opt, name);"
854     return [list [join $l \n] [join $j \n]]
855 }
856
857 # asnImports: parses i-list in "IMPORTS {i-list}" 
858 # On return inf(import,..)-array is updated.
859 # inf(import,"module") is a list of {C-handler, C-type} elements.
860 # The {C-handler, C-type} is compatible with the $tname as is used by the
861 # asnType procedure to solve external references.
862 proc asnImports {} {
863     global type val inf file
864
865     while {1} {
866         if {[string compare $type n]} {
867             asnError "Missing name in IMPORTS list"
868         }
869         lappend nam $val
870         lex
871         if {![string compare $type n] && ![string compare $val FROM]} {
872             lex
873             
874             if {[info exists inf(filename,$val)]} {
875                 set fname $inf(filename,$val)
876             } else {
877                 set fname $val
878             }
879             puts $file(outh) "\#include <$inf(h-dir)${fname}.h>"
880
881             if {[info exists inf(prefix,$val)]} {
882                 set prefix $inf(prefix,$val)
883             } else {
884                 set prefix $inf(prefix)
885             }
886             foreach n $nam {
887                 if {[info exists inf(map,$val,$n)]} {
888                     set v $inf(map,$val,$n)
889                 } else {
890                     set v $n
891                 }
892                 set w [join [split $v -] _]
893                 set inf(imports,$n) [list [lindex $prefix 0]$w \
894                                           [lindex $prefix 1]$w]
895             }
896             unset nam
897             lex
898             if {[string compare $type n]} break
899         } elseif {![string compare $type ,]} {
900             lex
901         } else break
902     }
903     if {[string compare $type \;]} {
904         asnError "Missing ; after IMPORTS list - got $type '$val'"
905     }
906     lex
907 }
908
909 # asnExports: parses e-list in "EXPORTS {e-list}" 
910 # This function does nothing with elements in the list.
911 proc asnExports {} {
912     global type val inf
913
914     while {1} {
915         if {[string compare $type n]} {
916             asnError "Missing name in EXPORTS list"
917         }
918         set inf(exports,$val) 1
919         lex
920         if {[string compare $type ,]} break
921         lex
922     }
923     if {[string compare $type \;]} {
924         asnError "Missing ; after EXPORTS list - got $type ($val)"
925     }
926     lex
927 }
928
929 # asnModuleBody: parses a module specification and generates C code.
930 # Exports lists, imports lists, and type definitions are handled;
931 # other things are silently ignored.
932 proc asnModuleBody {} {
933     global type val file inf
934
935     if {[info exists inf(prefix,$inf(module))]} {
936         set prefix $inf(prefix,$inf(module))
937     } else {
938         set prefix $inf(prefix)
939     }
940     set inf(fprefix) [lindex $prefix 0]
941     set inf(vprefix) [lindex $prefix 1]
942     set inf(dprefix) [lindex $prefix 2]
943     if {[llength $prefix] > 3} {
944         set inf(cprefix) [lindex $prefix 3]
945     } else {
946         set inf(cprefix) {YAZ_EXPORT }
947     }
948
949     if {$inf(verbose)} {
950         puts "Module $inf(module), $inf(lineno)"
951     }
952
953     set defblock 0
954     if {[info exists inf(init,$inf(module),c)]} {
955         puts $file(outc) $inf(init,$inf(module),c)
956     }
957     if {[info exists inf(init,$inf(module),h)]} {
958         puts $file(outh) "\#ifdef __cplusplus"
959         puts $file(outh) "extern \"C\" \{"
960         puts $file(outh) "\#endif"
961         set defblock 1
962         puts $file(outh) $inf(init,$inf(module),h)
963     }
964     if {[info exists inf(init,$inf(module),p)]} {
965         puts $file(outp) $inf(init,$inf(module),p)
966     }
967
968     while {[string length $type]} {
969         if {[string compare $type n]} {
970             lex
971             continue
972         }
973         if {![string compare $val END]} {
974             break
975         } elseif {![string compare $val EXPORTS]} {
976             lex
977             asnExports
978         } elseif {![string compare $val IMPORTS]} {
979             if {$defblock} {
980                 puts $file(outh) "\#ifdef __cplusplus"
981                 puts $file(outh) "\}"
982                 puts $file(outh) "\#endif"
983                 set defblock 0
984             }
985             lex
986             asnImports
987         } else {
988             if {!$defblock} {
989                 puts $file(outh) "\#ifdef __cplusplus"
990                 puts $file(outh) "extern \"C\" \{"
991                 puts $file(outh) "\#endif"
992                 set defblock 1
993             }
994             set inf(asndef) $inf(nodef)
995             set oval $val
996             lex
997             if {![string compare $type :]} {
998                 lex
999                 asnDef $oval
1000                 set inf(asndef) 0
1001             } elseif {![string compare $type n]} {
1002                 lex
1003                 if {[string length $type]} {
1004                     lex
1005                 }
1006             }
1007         }
1008     }
1009     if {$defblock} {
1010         puts $file(outh) "\#ifdef __cplusplus"
1011         puts $file(outh) "\}"
1012         puts $file(outh) "\#endif"
1013         set defblock 0
1014     }
1015     foreach x [array names inf imports,*] {
1016         unset inf($x)
1017     }
1018 }
1019
1020 # asnTagDefault: parses TagDefault section
1021 proc asnTagDefault {} {
1022     global type val inf file
1023     
1024     set inf(implicit-tags) 0
1025     while {[string length $type]} {
1026         if {[lex-name-move EXPLICIT]} {
1027             lex
1028             set inf(implicit-tags) 0
1029         } elseif {[lex-name-move  IMPLICIT]} {
1030             lex
1031             set inf(implicit-tags) 1
1032         } else {
1033             break
1034         }
1035     }
1036 }
1037
1038 # asnModules: parses a collection of module specifications.
1039 # Depending on the module pattern, $inf(moduleP), a module is either
1040 # skipped or processed.
1041 proc asnModules {} {
1042     global type val inf file yc_version
1043
1044     set inf(nodef) 0
1045     set inf(asndef) 0
1046     lex
1047     while {![string compare $type n]} {
1048         set inf(module) $val
1049         if {[info exists inf(moduleP)] && ![string match $inf(moduleP) $val]} {
1050             if {$inf(verbose)} {
1051                 puts "Skipping $id"
1052             }
1053             while {![lex-name-move END]} {
1054                 lex
1055             }
1056         } else {
1057             set inf(nodef) 1
1058             set inf(asndef) 1
1059
1060             while {![lex-name-move DEFINITIONS]} {
1061                 lex
1062                 if {![string length $type]} return
1063             }
1064             if {[info exists inf(filename,$inf(module))]} {
1065                 set fname $inf(filename,$inf(module))
1066             } else {
1067                 set fname $inf(module)
1068             }
1069             set ppname [join [split $fname -] _]
1070
1071             if {![info exists inf(c-file)]} {
1072                 set inf(c-file) ${fname}.c
1073             }
1074             set file(outc) [open $inf(c-file) w]
1075
1076             if {![info exists inf(h-file)]} {
1077                 set inf(h-file) ${fname}.h
1078             }
1079             set file(outh) [open $inf(h-path)/$inf(h-dir)$inf(h-file) w]
1080
1081             if {0} {
1082                 if {![info exists inf(p-file)]} {
1083                     set inf(p-file) ${fname}-p.h
1084                 }
1085                 set file(outp) [open $inf(h-path)/$inf(h-dir)$inf(p-file) w]
1086             }
1087
1088             set greeting {Generated automatically by YAZ ASN.1 Compiler}
1089
1090             puts $file(outc) "/** \\file $inf(c-file)"
1091             puts $file(outc) "    \\brief ASN.1 Module $inf(module)"
1092             puts $file(outc) ""
1093             puts $file(outc) "    ${greeting} ${yc_version}"
1094             puts $file(outc) "*/"
1095             puts $file(outc) {}
1096
1097             puts $file(outh) "/** \\file $inf(h-file)"
1098             puts $file(outh) "    \\brief ASN.1 Module $inf(module)"
1099             puts $file(outh) ""
1100             puts $file(outh) "    ${greeting} ${yc_version}"
1101             puts $file(outh) "*/"
1102             puts $file(outh) {}
1103
1104             if {[info exists file(outp)]} {
1105                 puts $file(outp) "/** \\file $inf(p-file)"
1106                 puts $file(outp) "    \\brief ASN.1 Module $inf(module)"
1107                 puts $file(outp) ""
1108                 puts $file(outp) "    ${greeting} ${yc_version}"
1109                 puts $file(outp) "*/"
1110                 puts $file(outp) {}
1111             }
1112
1113             if {[info exists inf(p-file)]} {
1114                 puts $file(outc) "\#include <$inf(h-dir)$inf(p-file)>"
1115             } else {
1116                 puts $file(outc) "\#include <$inf(h-dir)$inf(h-file)>"
1117             }
1118             puts $file(outh) "\#ifndef ${ppname}_H"
1119             puts $file(outh) "\#define ${ppname}_H"
1120             puts $file(outh) {}
1121             puts $file(outh) "\#include <yaz/odr.h>"
1122            
1123             if {[info exists file(outp)]} { 
1124                 puts $file(outp) "\#ifndef ${ppname}_P_H"
1125                 puts $file(outp) "\#define ${ppname}_P_H"
1126                 puts $file(outp) {}
1127                 puts $file(outp) "\#include <$inf(h-dir)$inf(h-file)>"
1128
1129             }
1130             
1131             asnTagDefault
1132             if {[string compare $type :]} {
1133                 asnError "::= expected got $type '$val'"
1134             } 
1135             lex
1136             if {![lex-name-move BEGIN]} {
1137                 asnError "BEGIN expected"
1138             }
1139             asnModuleBody
1140             lex
1141
1142             if {[info exists file(outp)]} {
1143                 set f $file(outp)
1144             } else {
1145                 set f $file(outh)
1146             }
1147             puts $f "\#ifdef __cplusplus"
1148             puts $f "extern \"C\" \{"
1149             puts $f "\#endif"
1150             for {set i 1} {$i < $inf(nodef)} {incr i} {
1151                 puts $f $inf(var,$i)
1152                 if {[info exists inf(asn,$i)]} {
1153                     if {0} {
1154                         puts $f "/*"
1155                         foreach comment $inf(asn,$i) {
1156                             puts $f $comment
1157                         }
1158                         puts $f " */"
1159                     }
1160                     unset inf(asn,$i)
1161                 }
1162                 unset inf(var,$i)
1163                 puts $f {}
1164             }
1165             puts $f "\#ifdef __cplusplus"
1166             puts $f "\}"
1167             puts $f "\#endif"
1168
1169             if {[info exists inf(body,$inf(module),h)]} {
1170                 puts $file(outh) $inf(body,$inf(module),h)
1171             }
1172             if {[info exists inf(body,$inf(module),c)]} {
1173                 puts $file(outc) $inf(body,$inf(module),c)
1174             }
1175             if {[info exists inf(body,$inf(module),p)]} {
1176                 if {[info exists file(outp)]} {
1177                     puts $file(outp) $inf(body,$inf(module),p)
1178                 }
1179             }
1180             puts $file(outh) "\#endif"
1181             if {[info exists file(outp)]} {
1182                 puts $file(outp) "\#endif"
1183             }
1184             foreach f [array names file] {
1185                 close $file($f)
1186             }
1187             unset inf(c-file)
1188             unset inf(h-file)
1189             catch {unset inf(p-file)}
1190         }
1191     }
1192 }
1193
1194 # asnFile: parses an ASN.1 specification file as specified in $inf(iname).
1195 proc asnFile {} {
1196     global inf file
1197
1198     if {$inf(verbose) > 1} {
1199         puts "Reading ASN.1 file $inf(iname)"
1200     }
1201     set inf(str) {}
1202     set inf(lineno) 0
1203     set inf(inf) [open $inf(iname) r]
1204     
1205     asnModules
1206     
1207 }
1208
1209 # The following procedures are invoked by the asnType function. 
1210 # Each procedure takes the form: asnBasic<TYPE> and they must return
1211 # two elements: the C function handler and the C type.
1212 # On entry upvar $name is the type we are defining and global, $inf(module), is
1213 # the current module name.
1214
1215 proc asnBasicEXTERNAL {} {
1216     return {odr_external {Odr_external}}
1217 }
1218
1219 proc asnBasicINTEGER {} {
1220     return {odr_integer {odr_int_t}}
1221 }
1222
1223 proc asnBasicENUMERATED {} {
1224     return {odr_enum {odr_int_t}}
1225 }
1226
1227 proc asnBasicNULL {} {
1228     return {odr_null {Odr_null}}
1229 }
1230
1231 proc asnBasicBOOLEAN {} {
1232     return {odr_bool {bool_t}}
1233 }
1234
1235 proc asnBasicOCTET {} {
1236     global type val
1237     lex-name-move STRING
1238     return {odr_octetstring {Odr_oct}}
1239 }
1240
1241 proc asnBasicBIT {} {
1242     global type val
1243     lex-name-move STRING
1244     return {odr_bitstring {Odr_bitmask}}
1245 }
1246
1247 proc asnBasicOBJECT {} {
1248     global type val
1249     lex-name-move IDENTIFIER
1250     return {odr_oid {Odr_oid}}
1251 }
1252
1253 proc asnBasicGeneralString {} {
1254     return {odr_generalstring char}
1255 }
1256
1257 proc asnBasicVisibleString {} {
1258     return {odr_visiblestring char}
1259 }
1260
1261 proc asnBasicGeneralizedTime {} {
1262     return {odr_generalizedtime char}
1263 }
1264
1265 proc asnBasicANY {} {
1266     upvar name name
1267     global inf
1268     return [list $inf(fprefix)ANY_$name void]
1269 }
1270
1271 # userDef: reads user definitions file $name
1272 proc userDef {name} {
1273     global inf
1274
1275     if {$inf(verbose) > 1} {
1276         puts "Reading definitions file $name"
1277     }
1278     source $name
1279
1280     if {[info exists default-prefix]} {
1281         set inf(prefix) ${default-prefix}
1282     }
1283     if {[info exists h-path]} {
1284         set inf(h-path) ${h-path}
1285     }
1286     foreach m [array names prefix] {
1287         set inf(prefix,$m) $prefix($m)
1288     }
1289     foreach m [array names body] {
1290         set inf(body,$m) $body($m)
1291     }
1292     foreach m [array names init] {
1293         set inf(init,$m) $init($m)
1294     }
1295     foreach m [array names filename] {
1296         set inf(filename,$m) $filename($m)
1297     }
1298     foreach m [array names map] {
1299         set inf(map,$m) $map($m)
1300     }
1301     foreach m [array names membermap] {
1302         set inf(membermap,$m) $membermap($m)
1303     }
1304     foreach m [array names unionmap] {
1305         set inf(unionmap,$m) $unionmap($m)
1306     }
1307 }
1308
1309 set inf(verbose) 0
1310 set inf(prefix) {yc_ Yc_ YC_}
1311 set inf(h-path) .
1312 set inf(h-dir) ""
1313
1314 # Parse command line
1315 set l [llength $argv]
1316 set i 0
1317 while {$i < $l} {
1318     set arg [lindex $argv $i]
1319     switch -glob -- $arg {
1320         -v {
1321             incr inf(verbose) 
1322         }
1323         -c {
1324             set p [string range $arg 2 end]
1325             if {![string length $p]} {
1326                  set p [lindex $argv [incr i]]
1327              }
1328             set inf(c-file) $p
1329         }
1330         -I* {
1331             set p [string range $arg 2 end]
1332             if {![string length $p]} {
1333                  set p [lindex $argv [incr i]]
1334              }
1335             set inf(h-path) $p
1336         }
1337         -i* {
1338             set p [string range $arg 2 end]
1339             if {![string length $p]} {
1340                  set p [lindex $argv [incr i]]
1341             }
1342             set inf(h-dir) [string trim $p \\/]/
1343         }
1344         -h* {
1345             set p [string range $arg 2 end]
1346             if {![string length $p]} {
1347                  set p [lindex $argv [incr i]]
1348              }
1349             set inf(h-file) $p
1350         }
1351         -p* {
1352             set p [string range $arg 2 end]
1353             if {![string length $p]} {
1354                 set p [lindex $argv [incr i]]
1355             }
1356             set inf(p-file) $p
1357         }
1358         -d* {
1359             set p [string range $arg 2 end]
1360             if {![string length $p]} {
1361                 set p [lindex $argv [incr i]]
1362             }
1363             userDef $p
1364         }
1365         -m* {
1366             set p [string range $arg 2 end]
1367             if {![string length $p]} {
1368                 set p [lindex $argv [incr i]]
1369             }
1370             set inf(moduleP) $p
1371         }
1372         -x* {
1373             set p [string range $arg 2 end]
1374             if {![string length $p]} {
1375                 set p [lindex $argv [incr i]]
1376             }
1377             if {[llength $p] == 1} {
1378                 set inf(prefix) [list [string tolower $p] \
1379                                      [string toupper $p] [string toupper $p]]
1380             } elseif {[llength $p] == 3} {
1381                 set inf(prefix) $p
1382             } else {
1383                 puts [llength $p]
1384                 exit 1
1385             }
1386         }           
1387         default {
1388             set inf(iname) $arg
1389         }
1390     }
1391     incr i
1392 }
1393
1394 if {![info exists inf(iname)]} {
1395     puts "YAZ ASN.1 Compiler ${yc_version}"
1396     puts "Usage:"       
1397     puts -nonewline ${argv0}
1398     puts { [-v] [-c cfile] [-h hfile] [-p hfile] [-d dfile] [-I iout]}
1399     puts {    [-i idir] [-m module] file}
1400     exit 1
1401 }
1402
1403 asnFile