1 /* Support for printing Pascal values for GDB, the GNU debugger.
3 Copyright (C) 2000-2020 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_value_print_inner (struct value
*val
, struct ui_file
*stream
,
69 const struct value_print_options
*options
)
72 struct type
*type
= check_typedef (value_type (val
));
73 struct gdbarch
*gdbarch
= get_type_arch (type
);
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 (type
))
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 && TYPE_CODE (elttype
) == 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 LA_PRINT_STRING (stream
, TYPE_TARGET_TYPE (type
),
120 valaddr
, len
, NULL
, 0, options
);
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 (TYPE_CODE (elttype
) == 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 && (TYPE_CODE (elttype
) == TYPE_CODE_INT
187 || TYPE_CODE (elttype
) == TYPE_CODE_CHAR
))
188 || ((TYPE_LENGTH (elttype
) == 2 || TYPE_LENGTH (elttype
) == 4)
189 && TYPE_CODE (elttype
) == 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 (is_pascal_string_type (elttype
, &length_pos
, &length_size
,
204 &string_pos
, &char_type
, NULL
)
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 (valaddr
309 + TYPE_FIELD_BITPOS (type
,
310 VTBL_FNADDR_OFFSET
) / 8,
311 TYPE_LENGTH (TYPE_FIELD_TYPE (type
,
312 VTBL_FNADDR_OFFSET
)),
318 if (is_pascal_string_type (type
, &length_pos
, &length_size
,
319 &string_pos
, &char_type
, NULL
))
321 len
= extract_unsigned_integer (valaddr
+ length_pos
,
322 length_size
, byte_order
);
323 LA_PRINT_STRING (stream
, char_type
, valaddr
+ string_pos
,
324 len
, NULL
, 0, options
);
327 pascal_object_print_value_fields (val
, stream
, recurse
,
333 elttype
= TYPE_INDEX_TYPE (type
);
334 elttype
= check_typedef (elttype
);
335 if (TYPE_STUB (elttype
))
337 fprintf_styled (stream
, metadata_style
.style (), "<incomplete type>");
342 struct type
*range
= elttype
;
343 LONGEST low_bound
, high_bound
;
346 fputs_filtered ("[", stream
);
348 int bound_info
= get_discrete_bounds (range
, &low_bound
, &high_bound
);
349 if (low_bound
== 0 && high_bound
== -1 && TYPE_LENGTH (type
) > 0)
351 /* If we know the size of the set type, we can figure out the
354 high_bound
= TYPE_LENGTH (type
) * TARGET_CHAR_BIT
- 1;
355 TYPE_HIGH_BOUND (range
) = high_bound
;
360 fputs_styled ("<error value>", metadata_style
.style (), stream
);
364 for (i
= low_bound
; i
<= high_bound
; i
++)
366 int element
= value_bit_index (type
, valaddr
, i
);
371 goto maybe_bad_bstring
;
376 fputs_filtered (", ", stream
);
377 print_type_scalar (range
, i
, stream
);
380 if (i
+ 1 <= high_bound
381 && value_bit_index (type
, valaddr
, ++i
))
385 fputs_filtered ("..", stream
);
386 while (i
+ 1 <= high_bound
387 && value_bit_index (type
, valaddr
, ++i
))
389 print_type_scalar (range
, j
, stream
);
394 fputs_filtered ("]", stream
);
399 error (_("Invalid pascal type code %d in symbol table."),
406 pascal_value_print (struct value
*val
, struct ui_file
*stream
,
407 const struct value_print_options
*options
)
409 struct type
*type
= value_type (val
);
410 struct value_print_options opts
= *options
;
414 /* If it is a pointer, indicate what it points to.
416 Print type also if it is a reference.
418 Object pascal: if it is a member pointer, we will take care
419 of that when we print it. */
420 if (TYPE_CODE (type
) == TYPE_CODE_PTR
421 || TYPE_CODE (type
) == TYPE_CODE_REF
)
423 /* Hack: remove (char *) for char strings. Their
424 type is indicated by the quoted string anyway. */
425 if (TYPE_CODE (type
) == TYPE_CODE_PTR
426 && TYPE_NAME (type
) == NULL
427 && TYPE_NAME (TYPE_TARGET_TYPE (type
)) != NULL
428 && strcmp (TYPE_NAME (TYPE_TARGET_TYPE (type
)), "char") == 0)
434 fprintf_filtered (stream
, "(");
435 type_print (type
, "", stream
, -1);
436 fprintf_filtered (stream
, ") ");
439 common_val_print (val
, stream
, 0, &opts
, current_language
);
444 show_pascal_static_field_print (struct ui_file
*file
, int from_tty
,
445 struct cmd_list_element
*c
, const char *value
)
447 fprintf_filtered (file
, _("Printing of pascal static members is %s.\n"),
451 static struct obstack dont_print_vb_obstack
;
452 static struct obstack dont_print_statmem_obstack
;
454 static void pascal_object_print_static_field (struct value
*,
455 struct ui_file
*, int,
456 const struct value_print_options
*);
458 static void pascal_object_print_value (struct value
*, struct ui_file
*, int,
459 const struct value_print_options
*,
462 /* It was changed to this after 2.4.5. */
463 const char pascal_vtbl_ptr_name
[] =
464 {'_', '_', 'v', 't', 'b', 'l', '_', 'p', 't', 'r', '_', 't', 'y', 'p', 'e', 0};
466 /* Return truth value for assertion that TYPE is of the type
467 "pointer to virtual function". */
470 pascal_object_is_vtbl_ptr_type (struct type
*type
)
472 const char *type_name
= TYPE_NAME (type
);
474 return (type_name
!= NULL
475 && strcmp (type_name
, pascal_vtbl_ptr_name
) == 0);
478 /* Return truth value for the assertion that TYPE is of the type
479 "pointer to virtual function table". */
482 pascal_object_is_vtbl_member (struct type
*type
)
484 if (TYPE_CODE (type
) == TYPE_CODE_PTR
)
486 type
= TYPE_TARGET_TYPE (type
);
487 if (TYPE_CODE (type
) == TYPE_CODE_ARRAY
)
489 type
= TYPE_TARGET_TYPE (type
);
490 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
/* If not using
492 || TYPE_CODE (type
) == TYPE_CODE_PTR
) /* If using thunks. */
494 /* Virtual functions tables are full of pointers
495 to virtual functions. */
496 return pascal_object_is_vtbl_ptr_type (type
);
503 /* Mutually recursive subroutines of pascal_object_print_value and
504 pascal_value_print to print out a structure's fields:
505 pascal_object_print_value_fields and pascal_object_print_value.
507 VAL, STREAM, RECURSE, and OPTIONS have the same meanings as in
508 pascal_object_print_value and c_value_print.
510 DONT_PRINT is an array of baseclass types that we
511 should not print, or zero if called from top level. */
514 pascal_object_print_value_fields (struct value
*val
, struct ui_file
*stream
,
516 const struct value_print_options
*options
,
517 struct type
**dont_print_vb
,
518 int dont_print_statmem
)
520 int i
, len
, n_baseclasses
;
521 char *last_dont_print
522 = (char *) obstack_next_free (&dont_print_statmem_obstack
);
524 struct type
*type
= check_typedef (value_type (val
));
526 fprintf_filtered (stream
, "{");
527 len
= TYPE_NFIELDS (type
);
528 n_baseclasses
= TYPE_N_BASECLASSES (type
);
530 /* Print out baseclasses such that we don't print
531 duplicates of virtual baseclasses. */
532 if (n_baseclasses
> 0)
533 pascal_object_print_value (val
, stream
, recurse
+ 1,
534 options
, dont_print_vb
);
536 if (!len
&& n_baseclasses
== 1)
537 fprintf_styled (stream
, metadata_style
.style (), "<No data fields>");
540 struct obstack tmp_obstack
= dont_print_statmem_obstack
;
542 const gdb_byte
*valaddr
= value_contents_for_printing (val
);
544 if (dont_print_statmem
== 0)
546 /* If we're at top level, carve out a completely fresh
547 chunk of the obstack and use that until this particular
548 invocation returns. */
549 obstack_finish (&dont_print_statmem_obstack
);
552 for (i
= n_baseclasses
; i
< len
; i
++)
554 /* If requested, skip printing of static fields. */
555 if (!options
->pascal_static_field_print
556 && field_is_static (&TYPE_FIELD (type
, i
)))
559 fprintf_filtered (stream
, ", ");
560 else if (n_baseclasses
> 0)
562 if (options
->prettyformat
)
564 fprintf_filtered (stream
, "\n");
565 print_spaces_filtered (2 + 2 * recurse
, stream
);
566 fputs_filtered ("members of ", stream
);
567 fputs_filtered (TYPE_NAME (type
), stream
);
568 fputs_filtered (": ", stream
);
573 if (options
->prettyformat
)
575 fprintf_filtered (stream
, "\n");
576 print_spaces_filtered (2 + 2 * recurse
, stream
);
580 wrap_here (n_spaces (2 + 2 * recurse
));
583 annotate_field_begin (TYPE_FIELD_TYPE (type
, i
));
585 if (field_is_static (&TYPE_FIELD (type
, i
)))
587 fputs_filtered ("static ", stream
);
588 fprintf_symbol_filtered (stream
,
589 TYPE_FIELD_NAME (type
, i
),
590 current_language
->la_language
,
591 DMGL_PARAMS
| DMGL_ANSI
);
594 fputs_styled (TYPE_FIELD_NAME (type
, i
),
595 variable_name_style
.style (), stream
);
596 annotate_field_name_end ();
597 fputs_filtered (" = ", stream
);
598 annotate_field_value ();
600 if (!field_is_static (&TYPE_FIELD (type
, i
))
601 && TYPE_FIELD_PACKED (type
, i
))
605 /* Bitfields require special handling, especially due to byte
607 if (TYPE_FIELD_IGNORE (type
, i
))
609 fputs_styled ("<optimized out or zero length>",
610 metadata_style
.style (), stream
);
612 else if (value_bits_synthetic_pointer (val
,
613 TYPE_FIELD_BITPOS (type
,
615 TYPE_FIELD_BITSIZE (type
,
618 fputs_styled (_("<synthetic pointer>"),
619 metadata_style
.style (), stream
);
623 struct value_print_options opts
= *options
;
625 v
= value_field_bitfield (type
, i
, valaddr
, 0, val
);
628 common_val_print (v
, stream
, recurse
+ 1, &opts
,
634 if (TYPE_FIELD_IGNORE (type
, i
))
636 fputs_styled ("<optimized out or zero length>",
637 metadata_style
.style (), stream
);
639 else if (field_is_static (&TYPE_FIELD (type
, i
)))
641 /* struct value *v = value_static_field (type, i);
645 v
= value_field_bitfield (type
, i
, valaddr
, 0, val
);
648 val_print_optimized_out (NULL
, stream
);
650 pascal_object_print_static_field (v
, stream
, recurse
+ 1,
655 struct value_print_options opts
= *options
;
659 struct value
*v
= value_primitive_field (val
, 0, i
,
661 common_val_print (v
, stream
, recurse
+ 1, &opts
,
665 annotate_field_end ();
668 if (dont_print_statmem
== 0)
670 /* Free the space used to deal with the printing
671 of the members from top level. */
672 obstack_free (&dont_print_statmem_obstack
, last_dont_print
);
673 dont_print_statmem_obstack
= tmp_obstack
;
676 if (options
->prettyformat
)
678 fprintf_filtered (stream
, "\n");
679 print_spaces_filtered (2 * recurse
, stream
);
682 fprintf_filtered (stream
, "}");
685 /* Special val_print routine to avoid printing multiple copies of virtual
689 pascal_object_print_value (struct value
*val
, struct ui_file
*stream
,
691 const struct value_print_options
*options
,
692 struct type
**dont_print_vb
)
694 struct type
**last_dont_print
695 = (struct type
**) obstack_next_free (&dont_print_vb_obstack
);
696 struct obstack tmp_obstack
= dont_print_vb_obstack
;
697 struct type
*type
= check_typedef (value_type (val
));
698 int i
, n_baseclasses
= TYPE_N_BASECLASSES (type
);
700 if (dont_print_vb
== 0)
702 /* If we're at top level, carve out a completely fresh
703 chunk of the obstack and use that until this particular
704 invocation returns. */
705 /* Bump up the high-water mark. Now alpha is omega. */
706 obstack_finish (&dont_print_vb_obstack
);
709 for (i
= 0; i
< n_baseclasses
; i
++)
712 struct type
*baseclass
= check_typedef (TYPE_BASECLASS (type
, i
));
713 const char *basename
= TYPE_NAME (baseclass
);
716 if (BASETYPE_VIA_VIRTUAL (type
, i
))
718 struct type
**first_dont_print
719 = (struct type
**) obstack_base (&dont_print_vb_obstack
);
721 int j
= (struct type
**) obstack_next_free (&dont_print_vb_obstack
)
725 if (baseclass
== first_dont_print
[j
])
728 obstack_ptr_grow (&dont_print_vb_obstack
, baseclass
);
731 struct value
*base_value
;
734 base_value
= value_primitive_field (val
, 0, i
, type
);
736 catch (const gdb_exception_error
&ex
)
738 base_value
= nullptr;
739 if (ex
.error
== NOT_AVAILABLE_ERROR
)
747 /* The virtual base class pointer might have been clobbered by the
748 user program. Make sure that it still points to a valid memory
751 if (boffset
< 0 || boffset
>= TYPE_LENGTH (type
))
753 CORE_ADDR address
= value_address (val
);
754 gdb::byte_vector
buf (TYPE_LENGTH (baseclass
));
756 if (target_read_memory (address
+ boffset
, buf
.data (),
757 TYPE_LENGTH (baseclass
)) != 0)
759 base_value
= value_from_contents_and_address (baseclass
,
762 baseclass
= value_type (base_value
);
767 if (options
->prettyformat
)
769 fprintf_filtered (stream
, "\n");
770 print_spaces_filtered (2 * recurse
, stream
);
772 fputs_filtered ("<", stream
);
773 /* Not sure what the best notation is in the case where there is no
776 fputs_filtered (basename
? basename
: "", stream
);
777 fputs_filtered ("> = ", stream
);
780 val_print_unavailable (stream
);
782 val_print_invalid_address (stream
);
784 pascal_object_print_value_fields
785 (base_value
, stream
, recurse
, options
,
786 (struct type
**) obstack_base (&dont_print_vb_obstack
),
788 fputs_filtered (", ", stream
);
794 if (dont_print_vb
== 0)
796 /* Free the space used to deal with the printing
797 of this type from top level. */
798 obstack_free (&dont_print_vb_obstack
, last_dont_print
);
799 /* Reset watermark so that we can continue protecting
800 ourselves from whatever we were protecting ourselves. */
801 dont_print_vb_obstack
= tmp_obstack
;
805 /* Print value of a static member.
806 To avoid infinite recursion when printing a class that contains
807 a static instance of the class, we keep the addresses of all printed
808 static member classes in an obstack and refuse to print them more
811 VAL contains the value to print, STREAM, RECURSE, and OPTIONS
812 have the same meanings as in c_val_print. */
815 pascal_object_print_static_field (struct value
*val
,
816 struct ui_file
*stream
,
818 const struct value_print_options
*options
)
820 struct type
*type
= value_type (val
);
821 struct value_print_options opts
;
823 if (value_entirely_optimized_out (val
))
825 val_print_optimized_out (val
, stream
);
829 if (TYPE_CODE (type
) == TYPE_CODE_STRUCT
)
831 CORE_ADDR
*first_dont_print
, addr
;
835 = (CORE_ADDR
*) obstack_base (&dont_print_statmem_obstack
);
836 i
= (CORE_ADDR
*) obstack_next_free (&dont_print_statmem_obstack
)
841 if (value_address (val
) == first_dont_print
[i
])
844 <same as static member of an already seen type>"),
845 metadata_style
.style (), stream
);
850 addr
= value_address (val
);
851 obstack_grow (&dont_print_statmem_obstack
, (char *) &addr
,
854 type
= check_typedef (type
);
855 pascal_object_print_value_fields (val
, stream
, recurse
,
862 common_val_print (val
, stream
, recurse
, &opts
, current_language
);
865 void _initialize_pascal_valprint ();
867 _initialize_pascal_valprint ()
869 add_setshow_boolean_cmd ("pascal_static-members", class_support
,
870 &user_print_options
.pascal_static_field_print
, _("\
871 Set printing of pascal static members."), _("\
872 Show printing of pascal static members."), NULL
,
874 show_pascal_static_field_print
,
875 &setprintlist
, &showprintlist
);