source: trunk/gsdl/packages/yaz/util/yaz-comp@ 1343

Last change on this file since 1343 was 1343, checked in by johnmcp, 24 years ago

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