gdb/
[deliverable/binutils-gdb.git] / gdb / testsuite / lib / dwarf.exp
1 # Copyright 2010-2013 Free Software Foundation, Inc.
2
3 # This program is free software; you can redistribute it and/or modify
4 # it under the terms of the GNU General Public License as published by
5 # the Free Software Foundation; either version 3 of the License, or
6 # (at your option) any later version.
7 #
8 # This program is distributed in the hope that it will be useful,
9 # but WITHOUT ANY WARRANTY; without even the implied warranty of
10 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 # GNU General Public License for more details.
12 #
13 # You should have received a copy of the GNU General Public License
14 # along with this program. If not, see <http://www.gnu.org/licenses/>.
15
16 # Return true if the target supports DWARF-2 and uses gas.
17 # For now pick a sampling of likely targets.
18 proc dwarf2_support {} {
19 if {[istarget *-*-linux*]
20 || [istarget *-*-gnu*]
21 || [istarget *-*-elf*]
22 || [istarget *-*-openbsd*]
23 || [istarget arm*-*-eabi*]
24 || [istarget arm*-*-symbianelf*]
25 || [istarget powerpc-*-eabi*]} {
26 return 1
27 }
28
29 return 0
30 }
31
32 # A DWARF assembler.
33 #
34 # All the variables in this namespace are private to the
35 # implementation. Also, any procedure whose name starts with "_" is
36 # private as well. Do not use these.
37 #
38 # Exported functions are documented at their definition.
39 #
40 # In addition to the hand-written functions documented below, this
41 # module automatically generates a function for each DWARF tag. For
42 # most tags, two forms are made: a full name, and one with the
43 # "DW_TAG_" prefix stripped. For example, you can use either
44 # 'DW_TAG_compile_unit' or 'compile_unit' interchangeably.
45 #
46 # There are two exceptions to this rule: DW_TAG_variable and
47 # DW_TAG_namespace. For these, the full name must always be used,
48 # as the short name conflicts with Tcl builtins. (Should future
49 # versions of Tcl or DWARF add more conflicts, this list will grow.
50 # If you want to be safe you should always use the full names.)
51 #
52 # Each tag procedure is defined like:
53 #
54 # proc DW_TAG_mumble {{attrs {}} {children {}}} { ... }
55 #
56 # ATTRS is an optional list of attributes.
57 # It is run through 'subst' in the caller's context before processing.
58 #
59 # Each attribute in the list has one of two forms:
60 # 1. { NAME VALUE }
61 # 2. { NAME VALUE FORM }
62 #
63 # In each case, NAME is the attribute's name.
64 # This can either be the full name, like 'DW_AT_name', or a shortened
65 # name, like 'name'. These are fully equivalent.
66 #
67 # If FORM is given, it should name a DW_FORM_ constant.
68 # This can either be the short form, like 'DW_FORM_addr', or a
69 # shortened version, like 'addr'. If the form is given, VALUE
70 # is its value; see below. In some cases, additional processing
71 # is done; for example, DW_FORM_strp manages the .debug_str
72 # section automatically.
73 #
74 # If FORM is 'SPECIAL_expr', then VALUE is treated as a location
75 # expression. The effective form is then DW_FORM_block, and VALUE
76 # is passed to the (internal) '_location' proc to be translated.
77 # This proc implements a miniature DW_OP_ assembler.
78 #
79 # If FORM is not given, it is guessed:
80 # * If VALUE starts with the "@" character, the rest of VALUE is
81 # looked up as a DWARF constant, and DW_FORM_sdata is used. For
82 # example, '@DW_LANG_c89' could be used.
83 # * If VALUE starts with the ":" character, then it is a label
84 # reference. The rest of VALUE is taken to be the name of a label,
85 # and DW_FORM_ref4 is used. See 'new_label' and 'define_label'.
86 # * Otherwise, VALUE is taken to be a string and DW_FORM_string is
87 # used.
88 # More form-guessing functionality may be added.
89 #
90 # CHILDREN is just Tcl code that can be used to define child DIEs. It
91 # is evaluated in the caller's context.
92 #
93 # Currently this code is missing nice support for CFA handling, and
94 # probably other things as well.
95
96 namespace eval Dwarf {
97 # True if the module has been initialized.
98 variable _initialized 0
99
100 # Constants from dwarf2.h.
101 variable _constants
102 # DW_AT short names.
103 variable _AT
104 # DW_FORM short names.
105 variable _FORM
106 # DW_OP short names.
107 variable _OP
108
109 # The current output file.
110 variable _output_file
111
112 # Note: The _cu_ values here also apply to type units (TUs).
113 # Think of a TU as a special kind of CU.
114
115 # Current CU count.
116 variable _cu_count
117
118 # The current CU's base label.
119 variable _cu_label
120
121 # The current CU's version.
122 variable _cu_version
123
124 # The current CU's address size.
125 variable _cu_addr_size
126 # The current CU's offset size.
127 variable _cu_offset_size
128
129 # Label generation number.
130 variable _label_num
131
132 # The deferred output array. The index is the section name; the
133 # contents hold the data for that section.
134 variable _deferred_output
135
136 # If empty, we should write directly to the output file.
137 # Otherwise, this is the name of a section to write to.
138 variable _defer
139
140 # The abbrev section. Typically .debug_abbrev but can be .debug_abbrev.dwo
141 # for Fission.
142 variable _abbrev_section
143
144 # The next available abbrev number in the current CU's abbrev
145 # table.
146 variable _abbrev_num
147
148 # The string table for this assembly. The key is the string; the
149 # value is the label for that string.
150 variable _strings
151
152 proc _process_one_constant {name value} {
153 variable _constants
154 variable _AT
155 variable _FORM
156 variable _OP
157
158 set _constants($name) $value
159
160 if {![regexp "^DW_(\[A-Z\]+)_(\[A-Za-z0-9_\]+)$" $name \
161 ignore prefix name2]} {
162 error "non-matching name: $name"
163 }
164
165 if {$name2 == "lo_user" || $name2 == "hi_user"} {
166 return
167 }
168
169 # We only try to shorten some very common things.
170 # FIXME: CFA?
171 switch -exact -- $prefix {
172 TAG {
173 # Create two procedures for the tag. These call
174 # _handle_DW_TAG with the full tag name baked in; this
175 # does all the actual work.
176 proc $name {{attrs {}} {children {}}} \
177 "_handle_DW_TAG $name \$attrs \$children"
178
179 # Filter out ones that are known to clash.
180 if {$name2 == "variable" || $name2 == "namespace"} {
181 set name2 "tag_$name2"
182 }
183
184 if {[info commands $name2] != {}} {
185 error "duplicate proc name: from $name"
186 }
187
188 proc $name2 {{attrs {}} {children {}}} \
189 "_handle_DW_TAG $name \$attrs \$children"
190 }
191
192 AT {
193 set _AT($name2) $name
194 }
195
196 FORM {
197 set _FORM($name2) $name
198 }
199
200 OP {
201 set _OP($name2) $name
202 }
203
204 default {
205 return
206 }
207 }
208 }
209
210 proc _read_constants {} {
211 global srcdir hex decimal
212 variable _constants
213
214 # DWARF name-matching regexp.
215 set dwrx "DW_\[a-zA-Z0-9_\]+"
216 # Whitespace regexp.
217 set ws "\[ \t\]+"
218
219 set fd [open [file join $srcdir .. .. include dwarf2.h]]
220 while {![eof $fd]} {
221 set line [gets $fd]
222 if {[regexp -- "^${ws}($dwrx)${ws}=${ws}($hex|$decimal),?$" \
223 $line ignore name value ignore2]} {
224 _process_one_constant $name $value
225 }
226 }
227 close $fd
228
229 set fd [open [file join $srcdir .. .. include dwarf2.def]]
230 while {![eof $fd]} {
231 set line [gets $fd]
232 if {[regexp -- \
233 "^DW_\[A-Z_\]+${ws}\\(($dwrx),${ws}($hex|$decimal)\\)$" \
234 $line ignore name value ignore2]} {
235 _process_one_constant $name $value
236 }
237 }
238 close $fd
239
240 set _constants(SPECIAL_expr) $_constants(DW_FORM_block)
241 }
242
243 proc _quote {string} {
244 # FIXME
245 return "\"${string}\\0\""
246 }
247
248 proc _nz_quote {string} {
249 # For now, no quoting is done.
250 return "\"${string}\""
251 }
252
253 proc _handle_DW_FORM {form value} {
254 switch -exact -- $form {
255 DW_FORM_string {
256 _op .ascii [_quote $value]
257 }
258
259 DW_FORM_flag_present {
260 # We don't need to emit anything.
261 }
262
263 DW_FORM_data4 -
264 DW_FORM_ref4 {
265 _op .4byte $value
266 }
267
268 DW_FORM_ref_addr {
269 variable _cu_offset_size
270 variable _cu_version
271 variable _cu_addr_size
272
273 if {$_cu_version == 2} {
274 set size $_cu_addr_size
275 } else {
276 set size $_cu_offset_size
277 }
278
279 _op .${size}byte $value
280 }
281
282 DW_FORM_ref1 -
283 DW_FORM_flag -
284 DW_FORM_data1 {
285 _op .byte $value
286 }
287
288 DW_FORM_sdata {
289 _op .sleb128 $value
290 }
291
292 DW_FORM_ref_udata -
293 DW_FORM_udata {
294 _op .uleb128 $value
295 }
296
297 DW_FORM_addr {
298 variable _cu_addr_size
299
300 _op .${_cu_addr_size}byte $value
301 }
302
303 DW_FORM_data2 -
304 DW_FORM_ref2 {
305 _op .2byte $value
306 }
307
308 DW_FORM_data8 -
309 DW_FORM_ref8 -
310 DW_FORM_ref_sig8 {
311 _op .8byte $value
312 }
313
314 DW_FORM_strp {
315 variable _strings
316 variable _cu_offset_size
317
318 if {![info exists _strings($value)]} {
319 set _strings($value) [new_label strp]
320 _defer_output .debug_string {
321 define_label $_strings($value)
322 _op .ascii [_quote $value]
323 }
324 }
325
326 _op .${_cu_offset_size}byte $_strings($value) "strp: $value"
327 }
328
329 SPECIAL_expr {
330 set l1 [new_label "expr_start"]
331 set l2 [new_label "expr_end"]
332 _op .uleb128 "$l2 - $l1" "expression"
333 define_label $l1
334 _location $value
335 define_label $l2
336 }
337
338 DW_FORM_block1 {
339 set len [string length $value]
340 if {$len > 255} {
341 error "DW_FORM_block1 length too long"
342 }
343 _op .byte $len
344 _op .ascii [_nz_quote $value]
345 }
346
347 DW_FORM_block2 -
348 DW_FORM_block4 -
349
350 DW_FORM_block -
351
352 DW_FORM_ref2 -
353 DW_FORM_indirect -
354 DW_FORM_sec_offset -
355 DW_FORM_exprloc -
356
357 DW_FORM_GNU_addr_index -
358 DW_FORM_GNU_str_index -
359 DW_FORM_GNU_ref_alt -
360 DW_FORM_GNU_strp_alt -
361
362 default {
363 error "unhandled form $form"
364 }
365 }
366 }
367
368 proc _guess_form {value varname} {
369 upvar $varname new_value
370
371 switch -exact -- [string range $value 0 0] {
372 @ {
373 # Constant reference.
374 variable _constants
375
376 set new_value $_constants([string range $value 1 end])
377 # Just the simplest.
378 return DW_FORM_sdata
379 }
380
381 : {
382 # Label reference.
383 variable _cu_label
384
385 set new_value "[string range $value 1 end] - $_cu_label"
386
387 return DW_FORM_ref4
388 }
389
390 default {
391 return DW_FORM_string
392 }
393 }
394 }
395
396 # Map NAME to its canonical form.
397 proc _map_name {name ary} {
398 variable $ary
399
400 if {[info exists ${ary}($name)]} {
401 set name [set ${ary}($name)]
402 }
403
404 return $name
405 }
406
407 proc _handle_DW_TAG {tag_name {attrs {}} {children {}}} {
408 variable _abbrev_section
409 variable _abbrev_num
410 variable _constants
411
412 set has_children [expr {[string length $children] > 0}]
413 set my_abbrev [incr _abbrev_num]
414
415 # We somewhat wastefully emit a new abbrev entry for each tag.
416 # There's no reason for this other than laziness.
417 _defer_output $_abbrev_section {
418 _op .uleb128 $my_abbrev "Abbrev start"
419 _op .uleb128 $_constants($tag_name) $tag_name
420 _op .byte $has_children "has_children"
421 }
422
423 _op .uleb128 $my_abbrev "Abbrev ($tag_name)"
424
425 foreach attr $attrs {
426 set attr_name [_map_name [lindex $attr 0] _AT]
427 set attr_value [uplevel 2 [list subst [lindex $attr 1]]]
428 if {[llength $attr] > 2} {
429 set attr_form [lindex $attr 2]
430 } else {
431 set attr_form [_guess_form $attr_value attr_value]
432 }
433 set attr_form [_map_name $attr_form _FORM]
434
435 _handle_DW_FORM $attr_form $attr_value
436
437 _defer_output $_abbrev_section {
438 _op .uleb128 $_constants($attr_name) $attr_name
439 _op .uleb128 $_constants($attr_form) $attr_form
440 }
441 }
442
443 _defer_output $_abbrev_section {
444 # Terminator.
445 _op .byte 0x0 Terminator
446 _op .byte 0x0 Terminator
447 }
448
449 if {$has_children} {
450 uplevel 2 $children
451
452 # Terminate children.
453 _op .byte 0x0 "Terminate children"
454 }
455 }
456
457 proc _emit {string} {
458 variable _output_file
459 variable _defer
460 variable _deferred_output
461
462 if {$_defer == ""} {
463 puts $_output_file $string
464 } else {
465 append _deferred_output($_defer) ${string}\n
466 }
467 }
468
469 proc _section {name} {
470 _emit " .section $name"
471 }
472
473 proc _defer_output {section body} {
474 variable _defer
475 variable _deferred_output
476
477 set old_defer $_defer
478 set _defer $section
479
480 if {![info exists _deferred_output($_defer)]} {
481 set _deferred_output($_defer) ""
482 _section $section
483 }
484
485 uplevel $body
486
487 set _defer $old_defer
488 }
489
490 proc _defer_to_string {body} {
491 variable _defer
492 variable _deferred_output
493
494 set old_defer $_defer
495 set _defer temp
496
497 set _deferred_output($_defer) ""
498
499 uplevel $body
500
501 set result $_deferred_output($_defer)
502 unset _deferred_output($_defer)
503
504 set _defer $old_defer
505 return $result
506 }
507
508 proc _write_deferred_output {} {
509 variable _output_file
510 variable _deferred_output
511
512 foreach section [array names _deferred_output] {
513 # The data already has a newline.
514 puts -nonewline $_output_file $_deferred_output($section)
515 }
516
517 # Save some memory.
518 unset _deferred_output
519 }
520
521 proc _op {name value {comment ""}} {
522 set text " ${name} ${value}"
523 if {$comment != ""} {
524 # Try to make stuff line up nicely.
525 while {[string length $text] < 40} {
526 append text " "
527 }
528 append text "/* ${comment} */"
529 }
530 _emit $text
531 }
532
533 proc _compute_label {name} {
534 return ".L${name}"
535 }
536
537 # Return a name suitable for use as a label. If BASE_NAME is
538 # specified, it is incorporated into the label name; this is to
539 # make debugging the generated assembler easier. If BASE_NAME is
540 # not specified a generic default is used. This proc does not
541 # define the label; see 'define_label'. 'new_label' attempts to
542 # ensure that label names are unique.
543 proc new_label {{base_name label}} {
544 variable _label_num
545
546 return [_compute_label ${base_name}[incr _label_num]]
547 }
548
549 # Define a label named NAME. Ordinarily, NAME comes from a call
550 # to 'new_label', but this is not required.
551 proc define_label {name} {
552 _emit "${name}:"
553 }
554
555 # Declare a global label. This is typically used to refer to
556 # labels defined in other files, for example a function defined in
557 # a .c file.
558 proc extern {args} {
559 foreach name $args {
560 _op .global $name
561 }
562 }
563
564 # A higher-level interface to label handling.
565 #
566 # ARGS is a list of label descriptors. Each one is either a
567 # single element, or a list of two elements -- a name and some
568 # text. For each descriptor, 'new_label' is invoked. If the list
569 # form is used, the second element in the list is passed as an
570 # argument. The label name is used to define a variable in the
571 # enclosing scope; this can be used to refer to the label later.
572 # The label name is also used to define a new proc whose name is
573 # the label name plus a trailing ":". This proc takes a body as
574 # an argument and can be used to define the label at that point;
575 # then the body, if any, is evaluated in the caller's context.
576 #
577 # For example:
578 #
579 # declare_labels int_label
580 # something { ... $int_label } ;# refer to the label
581 # int_label: constant { ... } ;# define the label
582 proc declare_labels {args} {
583 foreach arg $args {
584 set name [lindex $arg 0]
585 set text [lindex $arg 1]
586
587 upvar $name label_var
588 if {$text == ""} {
589 set label_var [new_label]
590 } else {
591 set label_var [new_label $text]
592 }
593
594 proc ${name}: {args} [format {
595 define_label %s
596 uplevel $args
597 } $label_var]
598 }
599 }
600
601 # This is a miniature assembler for location expressions. It is
602 # suitable for use in the attributes to a DIE. Its output is
603 # prefixed with "=" to make it automatically use DW_FORM_block.
604 # BODY is split by lines, and each line is taken to be a list.
605 # (FIXME should use 'info complete' here.)
606 # Each list's first element is the opcode, either short or long
607 # forms are accepted.
608 # FIXME argument handling
609 # FIXME move docs
610 proc _location {body} {
611 variable _constants
612 variable _cu_label
613 variable _cu_addr_size
614
615 foreach line [split $body \n] {
616 if {[lindex $line 0] == ""} {
617 continue
618 }
619 set opcode [_map_name [lindex $line 0] _OP]
620 _op .byte $_constants($opcode) $opcode
621
622 switch -exact -- $opcode {
623 DW_OP_addr {
624 _op .${_cu_addr_size}byte [lindex $line 1]
625 }
626
627 DW_OP_const1u -
628 DW_OP_const1s {
629 _op .byte [lindex $line 1]
630 }
631
632 DW_OP_const2u -
633 DW_OP_const2s {
634 _op .2byte [lindex $line 1]
635 }
636
637 DW_OP_const4u -
638 DW_OP_const4s {
639 _op .4byte [lindex $line 1]
640 }
641
642 DW_OP_const8u -
643 DW_OP_const8s {
644 _op .8byte [lindex $line 1]
645 }
646
647 DW_OP_constu {
648 _op .uleb128 [lindex $line 1]
649 }
650 DW_OP_consts {
651 _op .sleb128 [lindex $line 1]
652 }
653
654 DW_OP_GNU_implicit_pointer {
655 if {[llength $line] != 3} {
656 error "usage: DW_OP_GNU_implicit_pointer LABEL OFFSET"
657 }
658
659 # Here label is a section offset.
660 set label [lindex $line 1]
661 _op .${_cu_addr_size}byte $label
662 _op .sleb128 [lindex $line 2]
663 }
664
665 default {
666 if {[llength $line] > 1} {
667 error "Unimplemented: operands in location for $opcode"
668 }
669 }
670 }
671 }
672 }
673
674 # Emit a DWARF CU.
675 # OPTIONS is a list with an even number of elements containing
676 # option-name and option-value pairs.
677 # Current options are:
678 # is_64 0|1 - boolean indicating if you want to emit 64-bit DWARF
679 # default = 0 (32-bit)
680 # version n - DWARF version number to emit
681 # default = 4
682 # addr_size n - the size of addresses, 32 or 64
683 # default = 64
684 # fission 0|1 - boolean indicating if generating Fission debug info
685 # default = 0
686 # BODY is Tcl code that emits the DIEs which make up the body of
687 # the CU. It is evaluated in the caller's context.
688 proc cu {options body} {
689 variable _cu_count
690 variable _abbrev_section
691 variable _abbrev_num
692 variable _cu_label
693 variable _cu_version
694 variable _cu_addr_size
695 variable _cu_offset_size
696
697 # Establish the defaults.
698 set is_64 0
699 set _cu_version 4
700 set _cu_addr_size 8
701 set fission 0
702 set section ".debug_info"
703 set _abbrev_section ".debug_abbrev"
704
705 foreach { name value } $options {
706 switch -exact -- $name {
707 is_64 { set is_64 $value }
708 version { set _cu_version $value }
709 addr_size { set _cu_addr_size $value }
710 fission { set fission $value }
711 default { error "unknown option $name" }
712 }
713 }
714 set _cu_offset_size [expr { $is_64 ? 8 : 4 }]
715 if { $fission } {
716 set section ".debug_info.dwo"
717 set _abbrev_section ".debug_abbrev.dwo"
718 }
719
720 _section $section
721
722 set cu_num [incr _cu_count]
723 set my_abbrevs [_compute_label "abbrev${cu_num}_begin"]
724 set _abbrev_num 1
725
726 set _cu_label [_compute_label "cu${cu_num}_begin"]
727 set start_label [_compute_label "cu${cu_num}_start"]
728 set end_label [_compute_label "cu${cu_num}_end"]
729
730 define_label $_cu_label
731 if {$is_64} {
732 _op .4byte 0xffffffff
733 _op .8byte "$end_label - $start_label"
734 } else {
735 _op .4byte "$end_label - $start_label"
736 }
737 define_label $start_label
738 _op .2byte $_cu_version Version
739 _op .4byte $my_abbrevs Abbrevs
740 _op .byte $_cu_addr_size "Pointer size"
741
742 _defer_output $_abbrev_section {
743 define_label $my_abbrevs
744 }
745
746 uplevel $body
747
748 _defer_output $_abbrev_section {
749 # Emit the terminator.
750 _op .byte 0x0 Terminator
751 _op .byte 0x0 Terminator
752 }
753
754 define_label $end_label
755 }
756
757 # Emit a DWARF TU.
758 # OPTIONS is a list with an even number of elements containing
759 # option-name and option-value pairs.
760 # Current options are:
761 # is_64 0|1 - boolean indicating if you want to emit 64-bit DWARF
762 # default = 0 (32-bit)
763 # version n - DWARF version number to emit
764 # default = 4
765 # addr_size n - the size of addresses, 32 or 64
766 # default = 64
767 # fission 0|1 - boolean indicating if generating Fission debug info
768 # default = 0
769 # SIGNATURE is the 64-bit signature of the type.
770 # TYPE_LABEL is the label of the type defined by this TU,
771 # or "" if there is no type (i.e., type stubs in Fission).
772 # BODY is Tcl code that emits the DIEs which make up the body of
773 # the TU. It is evaluated in the caller's context.
774 proc tu {options signature type_label body} {
775 variable _cu_count
776 variable _abbrev_section
777 variable _abbrev_num
778 variable _cu_label
779 variable _cu_version
780 variable _cu_addr_size
781 variable _cu_offset_size
782
783 # Establish the defaults.
784 set is_64 0
785 set _cu_version 4
786 set _cu_addr_size 8
787 set fission 0
788 set section ".debug_types"
789 set _abbrev_section ".debug_abbrev"
790
791 foreach { name value } $options {
792 switch -exact -- $name {
793 is_64 { set is_64 $value }
794 version { set _cu_version $value }
795 addr_size { set _cu_addr_size $value }
796 fission { set fission $value }
797 default { error "unknown option $name" }
798 }
799 }
800 set _cu_offset_size [expr { $is_64 ? 8 : 4 }]
801 if { $fission } {
802 set section ".debug_types.dwo"
803 set _abbrev_section ".debug_abbrev.dwo"
804 }
805
806 _section $section
807
808 set cu_num [incr _cu_count]
809 set my_abbrevs [_compute_label "abbrev${cu_num}_begin"]
810 set _abbrev_num 1
811
812 set _cu_label [_compute_label "cu${cu_num}_begin"]
813 set start_label [_compute_label "cu${cu_num}_start"]
814 set end_label [_compute_label "cu${cu_num}_end"]
815
816 define_label $_cu_label
817 if {$is_64} {
818 _op .4byte 0xffffffff
819 _op .8byte "$end_label - $start_label"
820 } else {
821 _op .4byte "$end_label - $start_label"
822 }
823 define_label $start_label
824 _op .2byte $_cu_version Version
825 _op .4byte $my_abbrevs Abbrevs
826 _op .byte $_cu_addr_size "Pointer size"
827 _op .8byte $signature Signature
828 if { $type_label != "" } {
829 uplevel declare_labels $type_label
830 upvar $type_label my_type_label
831 if {$is_64} {
832 _op .8byte "$my_type_label - $_cu_label"
833 } else {
834 _op .4byte "$my_type_label - $_cu_label"
835 }
836 } else {
837 if {$is_64} {
838 _op .8byte 0
839 } else {
840 _op .4byte 0
841 }
842 }
843
844 _defer_output $_abbrev_section {
845 define_label $my_abbrevs
846 }
847
848 uplevel $body
849
850 _defer_output $_abbrev_section {
851 # Emit the terminator.
852 _op .byte 0x0 Terminator
853 _op .byte 0x0 Terminator
854 }
855
856 define_label $end_label
857 }
858
859 proc _empty_array {name} {
860 upvar $name the_array
861
862 catch {unset the_array}
863 set the_array(_) {}
864 unset the_array(_)
865 }
866
867 # The top-level interface to the DWARF assembler.
868 # FILENAME is the name of the file where the generated assembly
869 # code is written.
870 # BODY is Tcl code to emit the assembly. It is evaluated via
871 # "eval" -- not uplevel as you might expect, because it is
872 # important to run the body in the Dwarf namespace.
873 #
874 # A typical invocation is something like:
875 # Dwarf::assemble $file {
876 # cu 0 2 8 {
877 # compile_unit {
878 # ...
879 # }
880 # }
881 # cu 0 2 8 {
882 # ...
883 # }
884 # }
885 proc assemble {filename body} {
886 variable _initialized
887 variable _output_file
888 variable _deferred_output
889 variable _defer
890 variable _label_num
891 variable _strings
892 variable _cu_count
893
894 if {!$_initialized} {
895 _read_constants
896 set _initialized 1
897 }
898
899 set _output_file [open $filename w]
900 set _cu_count 0
901 _empty_array _deferred_output
902 set _defer ""
903 set _label_num 0
904 _empty_array _strings
905
906 # Not "uplevel" here, because we want to evaluate in this
907 # namespace. This is somewhat bad because it means we can't
908 # readily refer to outer variables.
909 eval $body
910
911 _write_deferred_output
912
913 catch {close $_output_file}
914 set _output_file {}
915 }
916 }
This page took 0.082623 seconds and 4 git commands to generate.