1 /* Support for printing Pascal values for GDB, the GNU debugger.
3 Copyright (C) 2000-2024 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 */
22 #include "gdbsupport/gdb_obstack.h"
25 #include "expression.h"
32 #include "typeprint.h"
38 #include "cp-support.h"
40 #include "gdbsupport/byte-vector.h"
41 #include "cli/cli-style.h"
44 static void pascal_object_print_value_fields (struct value
*, struct ui_file
*,
46 const struct value_print_options
*,
49 /* Decorations for Pascal. */
51 static const struct generic_val_print_decorations p_decorations
=
66 pascal_language::value_print_inner (struct value
*val
,
67 struct ui_file
*stream
, int recurse
,
68 const struct value_print_options
*options
) const
71 struct type
*type
= check_typedef (val
->type ());
72 struct gdbarch
*gdbarch
= type
->arch ();
73 enum bfd_endian byte_order
= type_byte_order (type
);
74 unsigned int i
= 0; /* Number of characters printed */
78 int length_pos
, length_size
, string_pos
;
79 struct type
*char_type
;
82 const gdb_byte
*valaddr
= val
->contents_for_printing ().data ();
84 switch (type
->code ())
88 LONGEST low_bound
, high_bound
;
90 if (get_array_bounds (type
, &low_bound
, &high_bound
))
92 len
= high_bound
- low_bound
+ 1;
93 elttype
= check_typedef (type
->target_type ());
94 eltlen
= elttype
->length ();
95 /* If 's' format is used, try to print out as string.
96 If no format is given, print as string if element type
97 is of TYPE_CODE_CHAR and element size is 1,2 or 4. */
98 if (options
->format
== 's'
99 || ((eltlen
== 1 || eltlen
== 2 || eltlen
== 4)
100 && elttype
->code () == TYPE_CODE_CHAR
101 && options
->format
== 0))
103 /* If requested, look for the first null char and only print
104 elements up to it. */
105 if (options
->stop_print_at_null
)
107 unsigned int print_max_chars
108 = get_print_max_chars (options
);
109 unsigned int temp_len
;
111 /* Look for a NULL char. */
113 (extract_unsigned_integer
114 (valaddr
+ temp_len
* eltlen
, eltlen
, byte_order
)
116 && temp_len
< print_max_chars
);
121 printstr (stream
, type
->target_type (), valaddr
, len
,
127 gdb_printf (stream
, "{");
128 /* If this is a virtual function table, print the 0th
129 entry specially, and the rest of the members normally. */
130 if (pascal_object_is_vtbl_ptr_type (elttype
))
133 gdb_printf (stream
, "%d vtable entries", len
- 1);
139 value_print_array_elements (val
, stream
, recurse
, options
, i
);
140 gdb_printf (stream
, "}");
144 /* Array of unspecified length: treat like pointer to first elt. */
145 addr
= val
->address ();
147 goto print_unpacked_pointer
;
150 if (options
->format
&& options
->format
!= 's')
152 value_print_scalar_formatted (val
, options
, 0, stream
);
155 if (options
->vtblprint
&& pascal_object_is_vtbl_ptr_type (type
))
157 /* Print the unmangled name if desired. */
158 /* Print vtable entry - we only get here if we ARE using
159 -fvtable_thunks. (Otherwise, look under TYPE_CODE_STRUCT.) */
160 /* Extract the address, assume that it is unsigned. */
161 addr
= extract_unsigned_integer (valaddr
,
162 type
->length (), byte_order
);
163 print_address_demangle (options
, gdbarch
, addr
, stream
, demangle
);
166 check_typedef (type
->target_type ());
168 addr
= unpack_pointer (type
, valaddr
);
169 print_unpacked_pointer
:
170 elttype
= check_typedef (type
->target_type ());
172 if (elttype
->code () == TYPE_CODE_FUNC
)
174 /* Try to print what function it points to. */
175 print_address_demangle (options
, gdbarch
, addr
, stream
, demangle
);
179 if (options
->addressprint
&& options
->format
!= 's')
181 gdb_puts (paddress (gdbarch
, addr
), stream
);
185 /* For a pointer to char or unsigned char, also print the string
186 pointed to, unless pointer is null. */
187 if (((elttype
->length () == 1
188 && (elttype
->code () == TYPE_CODE_INT
189 || elttype
->code () == TYPE_CODE_CHAR
))
190 || ((elttype
->length () == 2 || elttype
->length () == 4)
191 && elttype
->code () == TYPE_CODE_CHAR
))
192 && (options
->format
== 0 || options
->format
== 's')
196 gdb_puts (" ", stream
);
197 /* No wide string yet. */
198 i
= val_print_string (elttype
, NULL
, addr
, -1, stream
, options
);
200 /* Also for pointers to pascal strings. */
201 /* Note: this is Free Pascal specific:
202 as GDB does not recognize stabs pascal strings
203 Pascal strings are mapped to records
204 with lowercase names PM. */
205 if (pascal_is_string_type (elttype
, &length_pos
, &length_size
,
206 &string_pos
, &char_type
, NULL
) > 0
209 ULONGEST string_length
;
213 gdb_puts (" ", stream
);
214 buffer
= (gdb_byte
*) xmalloc (length_size
);
215 read_memory (addr
+ length_pos
, buffer
, length_size
);
216 string_length
= extract_unsigned_integer (buffer
, length_size
,
219 i
= val_print_string (char_type
, NULL
,
220 addr
+ string_pos
, string_length
,
223 else if (pascal_object_is_vtbl_member (type
))
225 /* Print vtbl's nicely. */
226 CORE_ADDR vt_address
= unpack_pointer (type
, valaddr
);
227 struct bound_minimal_symbol msymbol
=
228 lookup_minimal_symbol_by_pc (vt_address
);
230 /* If 'symbol_print' is set, we did the work above. */
231 if (!options
->symbol_print
232 && (msymbol
.minsym
!= NULL
)
233 && (vt_address
== msymbol
.value_address ()))
236 gdb_puts (" ", stream
);
237 gdb_puts ("<", stream
);
238 gdb_puts (msymbol
.minsym
->print_name (), stream
);
239 gdb_puts (">", stream
);
242 if (vt_address
&& options
->vtblprint
)
244 struct value
*vt_val
;
245 struct symbol
*wsym
= NULL
;
249 gdb_puts (" ", stream
);
251 if (msymbol
.minsym
!= NULL
)
253 const char *search_name
= msymbol
.minsym
->search_name ();
254 wsym
= lookup_symbol_search_name (search_name
, NULL
,
260 wtype
= wsym
->type ();
264 wtype
= type
->target_type ();
266 vt_val
= value_at (wtype
, vt_address
);
267 common_val_print (vt_val
, stream
, recurse
+ 1, options
,
269 if (options
->prettyformat
)
271 gdb_printf (stream
, "\n");
272 print_spaces (2 + 2 * recurse
, stream
);
281 case TYPE_CODE_FLAGS
:
283 case TYPE_CODE_RANGE
:
287 case TYPE_CODE_ERROR
:
288 case TYPE_CODE_UNDEF
:
291 generic_value_print (val
, stream
, recurse
, options
, &p_decorations
);
294 case TYPE_CODE_UNION
:
295 if (recurse
&& !options
->unionprint
)
297 gdb_printf (stream
, "{...}");
301 case TYPE_CODE_STRUCT
:
302 if (options
->vtblprint
&& pascal_object_is_vtbl_ptr_type (type
))
304 /* Print the unmangled name if desired. */
305 /* Print vtable entry - we only get here if NOT using
306 -fvtable_thunks. (Otherwise, look under TYPE_CODE_PTR.) */
307 /* Extract the address, assume that it is unsigned. */
308 print_address_demangle
310 extract_unsigned_integer
311 (valaddr
+ type
->field (VTBL_FNADDR_OFFSET
).loc_bitpos () / 8,
312 type
->field (VTBL_FNADDR_OFFSET
).type ()->length (),
318 if (pascal_is_string_type (type
, &length_pos
, &length_size
,
319 &string_pos
, &char_type
, NULL
) > 0)
321 len
= extract_unsigned_integer (valaddr
+ length_pos
,
322 length_size
, byte_order
);
323 printstr (stream
, char_type
, valaddr
+ string_pos
, len
,
327 pascal_object_print_value_fields (val
, stream
, recurse
,
333 elttype
= type
->index_type ();
334 elttype
= check_typedef (elttype
);
335 if (elttype
->is_stub ())
337 fprintf_styled (stream
, metadata_style
.style (), "<incomplete type>");
342 struct type
*range
= elttype
;
343 LONGEST low_bound
, high_bound
;
346 gdb_puts ("[", stream
);
348 int bound_info
= (get_discrete_bounds (range
, &low_bound
, &high_bound
)
350 if (low_bound
== 0 && high_bound
== -1 && type
->length () > 0)
352 /* If we know the size of the set type, we can figure out the
355 high_bound
= type
->length () * TARGET_CHAR_BIT
- 1;
356 range
->bounds ()->high
.set_const_val (high_bound
);
361 fputs_styled ("<error value>", metadata_style
.style (), stream
);
365 for (i
= low_bound
; i
<= high_bound
; i
++)
367 int element
= value_bit_index (type
, valaddr
, i
);
372 goto maybe_bad_bstring
;
377 gdb_puts (", ", stream
);
378 print_type_scalar (range
, i
, stream
);
381 if (i
+ 1 <= high_bound
382 && value_bit_index (type
, valaddr
, ++i
))
386 gdb_puts ("..", stream
);
387 while (i
+ 1 <= high_bound
388 && value_bit_index (type
, valaddr
, ++i
))
390 print_type_scalar (range
, j
, stream
);
395 gdb_puts ("]", stream
);
400 error (_("Invalid pascal type code %d in symbol table."),
407 pascal_language::value_print (struct value
*val
, struct ui_file
*stream
,
408 const struct value_print_options
*options
) const
410 struct type
*type
= val
->type ();
411 struct value_print_options opts
= *options
;
413 opts
.deref_ref
= true;
415 /* If it is a pointer, indicate what it points to.
417 Print type also if it is a reference.
419 Object pascal: if it is a member pointer, we will take care
420 of that when we print it. */
421 if (type
->code () == TYPE_CODE_PTR
422 || type
->code () == TYPE_CODE_REF
)
424 /* Hack: remove (char *) for char strings. Their
425 type is indicated by the quoted string anyway. */
426 if (type
->code () == TYPE_CODE_PTR
427 && type
->name () == NULL
428 && type
->target_type ()->name () != NULL
429 && strcmp (type
->target_type ()->name (), "char") == 0)
435 gdb_printf (stream
, "(");
436 type_print (type
, "", stream
, -1);
437 gdb_printf (stream
, ") ");
440 common_val_print (val
, stream
, 0, &opts
, current_language
);
445 show_pascal_static_field_print (struct ui_file
*file
, int from_tty
,
446 struct cmd_list_element
*c
, const char *value
)
448 gdb_printf (file
, _("Printing of pascal static members is %s.\n"),
452 static struct obstack dont_print_vb_obstack
;
453 static struct obstack dont_print_statmem_obstack
;
455 static void pascal_object_print_static_field (struct value
*,
456 struct ui_file
*, int,
457 const struct value_print_options
*);
459 static void pascal_object_print_value (struct value
*, struct ui_file
*, int,
460 const struct value_print_options
*,
463 /* It was changed to this after 2.4.5. */
464 const char pascal_vtbl_ptr_name
[] =
465 {'_', '_', 'v', 't', 'b', 'l', '_', 'p', 't', 'r', '_', 't', 'y', 'p', 'e', 0};
467 /* Return truth value for assertion that TYPE is of the type
468 "pointer to virtual function". */
471 pascal_object_is_vtbl_ptr_type (struct type
*type
)
473 const char *type_name
= type
->name ();
475 return (type_name
!= NULL
476 && strcmp (type_name
, pascal_vtbl_ptr_name
) == 0);
479 /* Return truth value for the assertion that TYPE is of the type
480 "pointer to virtual function table". */
483 pascal_object_is_vtbl_member (struct type
*type
)
485 if (type
->code () == TYPE_CODE_PTR
)
487 type
= type
->target_type ();
488 if (type
->code () == TYPE_CODE_ARRAY
)
490 type
= type
->target_type ();
491 if (type
->code () == TYPE_CODE_STRUCT
/* If not using
493 || type
->code () == TYPE_CODE_PTR
) /* If using thunks. */
495 /* Virtual functions tables are full of pointers
496 to virtual functions. */
497 return pascal_object_is_vtbl_ptr_type (type
);
504 /* Helper function for print pascal objects.
506 VAL, STREAM, RECURSE, and OPTIONS have the same meanings as in
507 pascal_object_print_value and c_value_print.
509 DONT_PRINT is an array of baseclass types that we
510 should not print, or zero if called from top level. */
513 pascal_object_print_value_fields (struct value
*val
, struct ui_file
*stream
,
515 const struct value_print_options
*options
,
516 struct type
**dont_print_vb
,
517 int dont_print_statmem
)
519 int i
, len
, n_baseclasses
;
520 char *last_dont_print
521 = (char *) obstack_next_free (&dont_print_statmem_obstack
);
523 struct type
*type
= check_typedef (val
->type ());
525 gdb_printf (stream
, "{");
526 len
= type
->num_fields ();
527 n_baseclasses
= TYPE_N_BASECLASSES (type
);
529 /* Print out baseclasses such that we don't print
530 duplicates of virtual baseclasses. */
531 if (n_baseclasses
> 0)
532 pascal_object_print_value (val
, stream
, recurse
+ 1,
533 options
, dont_print_vb
);
535 if (!len
&& n_baseclasses
== 1)
536 fprintf_styled (stream
, metadata_style
.style (), "<No data fields>");
539 struct obstack tmp_obstack
= dont_print_statmem_obstack
;
541 const gdb_byte
*valaddr
= val
->contents_for_printing ().data ();
543 if (dont_print_statmem
== 0)
545 /* If we're at top level, carve out a completely fresh
546 chunk of the obstack and use that until this particular
547 invocation returns. */
548 obstack_finish (&dont_print_statmem_obstack
);
551 for (i
= n_baseclasses
; i
< len
; i
++)
553 /* If requested, skip printing of static fields. */
554 if (!options
->pascal_static_field_print
555 && type
->field (i
).is_static ())
558 gdb_printf (stream
, ", ");
559 else if (n_baseclasses
> 0)
561 if (options
->prettyformat
)
563 gdb_printf (stream
, "\n");
564 print_spaces (2 + 2 * recurse
, stream
);
565 gdb_puts ("members of ", stream
);
566 gdb_puts (type
->name (), stream
);
567 gdb_puts (": ", stream
);
572 if (options
->prettyformat
)
574 gdb_printf (stream
, "\n");
575 print_spaces (2 + 2 * recurse
, stream
);
579 stream
->wrap_here (2 + 2 * recurse
);
582 annotate_field_begin (type
->field (i
).type ());
584 if (type
->field (i
).is_static ())
586 gdb_puts ("static ", stream
);
587 fprintf_symbol (stream
,
588 type
->field (i
).name (),
589 current_language
->la_language
,
590 DMGL_PARAMS
| DMGL_ANSI
);
593 fputs_styled (type
->field (i
).name (),
594 variable_name_style
.style (), stream
);
595 annotate_field_name_end ();
596 gdb_puts (" = ", stream
);
597 annotate_field_value ();
599 if (!type
->field (i
).is_static ()
600 && type
->field (i
).is_packed ())
604 /* Bitfields require special handling, especially due to byte
606 if (type
->field (i
).is_ignored ())
608 fputs_styled ("<optimized out or zero length>",
609 metadata_style
.style (), stream
);
611 else if (val
->bits_synthetic_pointer
612 (type
->field (i
).loc_bitpos (),
613 type
->field (i
).bitsize ()))
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
);
624 opts
.deref_ref
= false;
625 common_val_print (v
, stream
, recurse
+ 1, &opts
,
631 if (type
->field (i
).is_ignored ())
633 fputs_styled ("<optimized out or zero length>",
634 metadata_style
.style (), stream
);
636 else if (type
->field (i
).is_static ())
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
;
654 opts
.deref_ref
= false;
656 struct value
*v
= val
->primitive_field (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 gdb_printf (stream
, "\n");
676 print_spaces (2 * recurse
, stream
);
679 gdb_printf (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 (val
->type ());
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
= val
->primitive_field (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 ())
750 CORE_ADDR address
= val
->address ();
751 gdb::byte_vector
buf (baseclass
->length ());
753 if (target_read_memory (address
+ boffset
, buf
.data (),
754 baseclass
->length ()) != 0)
756 base_value
= value_from_contents_and_address (baseclass
,
759 baseclass
= base_value
->type ();
764 if (options
->prettyformat
)
766 gdb_printf (stream
, "\n");
767 print_spaces (2 * recurse
, stream
);
769 gdb_puts ("<", stream
);
770 /* Not sure what the best notation is in the case where there is no
773 gdb_puts (basename
? basename
: "", stream
);
774 gdb_puts ("> = ", 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 gdb_puts (", ", 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
= val
->type ();
818 struct value_print_options opts
;
820 if (val
->entirely_optimized_out ())
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 (val
->address () == first_dont_print
[i
])
841 <same as static member of an already seen type>"),
842 metadata_style
.style (), stream
);
847 addr
= val
->address ();
848 obstack_grow (&dont_print_statmem_obstack
, (char *) &addr
,
851 type
= check_typedef (type
);
852 pascal_object_print_value_fields (val
, stream
, recurse
,
858 opts
.deref_ref
= false;
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
);