1 /* Support for printing Pascal types for GDB, the GNU debugger.
2 Copyright (C) 2000-2022 Free Software Foundation, Inc.
4 This file is part of GDB.
6 This program is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 3 of the License, or
9 (at your option) any later version.
11 This program is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with this program. If not, see <http://www.gnu.org/licenses/>. */
19 /* This file is derived from p-typeprint.c */
22 #include "gdbsupport/gdb_obstack.h"
23 #include "bfd.h" /* Binary File Description */
26 #include "expression.h"
32 #include "typeprint.h"
33 #include "gdb-demangle.h"
35 #include "cli/cli-style.h"
40 pascal_language::print_type (struct type
*type
, const char *varstring
,
41 struct ui_file
*stream
, int show
, int level
,
42 const struct type_print_options
*flags
) const
50 type
= check_typedef (type
);
52 if ((code
== TYPE_CODE_FUNC
53 || code
== TYPE_CODE_METHOD
))
55 type_print_varspec_prefix (type
, stream
, show
, 0, flags
);
58 gdb_puts (varstring
, stream
);
60 if ((varstring
!= NULL
&& *varstring
!= '\0')
61 && !(code
== TYPE_CODE_FUNC
62 || code
== TYPE_CODE_METHOD
))
64 gdb_puts (" : ", stream
);
67 if (!(code
== TYPE_CODE_FUNC
68 || code
== TYPE_CODE_METHOD
))
70 type_print_varspec_prefix (type
, stream
, show
, 0, flags
);
73 type_print_base (type
, stream
, show
, level
, flags
);
74 /* For demangled function names, we have the arglist as part of the name,
75 so don't print an additional pair of ()'s. */
77 demangled_args
= varstring
? strchr (varstring
, '(') != NULL
: 0;
78 type_print_varspec_suffix (type
, stream
, show
, 0, demangled_args
,
86 pascal_language::print_typedef (struct type
*type
, struct symbol
*new_symbol
,
87 struct ui_file
*stream
) const
89 type
= check_typedef (type
);
90 gdb_printf (stream
, "type ");
91 gdb_printf (stream
, "%s = ", new_symbol
->print_name ());
92 type_print (type
, "", stream
, 0);
93 gdb_printf (stream
, ";");
99 pascal_language::type_print_derivation_info (struct ui_file
*stream
,
100 struct type
*type
) const
105 for (i
= 0; i
< TYPE_N_BASECLASSES (type
); i
++)
107 gdb_puts (i
== 0 ? ": " : ", ", stream
);
108 gdb_printf (stream
, "%s%s ",
109 BASETYPE_VIA_PUBLIC (type
, i
) ? "public" : "private",
110 BASETYPE_VIA_VIRTUAL (type
, i
) ? " virtual" : "");
111 name
= TYPE_BASECLASS (type
, i
)->name ();
112 gdb_printf (stream
, "%s", name
? name
: "(null)");
116 gdb_puts (" ", stream
);
123 pascal_language::type_print_method_args (const char *physname
,
124 const char *methodname
,
125 struct ui_file
*stream
) const
127 int is_constructor
= (startswith (physname
, "__ct__"));
128 int is_destructor
= (startswith (physname
, "__dt__"));
130 if (is_constructor
|| is_destructor
)
135 gdb_puts (methodname
, stream
);
137 if (physname
&& (*physname
!= 0))
139 gdb_puts (" (", stream
);
140 /* We must demangle this. */
141 while (isdigit (physname
[0]))
147 while (isdigit (physname
[len
]))
151 i
= strtol (physname
, &argname
, 0);
154 for (j
= 0; j
< i
; ++j
)
155 gdb_putc (physname
[j
], stream
);
158 if (physname
[0] != 0)
160 gdb_puts (", ", stream
);
163 gdb_puts (")", stream
);
170 pascal_language::type_print_varspec_prefix (struct type
*type
,
171 struct ui_file
*stream
,
172 int show
, int passed_a_ptr
,
173 const struct type_print_options
*flags
) const
178 if (type
->name () && show
<= 0)
183 switch (type
->code ())
186 gdb_printf (stream
, "^");
187 type_print_varspec_prefix (TYPE_TARGET_TYPE (type
), stream
, 0, 1,
189 break; /* Pointer should be handled normally
192 case TYPE_CODE_METHOD
:
194 gdb_printf (stream
, "(");
195 if (TYPE_TARGET_TYPE (type
) != NULL
196 && TYPE_TARGET_TYPE (type
)->code () != TYPE_CODE_VOID
)
198 gdb_printf (stream
, "function ");
202 gdb_printf (stream
, "procedure ");
207 gdb_printf (stream
, " ");
208 type_print_base (TYPE_SELF_TYPE (type
),
209 stream
, 0, passed_a_ptr
, flags
);
210 gdb_printf (stream
, "::");
215 type_print_varspec_prefix (TYPE_TARGET_TYPE (type
), stream
, 0, 1,
217 gdb_printf (stream
, "&");
222 gdb_printf (stream
, "(");
224 if (TYPE_TARGET_TYPE (type
) != NULL
225 && TYPE_TARGET_TYPE (type
)->code () != TYPE_CODE_VOID
)
227 gdb_printf (stream
, "function ");
231 gdb_printf (stream
, "procedure ");
236 case TYPE_CODE_ARRAY
:
238 gdb_printf (stream
, "(");
239 gdb_printf (stream
, "array ");
240 if (TYPE_LENGTH (TYPE_TARGET_TYPE (type
)) > 0
241 && type
->bounds ()->high
.kind () != PROP_UNDEFINED
)
242 gdb_printf (stream
, "[%s..%s] ",
243 plongest (type
->bounds ()->low
.const_val ()),
244 plongest (type
->bounds ()->high
.const_val ()));
245 gdb_printf (stream
, "of ");
248 case TYPE_CODE_UNDEF
:
249 case TYPE_CODE_STRUCT
:
250 case TYPE_CODE_UNION
:
255 case TYPE_CODE_ERROR
:
259 case TYPE_CODE_RANGE
:
260 case TYPE_CODE_STRING
:
261 case TYPE_CODE_COMPLEX
:
262 case TYPE_CODE_TYPEDEF
:
263 case TYPE_CODE_FIXED_POINT
:
264 /* These types need no prefix. They are listed here so that
265 gcc -Wall will reveal any types that haven't been handled. */
268 gdb_assert_not_reached ("unexpected type");
276 pascal_language::print_func_args (struct type
*type
, struct ui_file
*stream
,
277 const struct type_print_options
*flags
) const
279 int i
, len
= type
->num_fields ();
283 gdb_printf (stream
, "(");
285 for (i
= 0; i
< len
; i
++)
289 gdb_puts (", ", stream
);
290 stream
->wrap_here (4);
292 /* Can we find if it is a var parameter ??
293 if ( TYPE_FIELD(type, i) == )
295 gdb_printf (stream, "var ");
297 print_type (type
->field (i
).type (), "" /* TYPE_FIELD_NAME
299 ,stream
, -1, 0, flags
);
303 gdb_printf (stream
, ")");
310 pascal_language::type_print_func_varspec_suffix (struct type
*type
,
311 struct ui_file
*stream
,
312 int show
, int passed_a_ptr
,
314 const struct type_print_options
*flags
) const
316 if (TYPE_TARGET_TYPE (type
) == NULL
317 || TYPE_TARGET_TYPE (type
)->code () != TYPE_CODE_VOID
)
319 gdb_printf (stream
, " : ");
320 type_print_varspec_prefix (TYPE_TARGET_TYPE (type
),
321 stream
, 0, 0, flags
);
323 if (TYPE_TARGET_TYPE (type
) == NULL
)
324 type_print_unknown_return_type (stream
);
326 type_print_base (TYPE_TARGET_TYPE (type
), stream
, show
, 0,
329 type_print_varspec_suffix (TYPE_TARGET_TYPE (type
), stream
, 0,
330 passed_a_ptr
, 0, flags
);
337 pascal_language::type_print_varspec_suffix (struct type
*type
,
338 struct ui_file
*stream
,
339 int show
, int passed_a_ptr
,
341 const struct type_print_options
*flags
) const
346 if (type
->name () && show
<= 0)
351 switch (type
->code ())
353 case TYPE_CODE_ARRAY
:
355 gdb_printf (stream
, ")");
358 case TYPE_CODE_METHOD
:
360 gdb_printf (stream
, ")");
361 type_print_method_args ("", "", stream
);
362 type_print_func_varspec_suffix (type
, stream
, show
,
363 passed_a_ptr
, 0, flags
);
368 type_print_varspec_suffix (TYPE_TARGET_TYPE (type
),
369 stream
, 0, 1, 0, flags
);
374 gdb_printf (stream
, ")");
376 print_func_args (type
, stream
, flags
);
377 type_print_func_varspec_suffix (type
, stream
, show
,
378 passed_a_ptr
, 0, flags
);
381 case TYPE_CODE_UNDEF
:
382 case TYPE_CODE_STRUCT
:
383 case TYPE_CODE_UNION
:
388 case TYPE_CODE_ERROR
:
392 case TYPE_CODE_RANGE
:
393 case TYPE_CODE_STRING
:
394 case TYPE_CODE_COMPLEX
:
395 case TYPE_CODE_TYPEDEF
:
396 case TYPE_CODE_FIXED_POINT
:
397 /* These types do not need a suffix. They are listed so that
398 gcc -Wall will report types that may not have been considered. */
401 gdb_assert_not_reached ("unexpected type");
409 pascal_language::type_print_base (struct type
*type
, struct ui_file
*stream
, int show
,
410 int level
, const struct type_print_options
*flags
) const
417 s_none
, s_public
, s_private
, s_protected
422 stream
->wrap_here (4);
425 fputs_styled ("<type unknown>", metadata_style
.style (), stream
);
430 if ((type
->code () == TYPE_CODE_PTR
)
431 && (TYPE_TARGET_TYPE (type
)->code () == TYPE_CODE_VOID
))
433 gdb_puts (type
->name () ? type
->name () : "pointer",
437 /* When SHOW is zero or less, and there is a valid type name, then always
438 just print the type name directly from the type. */
441 && type
->name () != NULL
)
443 gdb_puts (type
->name (), stream
);
447 type
= check_typedef (type
);
449 switch (type
->code ())
451 case TYPE_CODE_TYPEDEF
:
454 type_print_base (TYPE_TARGET_TYPE (type
), stream
, show
, level
,
458 case TYPE_CODE_ARRAY
:
459 print_type (TYPE_TARGET_TYPE (type
), NULL
, stream
, 0, 0, flags
);
463 case TYPE_CODE_METHOD
:
465 case TYPE_CODE_STRUCT
:
466 if (type
->name () != NULL
)
468 gdb_puts (type
->name (), stream
);
469 gdb_puts (" = ", stream
);
471 if (HAVE_CPLUS_STRUCT (type
))
473 gdb_printf (stream
, "class ");
477 gdb_printf (stream
, "record ");
481 case TYPE_CODE_UNION
:
482 if (type
->name () != NULL
)
484 gdb_puts (type
->name (), stream
);
485 gdb_puts (" = ", stream
);
487 gdb_printf (stream
, "case <?> of ");
490 stream
->wrap_here (4);
493 /* If we just printed a tag name, no need to print anything else. */
494 if (type
->name () == NULL
)
495 gdb_printf (stream
, "{...}");
497 else if (show
> 0 || type
->name () == NULL
)
499 type_print_derivation_info (stream
, type
);
501 gdb_printf (stream
, "\n");
502 if ((type
->num_fields () == 0) && (TYPE_NFN_FIELDS (type
) == 0))
504 if (type
->is_stub ())
505 gdb_printf (stream
, "%*s<incomplete type>\n",
508 gdb_printf (stream
, "%*s<no data fields>\n",
512 /* Start off with no specific section type, so we can print
513 one for the first field we find, and use that section type
514 thereafter until we find another type. */
516 section_type
= s_none
;
518 /* If there is a base class for this type,
519 do not print the field that it occupies. */
521 len
= type
->num_fields ();
522 for (i
= TYPE_N_BASECLASSES (type
); i
< len
; i
++)
525 /* Don't print out virtual function table. */
526 if ((startswith (type
->field (i
).name (), "_vptr"))
527 && is_cplus_marker ((type
->field (i
).name ())[5]))
530 /* If this is a pascal object or class we can print the
531 various section labels. */
533 if (HAVE_CPLUS_STRUCT (type
))
535 if (TYPE_FIELD_PROTECTED (type
, i
))
537 if (section_type
!= s_protected
)
539 section_type
= s_protected
;
540 gdb_printf (stream
, "%*sprotected\n",
544 else if (TYPE_FIELD_PRIVATE (type
, i
))
546 if (section_type
!= s_private
)
548 section_type
= s_private
;
549 gdb_printf (stream
, "%*sprivate\n",
555 if (section_type
!= s_public
)
557 section_type
= s_public
;
558 gdb_printf (stream
, "%*spublic\n",
564 print_spaces (level
+ 4, stream
);
565 if (field_is_static (&type
->field (i
)))
566 gdb_printf (stream
, "static ");
567 print_type (type
->field (i
).type (),
568 type
->field (i
).name (),
569 stream
, show
- 1, level
+ 4, flags
);
570 if (!field_is_static (&type
->field (i
))
571 && TYPE_FIELD_PACKED (type
, i
))
573 /* It is a bitfield. This code does not attempt
574 to look at the bitpos and reconstruct filler,
575 unnamed fields. This would lead to misleading
576 results if the compiler does not put out fields
577 for such things (I don't know what it does). */
578 gdb_printf (stream
, " : %d",
579 TYPE_FIELD_BITSIZE (type
, i
));
581 gdb_printf (stream
, ";\n");
584 /* If there are both fields and methods, put a space between. */
585 len
= TYPE_NFN_FIELDS (type
);
586 if (len
&& section_type
!= s_none
)
587 gdb_printf (stream
, "\n");
589 /* Object pascal: print out the methods. */
591 for (i
= 0; i
< len
; i
++)
593 struct fn_field
*f
= TYPE_FN_FIELDLIST1 (type
, i
);
594 int j
, len2
= TYPE_FN_FIELDLIST_LENGTH (type
, i
);
595 const char *method_name
= TYPE_FN_FIELDLIST_NAME (type
, i
);
597 /* this is GNU C++ specific
598 how can we know constructor/destructor?
599 It might work for GNU pascal. */
600 for (j
= 0; j
< len2
; j
++)
602 const char *physname
= TYPE_FN_FIELD_PHYSNAME (f
, j
);
604 int is_constructor
= (startswith (physname
, "__ct__"));
605 int is_destructor
= (startswith (physname
, "__dt__"));
608 if (TYPE_FN_FIELD_PROTECTED (f
, j
))
610 if (section_type
!= s_protected
)
612 section_type
= s_protected
;
613 gdb_printf (stream
, "%*sprotected\n",
617 else if (TYPE_FN_FIELD_PRIVATE (f
, j
))
619 if (section_type
!= s_private
)
621 section_type
= s_private
;
622 gdb_printf (stream
, "%*sprivate\n",
628 if (section_type
!= s_public
)
630 section_type
= s_public
;
631 gdb_printf (stream
, "%*spublic\n",
636 print_spaces (level
+ 4, stream
);
637 if (TYPE_FN_FIELD_STATIC_P (f
, j
))
638 gdb_printf (stream
, "static ");
639 if (TYPE_TARGET_TYPE (TYPE_FN_FIELD_TYPE (f
, j
)) == 0)
641 /* Keep GDB from crashing here. */
642 gdb_printf (stream
, "<undefined type> %s;\n",
643 TYPE_FN_FIELD_PHYSNAME (f
, j
));
649 gdb_printf (stream
, "constructor ");
651 else if (is_destructor
)
653 gdb_printf (stream
, "destructor ");
655 else if (TYPE_TARGET_TYPE (TYPE_FN_FIELD_TYPE (f
, j
)) != 0
656 && TYPE_TARGET_TYPE (TYPE_FN_FIELD_TYPE(f
, j
))->code () != TYPE_CODE_VOID
)
658 gdb_printf (stream
, "function ");
662 gdb_printf (stream
, "procedure ");
664 /* This does not work, no idea why !! */
666 type_print_method_args (physname
, method_name
, stream
);
668 if (TYPE_TARGET_TYPE (TYPE_FN_FIELD_TYPE (f
, j
)) != 0
669 && TYPE_TARGET_TYPE (TYPE_FN_FIELD_TYPE(f
, j
))->code () != TYPE_CODE_VOID
)
671 gdb_puts (" : ", stream
);
672 type_print (TYPE_TARGET_TYPE (TYPE_FN_FIELD_TYPE (f
, j
)),
675 if (TYPE_FN_FIELD_VIRTUAL_P (f
, j
))
676 gdb_printf (stream
, "; virtual");
678 gdb_printf (stream
, ";\n");
681 gdb_printf (stream
, "%*send", level
, "");
686 if (type
->name () != NULL
)
688 gdb_puts (type
->name (), stream
);
690 gdb_puts (" ", stream
);
692 /* enum is just defined by
693 type enume_name = (enum_member1,enum_member2,...) */
694 gdb_printf (stream
, " = ");
695 stream
->wrap_here (4);
698 /* If we just printed a tag name, no need to print anything else. */
699 if (type
->name () == NULL
)
700 gdb_printf (stream
, "(...)");
702 else if (show
> 0 || type
->name () == NULL
)
704 gdb_printf (stream
, "(");
705 len
= type
->num_fields ();
707 for (i
= 0; i
< len
; i
++)
711 gdb_printf (stream
, ", ");
712 stream
->wrap_here (4);
713 gdb_puts (type
->field (i
).name (), stream
);
714 if (lastval
!= type
->field (i
).loc_enumval ())
718 plongest (type
->field (i
).loc_enumval ()));
719 lastval
= type
->field (i
).loc_enumval ();
723 gdb_printf (stream
, ")");
728 gdb_printf (stream
, "void");
731 case TYPE_CODE_UNDEF
:
732 gdb_printf (stream
, "record <unknown>");
735 case TYPE_CODE_ERROR
:
736 gdb_printf (stream
, "%s", TYPE_ERROR_NAME (type
));
739 /* this probably does not work for enums. */
740 case TYPE_CODE_RANGE
:
742 struct type
*target
= TYPE_TARGET_TYPE (type
);
744 print_type_scalar (target
, type
->bounds ()->low
.const_val (), stream
);
745 gdb_puts ("..", stream
);
746 print_type_scalar (target
, type
->bounds ()->high
.const_val (), stream
);
751 gdb_puts ("set of ", stream
);
752 print_type (type
->index_type (), "", stream
,
753 show
- 1, level
, flags
);
756 case TYPE_CODE_STRING
:
757 gdb_puts ("String", stream
);
761 /* Handle types not explicitly handled by the other cases,
762 such as fundamental types. For these, just print whatever
763 the type name is, as recorded in the type itself. If there
764 is no type name, then complain. */
765 if (type
->name () != NULL
)
767 gdb_puts (type
->name (), stream
);
771 /* At least for dump_symtab, it is important that this not be
773 fprintf_styled (stream
, metadata_style
.style (),
774 "<invalid unnamed pascal type code %d>",