1 /* Support for printing Pascal values for GDB, the GNU debugger.
3 Copyright (C) 2000-2021 Free Software Foundation, Inc.
5 This file is part of GDB.
7 This program is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 3 of the License, or
10 (at your option) any later version.
12 This program is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with this program. If not, see <http://www.gnu.org/licenses/>. */
20 /* This file is derived from c-valprint.c */
23 #include "gdb_obstack.h"
26 #include "expression.h"
33 #include "typeprint.h"
39 #include "cp-support.h"
41 #include "gdbsupport/byte-vector.h"
42 #include "cli/cli-style.h"
45 static void pascal_object_print_value_fields (struct value
*, struct ui_file
*,
47 const struct value_print_options
*,
50 /* Decorations for Pascal. */
52 static const struct generic_val_print_decorations p_decorations
=
67 pascal_language::value_print_inner (struct value
*val
,
68 struct ui_file
*stream
, int recurse
,
69 const struct value_print_options
*options
) const
72 struct type
*type
= check_typedef (value_type (val
));
73 struct gdbarch
*gdbarch
= type
->arch ();
74 enum bfd_endian byte_order
= type_byte_order (type
);
75 unsigned int i
= 0; /* Number of characters printed */
79 int length_pos
, length_size
, string_pos
;
80 struct type
*char_type
;
83 const gdb_byte
*valaddr
= value_contents_for_printing (val
);
85 switch (type
->code ())
89 LONGEST low_bound
, high_bound
;
91 if (get_array_bounds (type
, &low_bound
, &high_bound
))
93 len
= high_bound
- low_bound
+ 1;
94 elttype
= check_typedef (TYPE_TARGET_TYPE (type
));
95 eltlen
= TYPE_LENGTH (elttype
);
96 /* If 's' format is used, try to print out as string.
97 If no format is given, print as string if element type
98 is of TYPE_CODE_CHAR and element size is 1,2 or 4. */
99 if (options
->format
== 's'
100 || ((eltlen
== 1 || eltlen
== 2 || eltlen
== 4)
101 && elttype
->code () == TYPE_CODE_CHAR
102 && options
->format
== 0))
104 /* If requested, look for the first null char and only print
105 elements up to it. */
106 if (options
->stop_print_at_null
)
108 unsigned int temp_len
;
110 /* Look for a NULL char. */
112 extract_unsigned_integer (valaddr
+ temp_len
* eltlen
,
114 && temp_len
< len
&& temp_len
< options
->print_max
;
119 printstr (stream
, TYPE_TARGET_TYPE (type
), valaddr
, len
,
125 fprintf_filtered (stream
, "{");
126 /* If this is a virtual function table, print the 0th
127 entry specially, and the rest of the members normally. */
128 if (pascal_object_is_vtbl_ptr_type (elttype
))
131 fprintf_filtered (stream
, "%d vtable entries", len
- 1);
137 value_print_array_elements (val
, stream
, recurse
, options
, i
);
138 fprintf_filtered (stream
, "}");
142 /* Array of unspecified length: treat like pointer to first elt. */
143 addr
= value_address (val
);
145 goto print_unpacked_pointer
;
148 if (options
->format
&& options
->format
!= 's')
150 value_print_scalar_formatted (val
, options
, 0, stream
);
153 if (options
->vtblprint
&& pascal_object_is_vtbl_ptr_type (type
))
155 /* Print the unmangled name if desired. */
156 /* Print vtable entry - we only get here if we ARE using
157 -fvtable_thunks. (Otherwise, look under TYPE_CODE_STRUCT.) */
158 /* Extract the address, assume that it is unsigned. */
159 addr
= extract_unsigned_integer (valaddr
,
160 TYPE_LENGTH (type
), byte_order
);
161 print_address_demangle (options
, gdbarch
, addr
, stream
, demangle
);
164 check_typedef (TYPE_TARGET_TYPE (type
));
166 addr
= unpack_pointer (type
, valaddr
);
167 print_unpacked_pointer
:
168 elttype
= check_typedef (TYPE_TARGET_TYPE (type
));
170 if (elttype
->code () == TYPE_CODE_FUNC
)
172 /* Try to print what function it points to. */
173 print_address_demangle (options
, gdbarch
, addr
, stream
, demangle
);
177 if (options
->addressprint
&& options
->format
!= 's')
179 fputs_filtered (paddress (gdbarch
, addr
), stream
);
183 /* For a pointer to char or unsigned char, also print the string
184 pointed to, unless pointer is null. */
185 if (((TYPE_LENGTH (elttype
) == 1
186 && (elttype
->code () == TYPE_CODE_INT
187 || elttype
->code () == TYPE_CODE_CHAR
))
188 || ((TYPE_LENGTH (elttype
) == 2 || TYPE_LENGTH (elttype
) == 4)
189 && elttype
->code () == TYPE_CODE_CHAR
))
190 && (options
->format
== 0 || options
->format
== 's')
194 fputs_filtered (" ", stream
);
195 /* No wide string yet. */
196 i
= val_print_string (elttype
, NULL
, addr
, -1, stream
, options
);
198 /* Also for pointers to pascal strings. */
199 /* Note: this is Free Pascal specific:
200 as GDB does not recognize stabs pascal strings
201 Pascal strings are mapped to records
202 with lowercase names PM. */
203 if (pascal_is_string_type (elttype
, &length_pos
, &length_size
,
204 &string_pos
, &char_type
, NULL
) > 0
207 ULONGEST string_length
;
211 fputs_filtered (" ", stream
);
212 buffer
= (gdb_byte
*) xmalloc (length_size
);
213 read_memory (addr
+ length_pos
, buffer
, length_size
);
214 string_length
= extract_unsigned_integer (buffer
, length_size
,
217 i
= val_print_string (char_type
, NULL
,
218 addr
+ string_pos
, string_length
,
221 else if (pascal_object_is_vtbl_member (type
))
223 /* Print vtbl's nicely. */
224 CORE_ADDR vt_address
= unpack_pointer (type
, valaddr
);
225 struct bound_minimal_symbol msymbol
=
226 lookup_minimal_symbol_by_pc (vt_address
);
228 /* If 'symbol_print' is set, we did the work above. */
229 if (!options
->symbol_print
230 && (msymbol
.minsym
!= NULL
)
231 && (vt_address
== BMSYMBOL_VALUE_ADDRESS (msymbol
)))
234 fputs_filtered (" ", stream
);
235 fputs_filtered ("<", stream
);
236 fputs_filtered (msymbol
.minsym
->print_name (), stream
);
237 fputs_filtered (">", stream
);
240 if (vt_address
&& options
->vtblprint
)
242 struct value
*vt_val
;
243 struct symbol
*wsym
= NULL
;
247 fputs_filtered (" ", stream
);
249 if (msymbol
.minsym
!= NULL
)
251 const char *search_name
= msymbol
.minsym
->search_name ();
252 wsym
= lookup_symbol_search_name (search_name
, NULL
,
258 wtype
= SYMBOL_TYPE (wsym
);
262 wtype
= TYPE_TARGET_TYPE (type
);
264 vt_val
= value_at (wtype
, vt_address
);
265 common_val_print (vt_val
, stream
, recurse
+ 1, options
,
267 if (options
->prettyformat
)
269 fprintf_filtered (stream
, "\n");
270 print_spaces_filtered (2 + 2 * recurse
, stream
);
279 case TYPE_CODE_FLAGS
:
281 case TYPE_CODE_RANGE
:
285 case TYPE_CODE_ERROR
:
286 case TYPE_CODE_UNDEF
:
289 generic_value_print (val
, stream
, recurse
, options
, &p_decorations
);
292 case TYPE_CODE_UNION
:
293 if (recurse
&& !options
->unionprint
)
295 fprintf_filtered (stream
, "{...}");
299 case TYPE_CODE_STRUCT
:
300 if (options
->vtblprint
&& pascal_object_is_vtbl_ptr_type (type
))
302 /* Print the unmangled name if desired. */
303 /* Print vtable entry - we only get here if NOT using
304 -fvtable_thunks. (Otherwise, look under TYPE_CODE_PTR.) */
305 /* Extract the address, assume that it is unsigned. */
306 print_address_demangle
308 extract_unsigned_integer
309 (valaddr
+ TYPE_FIELD_BITPOS (type
, VTBL_FNADDR_OFFSET
) / 8,
310 TYPE_LENGTH (type
->field (VTBL_FNADDR_OFFSET
).type ()),
316 if (pascal_is_string_type (type
, &length_pos
, &length_size
,
317 &string_pos
, &char_type
, NULL
) > 0)
319 len
= extract_unsigned_integer (valaddr
+ length_pos
,
320 length_size
, byte_order
);
321 printstr (stream
, char_type
, valaddr
+ string_pos
, len
,
325 pascal_object_print_value_fields (val
, stream
, recurse
,
331 elttype
= type
->index_type ();
332 elttype
= check_typedef (elttype
);
333 if (elttype
->is_stub ())
335 fprintf_styled (stream
, metadata_style
.style (), "<incomplete type>");
340 struct type
*range
= elttype
;
341 LONGEST low_bound
, high_bound
;
344 fputs_filtered ("[", stream
);
346 int bound_info
= (get_discrete_bounds (range
, &low_bound
, &high_bound
)
348 if (low_bound
== 0 && high_bound
== -1 && TYPE_LENGTH (type
) > 0)
350 /* If we know the size of the set type, we can figure out the
353 high_bound
= TYPE_LENGTH (type
) * TARGET_CHAR_BIT
- 1;
354 range
->bounds ()->high
.set_const_val (high_bound
);
359 fputs_styled ("<error value>", metadata_style
.style (), stream
);
363 for (i
= low_bound
; i
<= high_bound
; i
++)
365 int element
= value_bit_index (type
, valaddr
, i
);
370 goto maybe_bad_bstring
;
375 fputs_filtered (", ", stream
);
376 print_type_scalar (range
, i
, stream
);
379 if (i
+ 1 <= high_bound
380 && value_bit_index (type
, valaddr
, ++i
))
384 fputs_filtered ("..", stream
);
385 while (i
+ 1 <= high_bound
386 && value_bit_index (type
, valaddr
, ++i
))
388 print_type_scalar (range
, j
, stream
);
393 fputs_filtered ("]", stream
);
398 error (_("Invalid pascal type code %d in symbol table."),
405 pascal_language::value_print (struct value
*val
, struct ui_file
*stream
,
406 const struct value_print_options
*options
) const
408 struct type
*type
= value_type (val
);
409 struct value_print_options opts
= *options
;
413 /* If it is a pointer, indicate what it points to.
415 Print type also if it is a reference.
417 Object pascal: if it is a member pointer, we will take care
418 of that when we print it. */
419 if (type
->code () == TYPE_CODE_PTR
420 || type
->code () == TYPE_CODE_REF
)
422 /* Hack: remove (char *) for char strings. Their
423 type is indicated by the quoted string anyway. */
424 if (type
->code () == TYPE_CODE_PTR
425 && type
->name () == NULL
426 && TYPE_TARGET_TYPE (type
)->name () != NULL
427 && strcmp (TYPE_TARGET_TYPE (type
)->name (), "char") == 0)
433 fprintf_filtered (stream
, "(");
434 type_print (type
, "", stream
, -1);
435 fprintf_filtered (stream
, ") ");
438 common_val_print (val
, stream
, 0, &opts
, current_language
);
443 show_pascal_static_field_print (struct ui_file
*file
, int from_tty
,
444 struct cmd_list_element
*c
, const char *value
)
446 fprintf_filtered (file
, _("Printing of pascal static members is %s.\n"),
450 static struct obstack dont_print_vb_obstack
;
451 static struct obstack dont_print_statmem_obstack
;
453 static void pascal_object_print_static_field (struct value
*,
454 struct ui_file
*, int,
455 const struct value_print_options
*);
457 static void pascal_object_print_value (struct value
*, struct ui_file
*, int,
458 const struct value_print_options
*,
461 /* It was changed to this after 2.4.5. */
462 const char pascal_vtbl_ptr_name
[] =
463 {'_', '_', 'v', 't', 'b', 'l', '_', 'p', 't', 'r', '_', 't', 'y', 'p', 'e', 0};
465 /* Return truth value for assertion that TYPE is of the type
466 "pointer to virtual function". */
469 pascal_object_is_vtbl_ptr_type (struct type
*type
)
471 const char *type_name
= type
->name ();
473 return (type_name
!= NULL
474 && strcmp (type_name
, pascal_vtbl_ptr_name
) == 0);
477 /* Return truth value for the assertion that TYPE is of the type
478 "pointer to virtual function table". */
481 pascal_object_is_vtbl_member (struct type
*type
)
483 if (type
->code () == TYPE_CODE_PTR
)
485 type
= TYPE_TARGET_TYPE (type
);
486 if (type
->code () == TYPE_CODE_ARRAY
)
488 type
= TYPE_TARGET_TYPE (type
);
489 if (type
->code () == TYPE_CODE_STRUCT
/* If not using
491 || type
->code () == TYPE_CODE_PTR
) /* If using thunks. */
493 /* Virtual functions tables are full of pointers
494 to virtual functions. */
495 return pascal_object_is_vtbl_ptr_type (type
);
502 /* Helper function for print pascal objects.
504 VAL, STREAM, RECURSE, and OPTIONS have the same meanings as in
505 pascal_object_print_value and c_value_print.
507 DONT_PRINT is an array of baseclass types that we
508 should not print, or zero if called from top level. */
511 pascal_object_print_value_fields (struct value
*val
, struct ui_file
*stream
,
513 const struct value_print_options
*options
,
514 struct type
**dont_print_vb
,
515 int dont_print_statmem
)
517 int i
, len
, n_baseclasses
;
518 char *last_dont_print
519 = (char *) obstack_next_free (&dont_print_statmem_obstack
);
521 struct type
*type
= check_typedef (value_type (val
));
523 fprintf_filtered (stream
, "{");
524 len
= type
->num_fields ();
525 n_baseclasses
= TYPE_N_BASECLASSES (type
);
527 /* Print out baseclasses such that we don't print
528 duplicates of virtual baseclasses. */
529 if (n_baseclasses
> 0)
530 pascal_object_print_value (val
, stream
, recurse
+ 1,
531 options
, dont_print_vb
);
533 if (!len
&& n_baseclasses
== 1)
534 fprintf_styled (stream
, metadata_style
.style (), "<No data fields>");
537 struct obstack tmp_obstack
= dont_print_statmem_obstack
;
539 const gdb_byte
*valaddr
= value_contents_for_printing (val
);
541 if (dont_print_statmem
== 0)
543 /* If we're at top level, carve out a completely fresh
544 chunk of the obstack and use that until this particular
545 invocation returns. */
546 obstack_finish (&dont_print_statmem_obstack
);
549 for (i
= n_baseclasses
; i
< len
; i
++)
551 /* If requested, skip printing of static fields. */
552 if (!options
->pascal_static_field_print
553 && field_is_static (&type
->field (i
)))
556 fprintf_filtered (stream
, ", ");
557 else if (n_baseclasses
> 0)
559 if (options
->prettyformat
)
561 fprintf_filtered (stream
, "\n");
562 print_spaces_filtered (2 + 2 * recurse
, stream
);
563 fputs_filtered ("members of ", stream
);
564 fputs_filtered (type
->name (), stream
);
565 fputs_filtered (": ", stream
);
570 if (options
->prettyformat
)
572 fprintf_filtered (stream
, "\n");
573 print_spaces_filtered (2 + 2 * recurse
, stream
);
577 wrap_here (n_spaces (2 + 2 * recurse
));
580 annotate_field_begin (type
->field (i
).type ());
582 if (field_is_static (&type
->field (i
)))
584 fputs_filtered ("static ", stream
);
585 fprintf_symbol_filtered (stream
,
586 TYPE_FIELD_NAME (type
, i
),
587 current_language
->la_language
,
588 DMGL_PARAMS
| DMGL_ANSI
);
591 fputs_styled (TYPE_FIELD_NAME (type
, i
),
592 variable_name_style
.style (), stream
);
593 annotate_field_name_end ();
594 fputs_filtered (" = ", stream
);
595 annotate_field_value ();
597 if (!field_is_static (&type
->field (i
))
598 && TYPE_FIELD_PACKED (type
, i
))
602 /* Bitfields require special handling, especially due to byte
604 if (TYPE_FIELD_IGNORE (type
, i
))
606 fputs_styled ("<optimized out or zero length>",
607 metadata_style
.style (), stream
);
609 else if (value_bits_synthetic_pointer (val
,
610 TYPE_FIELD_BITPOS (type
,
612 TYPE_FIELD_BITSIZE (type
,
615 fputs_styled (_("<synthetic pointer>"),
616 metadata_style
.style (), stream
);
620 struct value_print_options opts
= *options
;
622 v
= value_field_bitfield (type
, i
, valaddr
, 0, val
);
625 common_val_print (v
, stream
, recurse
+ 1, &opts
,
631 if (TYPE_FIELD_IGNORE (type
, i
))
633 fputs_styled ("<optimized out or zero length>",
634 metadata_style
.style (), stream
);
636 else if (field_is_static (&type
->field (i
)))
638 /* struct value *v = value_static_field (type, i);
642 v
= value_field_bitfield (type
, i
, valaddr
, 0, val
);
645 val_print_optimized_out (NULL
, stream
);
647 pascal_object_print_static_field (v
, stream
, recurse
+ 1,
652 struct value_print_options opts
= *options
;
656 struct value
*v
= value_primitive_field (val
, 0, i
,
658 common_val_print (v
, stream
, recurse
+ 1, &opts
,
662 annotate_field_end ();
665 if (dont_print_statmem
== 0)
667 /* Free the space used to deal with the printing
668 of the members from top level. */
669 obstack_free (&dont_print_statmem_obstack
, last_dont_print
);
670 dont_print_statmem_obstack
= tmp_obstack
;
673 if (options
->prettyformat
)
675 fprintf_filtered (stream
, "\n");
676 print_spaces_filtered (2 * recurse
, stream
);
679 fprintf_filtered (stream
, "}");
682 /* Special val_print routine to avoid printing multiple copies of virtual
686 pascal_object_print_value (struct value
*val
, struct ui_file
*stream
,
688 const struct value_print_options
*options
,
689 struct type
**dont_print_vb
)
691 struct type
**last_dont_print
692 = (struct type
**) obstack_next_free (&dont_print_vb_obstack
);
693 struct obstack tmp_obstack
= dont_print_vb_obstack
;
694 struct type
*type
= check_typedef (value_type (val
));
695 int i
, n_baseclasses
= TYPE_N_BASECLASSES (type
);
697 if (dont_print_vb
== 0)
699 /* If we're at top level, carve out a completely fresh
700 chunk of the obstack and use that until this particular
701 invocation returns. */
702 /* Bump up the high-water mark. Now alpha is omega. */
703 obstack_finish (&dont_print_vb_obstack
);
706 for (i
= 0; i
< n_baseclasses
; i
++)
709 struct type
*baseclass
= check_typedef (TYPE_BASECLASS (type
, i
));
710 const char *basename
= baseclass
->name ();
713 if (BASETYPE_VIA_VIRTUAL (type
, i
))
715 struct type
**first_dont_print
716 = (struct type
**) obstack_base (&dont_print_vb_obstack
);
718 int j
= (struct type
**) obstack_next_free (&dont_print_vb_obstack
)
722 if (baseclass
== first_dont_print
[j
])
725 obstack_ptr_grow (&dont_print_vb_obstack
, baseclass
);
728 struct value
*base_value
;
731 base_value
= value_primitive_field (val
, 0, i
, type
);
733 catch (const gdb_exception_error
&ex
)
735 base_value
= nullptr;
736 if (ex
.error
== NOT_AVAILABLE_ERROR
)
744 /* The virtual base class pointer might have been clobbered by the
745 user program. Make sure that it still points to a valid memory
748 if (boffset
< 0 || boffset
>= TYPE_LENGTH (type
))
750 CORE_ADDR address
= value_address (val
);
751 gdb::byte_vector
buf (TYPE_LENGTH (baseclass
));
753 if (target_read_memory (address
+ boffset
, buf
.data (),
754 TYPE_LENGTH (baseclass
)) != 0)
756 base_value
= value_from_contents_and_address (baseclass
,
759 baseclass
= value_type (base_value
);
764 if (options
->prettyformat
)
766 fprintf_filtered (stream
, "\n");
767 print_spaces_filtered (2 * recurse
, stream
);
769 fputs_filtered ("<", stream
);
770 /* Not sure what the best notation is in the case where there is no
773 fputs_filtered (basename
? basename
: "", stream
);
774 fputs_filtered ("> = ", stream
);
777 val_print_unavailable (stream
);
779 val_print_invalid_address (stream
);
781 pascal_object_print_value_fields
782 (base_value
, stream
, recurse
, options
,
783 (struct type
**) obstack_base (&dont_print_vb_obstack
),
785 fputs_filtered (", ", stream
);
791 if (dont_print_vb
== 0)
793 /* Free the space used to deal with the printing
794 of this type from top level. */
795 obstack_free (&dont_print_vb_obstack
, last_dont_print
);
796 /* Reset watermark so that we can continue protecting
797 ourselves from whatever we were protecting ourselves. */
798 dont_print_vb_obstack
= tmp_obstack
;
802 /* Print value of a static member.
803 To avoid infinite recursion when printing a class that contains
804 a static instance of the class, we keep the addresses of all printed
805 static member classes in an obstack and refuse to print them more
808 VAL contains the value to print, STREAM, RECURSE, and OPTIONS
809 have the same meanings as in c_val_print. */
812 pascal_object_print_static_field (struct value
*val
,
813 struct ui_file
*stream
,
815 const struct value_print_options
*options
)
817 struct type
*type
= value_type (val
);
818 struct value_print_options opts
;
820 if (value_entirely_optimized_out (val
))
822 val_print_optimized_out (val
, stream
);
826 if (type
->code () == TYPE_CODE_STRUCT
)
828 CORE_ADDR
*first_dont_print
, addr
;
832 = (CORE_ADDR
*) obstack_base (&dont_print_statmem_obstack
);
833 i
= (CORE_ADDR
*) obstack_next_free (&dont_print_statmem_obstack
)
838 if (value_address (val
) == first_dont_print
[i
])
841 <same as static member of an already seen type>"),
842 metadata_style
.style (), stream
);
847 addr
= value_address (val
);
848 obstack_grow (&dont_print_statmem_obstack
, (char *) &addr
,
851 type
= check_typedef (type
);
852 pascal_object_print_value_fields (val
, stream
, recurse
,
859 common_val_print (val
, stream
, recurse
, &opts
, current_language
);
862 void _initialize_pascal_valprint ();
864 _initialize_pascal_valprint ()
866 add_setshow_boolean_cmd ("pascal_static-members", class_support
,
867 &user_print_options
.pascal_static_field_print
, _("\
868 Set printing of pascal static members."), _("\
869 Show printing of pascal static members."), NULL
,
871 show_pascal_static_field_print
,
872 &setprintlist
, &showprintlist
);