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

Last change on this file since 1348 was 1348, checked in by jrm21, 24 years ago

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