1 /* Support for printing Pascal values for GDB, the GNU debugger.
2 Copyright 2000, 2001, 2003
3 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 2 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, write to the Free Software
19 Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */
21 /* This file is derived from c-valprint.c */
24 #include "gdb_obstack.h"
27 #include "expression.h"
34 #include "typeprint.h"
44 /* Print data of type TYPE located at VALADDR (within GDB), which came from
45 the inferior at address ADDRESS, onto stdio stream STREAM according to
46 FORMAT (a letter or 0 for natural format). The data at VALADDR is in
49 If the data are a string pointer, returns the number of string characters
52 If DEREF_REF is nonzero, then dereference references, otherwise just print
55 The PRETTY parameter controls prettyprinting. */
59 pascal_val_print (struct type *type, char *valaddr, int embedded_offset,
60 CORE_ADDR address, struct ui_file *stream, int format,
61 int deref_ref, int recurse, enum val_prettyprint pretty)
63 unsigned int i = 0; /* Number of characters printed */
67 int length_pos, length_size, string_pos;
73 switch (TYPE_CODE (type))
76 if (TYPE_LENGTH (type) > 0 && TYPE_LENGTH (TYPE_TARGET_TYPE (type)) > 0)
78 elttype = check_typedef (TYPE_TARGET_TYPE (type));
79 eltlen = TYPE_LENGTH (elttype);
80 len = TYPE_LENGTH (type) / eltlen;
81 if (prettyprint_arrays)
83 print_spaces_filtered (2 + 2 * recurse, stream);
85 /* For an array of chars, print with string syntax. */
87 ((TYPE_CODE (elttype) == TYPE_CODE_INT)
88 || ((current_language->la_language == language_m2)
89 && (TYPE_CODE (elttype) == TYPE_CODE_CHAR)))
90 && (format == 0 || format == 's'))
92 /* If requested, look for the first null char and only print
94 if (stop_print_at_null)
96 unsigned int temp_len;
98 /* Look for a NULL char. */
100 (valaddr + embedded_offset)[temp_len]
101 && temp_len < len && temp_len < print_max;
106 LA_PRINT_STRING (stream, valaddr + embedded_offset, len, 1, 0);
111 fprintf_filtered (stream, "{");
112 /* If this is a virtual function table, print the 0th
113 entry specially, and the rest of the members normally. */
114 if (pascal_object_is_vtbl_ptr_type (elttype))
117 fprintf_filtered (stream, "%d vtable entries", len - 1);
123 val_print_array_elements (type, valaddr + embedded_offset, address, stream,
124 format, deref_ref, recurse, pretty, i);
125 fprintf_filtered (stream, "}");
129 /* Array of unspecified length: treat like pointer to first elt. */
131 goto print_unpacked_pointer;
134 if (format && format != 's')
136 print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
139 if (vtblprint && pascal_object_is_vtbl_ptr_type (type))
141 /* Print the unmangled name if desired. */
142 /* Print vtable entry - we only get here if we ARE using
143 -fvtable_thunks. (Otherwise, look under TYPE_CODE_STRUCT.) */
144 /* Extract the address, assume that it is unsigned. */
145 print_address_demangle (extract_unsigned_integer (valaddr + embedded_offset, TYPE_LENGTH (type)),
149 elttype = check_typedef (TYPE_TARGET_TYPE (type));
150 if (TYPE_CODE (elttype) == TYPE_CODE_METHOD)
152 pascal_object_print_class_method (valaddr + embedded_offset, type, stream);
154 else if (TYPE_CODE (elttype) == TYPE_CODE_MEMBER)
156 pascal_object_print_class_member (valaddr + embedded_offset,
157 TYPE_DOMAIN_TYPE (TYPE_TARGET_TYPE (type)),
162 addr = unpack_pointer (type, valaddr + embedded_offset);
163 print_unpacked_pointer:
164 elttype = check_typedef (TYPE_TARGET_TYPE (type));
166 if (TYPE_CODE (elttype) == TYPE_CODE_FUNC)
168 /* Try to print what function it points to. */
169 print_address_demangle (addr, stream, demangle);
170 /* Return value is irrelevant except for string pointers. */
174 if (addressprint && format != 's')
176 print_address_numeric (addr, 1, stream);
179 /* For a pointer to char or unsigned char, also print the string
180 pointed to, unless pointer is null. */
181 if (TYPE_LENGTH (elttype) == 1
182 && TYPE_CODE (elttype) == TYPE_CODE_INT
183 && (format == 0 || format == 's')
186 /* no wide string yet */
187 i = val_print_string (addr, -1, 1, stream);
189 /* also for pointers to pascal strings */
190 /* Note: this is Free Pascal specific:
191 as GDB does not recognize stabs pascal strings
192 Pascal strings are mapped to records
193 with lowercase names PM */
194 if (is_pascal_string_type (elttype, &length_pos, &length_size,
195 &string_pos, &char_size, NULL)
198 ULONGEST string_length;
200 buffer = xmalloc (length_size);
201 read_memory (addr + length_pos, buffer, length_size);
202 string_length = extract_unsigned_integer (buffer, length_size);
204 i = val_print_string (addr + string_pos, string_length, char_size, stream);
206 else if (pascal_object_is_vtbl_member (type))
208 /* print vtbl's nicely */
209 CORE_ADDR vt_address = unpack_pointer (type, valaddr + embedded_offset);
211 struct minimal_symbol *msymbol =
212 lookup_minimal_symbol_by_pc (vt_address);
213 if ((msymbol != NULL)
214 && (vt_address == SYMBOL_VALUE_ADDRESS (msymbol)))
216 fputs_filtered (" <", stream);
217 fputs_filtered (SYMBOL_PRINT_NAME (msymbol), stream);
218 fputs_filtered (">", stream);
220 if (vt_address && vtblprint)
222 struct value *vt_val;
223 struct symbol *wsym = (struct symbol *) NULL;
225 struct block *block = (struct block *) NULL;
229 wsym = lookup_symbol (DEPRECATED_SYMBOL_NAME (msymbol), block,
230 VAR_DOMAIN, &is_this_fld, NULL);
234 wtype = SYMBOL_TYPE (wsym);
238 wtype = TYPE_TARGET_TYPE (type);
240 vt_val = value_at (wtype, vt_address, NULL);
241 common_val_print (vt_val, stream, format, deref_ref,
242 recurse + 1, pretty);
245 fprintf_filtered (stream, "\n");
246 print_spaces_filtered (2 + 2 * recurse, stream);
251 /* Return number of characters printed, including the terminating
252 '\0' if we reached the end. val_print_string takes care including
253 the terminating '\0' if necessary. */
258 case TYPE_CODE_MEMBER:
259 error ("not implemented: member type in pascal_val_print");
263 elttype = check_typedef (TYPE_TARGET_TYPE (type));
264 if (TYPE_CODE (elttype) == TYPE_CODE_MEMBER)
266 pascal_object_print_class_member (valaddr + embedded_offset,
267 TYPE_DOMAIN_TYPE (elttype),
273 fprintf_filtered (stream, "@");
274 /* Extract the address, assume that it is unsigned. */
275 print_address_numeric
276 (extract_unsigned_integer (valaddr + embedded_offset,
277 TARGET_PTR_BIT / HOST_CHAR_BIT),
280 fputs_filtered (": ", stream);
282 /* De-reference the reference. */
285 if (TYPE_CODE (elttype) != TYPE_CODE_UNDEF)
287 struct value *deref_val =
289 (TYPE_TARGET_TYPE (type),
290 unpack_pointer (lookup_pointer_type (builtin_type_void),
291 valaddr + embedded_offset),
293 common_val_print (deref_val, stream, format, deref_ref,
294 recurse + 1, pretty);
297 fputs_filtered ("???", stream);
301 case TYPE_CODE_UNION:
302 if (recurse && !unionprint)
304 fprintf_filtered (stream, "{...}");
308 case TYPE_CODE_STRUCT:
309 if (vtblprint && pascal_object_is_vtbl_ptr_type (type))
311 /* Print the unmangled name if desired. */
312 /* Print vtable entry - we only get here if NOT using
313 -fvtable_thunks. (Otherwise, look under TYPE_CODE_PTR.) */
314 /* Extract the address, assume that it is unsigned. */
315 print_address_demangle
316 (extract_unsigned_integer (valaddr + embedded_offset + TYPE_FIELD_BITPOS (type, VTBL_FNADDR_OFFSET) / 8,
317 TYPE_LENGTH (TYPE_FIELD_TYPE (type, VTBL_FNADDR_OFFSET))),
322 if (is_pascal_string_type (type, &length_pos, &length_size,
323 &string_pos, &char_size, NULL))
325 len = extract_unsigned_integer (valaddr + embedded_offset + length_pos, length_size);
326 LA_PRINT_STRING (stream, valaddr + embedded_offset + string_pos, len, char_size, 0);
329 pascal_object_print_value_fields (type, valaddr + embedded_offset, address, stream, format,
330 recurse, pretty, NULL, 0);
337 print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
340 len = TYPE_NFIELDS (type);
341 val = unpack_long (type, valaddr + embedded_offset);
342 for (i = 0; i < len; i++)
345 if (val == TYPE_FIELD_BITPOS (type, i))
352 fputs_filtered (TYPE_FIELD_NAME (type, i), stream);
356 print_longest (stream, 'd', 0, val);
363 print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
366 /* FIXME, we should consider, at least for ANSI C language, eliminating
367 the distinction made between FUNCs and POINTERs to FUNCs. */
368 fprintf_filtered (stream, "{");
369 type_print (type, "", stream, -1);
370 fprintf_filtered (stream, "} ");
371 /* Try to print what function it points to, and its address. */
372 print_address_demangle (address, stream, demangle);
376 format = format ? format : output_format;
378 print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
381 val = unpack_long (type, valaddr + embedded_offset);
383 fputs_filtered ("false", stream);
385 fputs_filtered ("true", stream);
388 fputs_filtered ("true (", stream);
389 fprintf_filtered (stream, "%ld)", (long int) val);
394 case TYPE_CODE_RANGE:
395 /* FIXME: create_range_type does not set the unsigned bit in a
396 range type (I think it probably should copy it from the target
397 type), so we won't print values which are too large to
398 fit in a signed integer correctly. */
399 /* FIXME: Doesn't handle ranges of enums correctly. (Can't just
400 print with the target type, though, because the size of our type
401 and the target type might differ). */
405 format = format ? format : output_format;
408 print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
412 val_print_type_code_int (type, valaddr + embedded_offset, stream);
417 format = format ? format : output_format;
420 print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
424 val = unpack_long (type, valaddr + embedded_offset);
425 if (TYPE_UNSIGNED (type))
426 fprintf_filtered (stream, "%u", (unsigned int) val);
428 fprintf_filtered (stream, "%d", (int) val);
429 fputs_filtered (" ", stream);
430 LA_PRINT_CHAR ((unsigned char) val, stream);
437 print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
441 print_floating (valaddr + embedded_offset, type, stream);
445 case TYPE_CODE_BITSTRING:
447 elttype = TYPE_INDEX_TYPE (type);
448 CHECK_TYPEDEF (elttype);
449 if (TYPE_STUB (elttype))
451 fprintf_filtered (stream, "<incomplete type>");
457 struct type *range = elttype;
458 LONGEST low_bound, high_bound;
460 int is_bitstring = TYPE_CODE (type) == TYPE_CODE_BITSTRING;
464 fputs_filtered ("B'", stream);
466 fputs_filtered ("[", stream);
468 i = get_discrete_bounds (range, &low_bound, &high_bound);
472 fputs_filtered ("<error value>", stream);
476 for (i = low_bound; i <= high_bound; i++)
478 int element = value_bit_index (type, valaddr + embedded_offset, i);
482 goto maybe_bad_bstring;
485 fprintf_filtered (stream, "%d", element);
489 fputs_filtered (", ", stream);
490 print_type_scalar (range, i, stream);
493 if (i + 1 <= high_bound && value_bit_index (type, valaddr + embedded_offset, ++i))
496 fputs_filtered ("..", stream);
497 while (i + 1 <= high_bound
498 && value_bit_index (type, valaddr + embedded_offset, ++i))
500 print_type_scalar (range, j, stream);
506 fputs_filtered ("'", stream);
508 fputs_filtered ("]", stream);
513 fprintf_filtered (stream, "void");
516 case TYPE_CODE_ERROR:
517 fprintf_filtered (stream, "<error type>");
520 case TYPE_CODE_UNDEF:
521 /* This happens (without TYPE_FLAG_STUB set) on systems which don't use
522 dbx xrefs (NO_DBX_XREFS in gcc) if a file has a "struct foo *bar"
523 and no complete type for struct foo in that file. */
524 fprintf_filtered (stream, "<incomplete type>");
528 error ("Invalid pascal type code %d in symbol table.", TYPE_CODE (type));
535 pascal_value_print (struct value *val, struct ui_file *stream, int format,
536 enum val_prettyprint pretty)
538 struct type *type = VALUE_TYPE (val);
540 /* If it is a pointer, indicate what it points to.
542 Print type also if it is a reference.
544 Object pascal: if it is a member pointer, we will take care
545 of that when we print it. */
546 if (TYPE_CODE (type) == TYPE_CODE_PTR ||
547 TYPE_CODE (type) == TYPE_CODE_REF)
549 /* Hack: remove (char *) for char strings. Their
550 type is indicated by the quoted string anyway. */
551 if (TYPE_CODE (type) == TYPE_CODE_PTR &&
552 TYPE_NAME (type) == NULL &&
553 TYPE_NAME (TYPE_TARGET_TYPE (type)) != NULL
554 && strcmp (TYPE_NAME (TYPE_TARGET_TYPE (type)), "char") == 0)
560 fprintf_filtered (stream, "(");
561 type_print (type, "", stream, -1);
562 fprintf_filtered (stream, ") ");
565 return common_val_print (val, stream, format, 1, 0, pretty);
569 /******************************************************************************
570 Inserted from cp-valprint
571 ******************************************************************************/
573 extern int vtblprint; /* Controls printing of vtbl's */
574 extern int objectprint; /* Controls looking up an object's derived type
575 using what we find in its vtables. */
576 static int pascal_static_field_print; /* Controls printing of static fields. */
578 static struct obstack dont_print_vb_obstack;
579 static struct obstack dont_print_statmem_obstack;
581 static void pascal_object_print_static_field (struct value *,
582 struct ui_file *, int, int,
583 enum val_prettyprint);
586 pascal_object_print_value (struct type *, char *, CORE_ADDR, struct ui_file *,
587 int, int, enum val_prettyprint, struct type **);
590 pascal_object_print_class_method (char *valaddr, struct type *type,
591 struct ui_file *stream)
594 struct fn_field *f = NULL;
603 struct type *target_type = check_typedef (TYPE_TARGET_TYPE (type));
605 domain = TYPE_DOMAIN_TYPE (target_type);
606 if (domain == (struct type *) NULL)
608 fprintf_filtered (stream, "<unknown>");
611 addr = unpack_pointer (lookup_pointer_type (builtin_type_void), valaddr);
612 if (METHOD_PTR_IS_VIRTUAL (addr))
614 offset = METHOD_PTR_TO_VOFFSET (addr);
615 len = TYPE_NFN_FIELDS (domain);
616 for (i = 0; i < len; i++)
618 f = TYPE_FN_FIELDLIST1 (domain, i);
619 len2 = TYPE_FN_FIELDLIST_LENGTH (domain, i);
621 check_stub_method_group (domain, i);
622 for (j = 0; j < len2; j++)
624 if (TYPE_FN_FIELD_VOFFSET (f, j) == offset)
634 sym = find_pc_function (addr);
637 error ("invalid pointer to member function");
639 len = TYPE_NFN_FIELDS (domain);
640 for (i = 0; i < len; i++)
642 f = TYPE_FN_FIELDLIST1 (domain, i);
643 len2 = TYPE_FN_FIELDLIST_LENGTH (domain, i);
645 check_stub_method_group (domain, i);
646 for (j = 0; j < len2; j++)
648 if (DEPRECATED_STREQ (DEPRECATED_SYMBOL_NAME (sym), TYPE_FN_FIELD_PHYSNAME (f, j)))
656 char *demangled_name;
658 fprintf_filtered (stream, "&");
659 fputs_filtered (kind, stream);
660 demangled_name = cplus_demangle (TYPE_FN_FIELD_PHYSNAME (f, j),
661 DMGL_ANSI | DMGL_PARAMS);
662 if (demangled_name == NULL)
663 fprintf_filtered (stream, "<badly mangled name %s>",
664 TYPE_FN_FIELD_PHYSNAME (f, j));
667 fputs_filtered (demangled_name, stream);
668 xfree (demangled_name);
673 fprintf_filtered (stream, "(");
674 type_print (type, "", stream, -1);
675 fprintf_filtered (stream, ") %d", (int) addr >> 3);
679 /* It was changed to this after 2.4.5. */
680 const char pascal_vtbl_ptr_name[] =
681 {'_', '_', 'v', 't', 'b', 'l', '_', 'p', 't', 'r', '_', 't', 'y', 'p', 'e', 0};
683 /* Return truth value for assertion that TYPE is of the type
684 "pointer to virtual function". */
687 pascal_object_is_vtbl_ptr_type (struct type *type)
689 char *typename = type_name_no_tag (type);
691 return (typename != NULL
692 && strcmp (typename, pascal_vtbl_ptr_name) == 0);
695 /* Return truth value for the assertion that TYPE is of the type
696 "pointer to virtual function table". */
699 pascal_object_is_vtbl_member (struct type *type)
701 if (TYPE_CODE (type) == TYPE_CODE_PTR)
703 type = TYPE_TARGET_TYPE (type);
704 if (TYPE_CODE (type) == TYPE_CODE_ARRAY)
706 type = TYPE_TARGET_TYPE (type);
707 if (TYPE_CODE (type) == TYPE_CODE_STRUCT /* if not using thunks */
708 || TYPE_CODE (type) == TYPE_CODE_PTR) /* if using thunks */
710 /* Virtual functions tables are full of pointers
711 to virtual functions. */
712 return pascal_object_is_vtbl_ptr_type (type);
719 /* Mutually recursive subroutines of pascal_object_print_value and c_val_print to
720 print out a structure's fields: pascal_object_print_value_fields and pascal_object_print_value.
722 TYPE, VALADDR, ADDRESS, STREAM, RECURSE, and PRETTY have the
723 same meanings as in pascal_object_print_value and c_val_print.
725 DONT_PRINT is an array of baseclass types that we
726 should not print, or zero if called from top level. */
729 pascal_object_print_value_fields (struct type *type, char *valaddr,
730 CORE_ADDR address, struct ui_file *stream,
731 int format, int recurse,
732 enum val_prettyprint pretty,
733 struct type **dont_print_vb,
734 int dont_print_statmem)
736 int i, len, n_baseclasses;
737 struct obstack tmp_obstack;
738 char *last_dont_print = obstack_next_free (&dont_print_statmem_obstack);
740 CHECK_TYPEDEF (type);
742 fprintf_filtered (stream, "{");
743 len = TYPE_NFIELDS (type);
744 n_baseclasses = TYPE_N_BASECLASSES (type);
746 /* Print out baseclasses such that we don't print
747 duplicates of virtual baseclasses. */
748 if (n_baseclasses > 0)
749 pascal_object_print_value (type, valaddr, address, stream,
750 format, recurse + 1, pretty, dont_print_vb);
752 if (!len && n_baseclasses == 1)
753 fprintf_filtered (stream, "<No data fields>");
758 if (dont_print_statmem == 0)
760 /* If we're at top level, carve out a completely fresh
761 chunk of the obstack and use that until this particular
762 invocation returns. */
763 tmp_obstack = dont_print_statmem_obstack;
764 obstack_finish (&dont_print_statmem_obstack);
767 for (i = n_baseclasses; i < len; i++)
769 /* If requested, skip printing of static fields. */
770 if (!pascal_static_field_print && TYPE_FIELD_STATIC (type, i))
773 fprintf_filtered (stream, ", ");
774 else if (n_baseclasses > 0)
778 fprintf_filtered (stream, "\n");
779 print_spaces_filtered (2 + 2 * recurse, stream);
780 fputs_filtered ("members of ", stream);
781 fputs_filtered (type_name_no_tag (type), stream);
782 fputs_filtered (": ", stream);
789 fprintf_filtered (stream, "\n");
790 print_spaces_filtered (2 + 2 * recurse, stream);
794 wrap_here (n_spaces (2 + 2 * recurse));
798 if (TYPE_CODE (TYPE_FIELD_TYPE (type, i)) == TYPE_CODE_PTR)
799 fputs_filtered ("\"( ptr \"", stream);
801 fputs_filtered ("\"( nodef \"", stream);
802 if (TYPE_FIELD_STATIC (type, i))
803 fputs_filtered ("static ", stream);
804 fprintf_symbol_filtered (stream, TYPE_FIELD_NAME (type, i),
806 DMGL_PARAMS | DMGL_ANSI);
807 fputs_filtered ("\" \"", stream);
808 fprintf_symbol_filtered (stream, TYPE_FIELD_NAME (type, i),
810 DMGL_PARAMS | DMGL_ANSI);
811 fputs_filtered ("\") \"", stream);
815 annotate_field_begin (TYPE_FIELD_TYPE (type, i));
817 if (TYPE_FIELD_STATIC (type, i))
818 fputs_filtered ("static ", stream);
819 fprintf_symbol_filtered (stream, TYPE_FIELD_NAME (type, i),
821 DMGL_PARAMS | DMGL_ANSI);
822 annotate_field_name_end ();
823 fputs_filtered (" = ", stream);
824 annotate_field_value ();
827 if (!TYPE_FIELD_STATIC (type, i) && TYPE_FIELD_PACKED (type, i))
831 /* Bitfields require special handling, especially due to byte
833 if (TYPE_FIELD_IGNORE (type, i))
835 fputs_filtered ("<optimized out or zero length>", stream);
839 v = value_from_longest (TYPE_FIELD_TYPE (type, i),
840 unpack_field_as_long (type, valaddr, i));
842 common_val_print (v, stream, format, 0, recurse + 1, pretty);
847 if (TYPE_FIELD_IGNORE (type, i))
849 fputs_filtered ("<optimized out or zero length>", stream);
851 else if (TYPE_FIELD_STATIC (type, i))
853 /* struct value *v = value_static_field (type, i); v4.17 specific */
855 v = value_from_longest (TYPE_FIELD_TYPE (type, i),
856 unpack_field_as_long (type, valaddr, i));
859 fputs_filtered ("<optimized out>", stream);
861 pascal_object_print_static_field (v, stream, format,
862 recurse + 1, pretty);
866 /* val_print (TYPE_FIELD_TYPE (type, i),
867 valaddr + TYPE_FIELD_BITPOS (type, i) / 8,
868 address + TYPE_FIELD_BITPOS (type, i) / 8, 0,
869 stream, format, 0, recurse + 1, pretty); */
870 val_print (TYPE_FIELD_TYPE (type, i),
871 valaddr, TYPE_FIELD_BITPOS (type, i) / 8,
872 address + TYPE_FIELD_BITPOS (type, i) / 8,
873 stream, format, 0, recurse + 1, pretty);
876 annotate_field_end ();
879 if (dont_print_statmem == 0)
881 /* Free the space used to deal with the printing
882 of the members from top level. */
883 obstack_free (&dont_print_statmem_obstack, last_dont_print);
884 dont_print_statmem_obstack = tmp_obstack;
889 fprintf_filtered (stream, "\n");
890 print_spaces_filtered (2 * recurse, stream);
893 fprintf_filtered (stream, "}");
896 /* Special val_print routine to avoid printing multiple copies of virtual
900 pascal_object_print_value (struct type *type, char *valaddr, CORE_ADDR address,
901 struct ui_file *stream, int format, int recurse,
902 enum val_prettyprint pretty,
903 struct type **dont_print_vb)
905 struct obstack tmp_obstack;
906 struct type **last_dont_print
907 = (struct type **) obstack_next_free (&dont_print_vb_obstack);
908 int i, n_baseclasses = TYPE_N_BASECLASSES (type);
910 if (dont_print_vb == 0)
912 /* If we're at top level, carve out a completely fresh
913 chunk of the obstack and use that until this particular
914 invocation returns. */
915 tmp_obstack = dont_print_vb_obstack;
916 /* Bump up the high-water mark. Now alpha is omega. */
917 obstack_finish (&dont_print_vb_obstack);
920 for (i = 0; i < n_baseclasses; i++)
923 struct type *baseclass = check_typedef (TYPE_BASECLASS (type, i));
924 char *basename = TYPE_NAME (baseclass);
927 if (BASETYPE_VIA_VIRTUAL (type, i))
929 struct type **first_dont_print
930 = (struct type **) obstack_base (&dont_print_vb_obstack);
932 int j = (struct type **) obstack_next_free (&dont_print_vb_obstack)
936 if (baseclass == first_dont_print[j])
939 obstack_ptr_grow (&dont_print_vb_obstack, baseclass);
942 boffset = baseclass_offset (type, i, valaddr, address);
946 fprintf_filtered (stream, "\n");
947 print_spaces_filtered (2 * recurse, stream);
949 fputs_filtered ("<", stream);
950 /* Not sure what the best notation is in the case where there is no
953 fputs_filtered (basename ? basename : "", stream);
954 fputs_filtered ("> = ", stream);
956 /* The virtual base class pointer might have been clobbered by the
957 user program. Make sure that it still points to a valid memory
960 if (boffset != -1 && (boffset < 0 || boffset >= TYPE_LENGTH (type)))
962 /* FIXME (alloc): not safe is baseclass is really really big. */
963 base_valaddr = (char *) alloca (TYPE_LENGTH (baseclass));
964 if (target_read_memory (address + boffset, base_valaddr,
965 TYPE_LENGTH (baseclass)) != 0)
969 base_valaddr = valaddr + boffset;
972 fprintf_filtered (stream, "<invalid address>");
974 pascal_object_print_value_fields (baseclass, base_valaddr, address + boffset,
975 stream, format, recurse, pretty,
976 (struct type **) obstack_base (&dont_print_vb_obstack),
978 fputs_filtered (", ", stream);
984 if (dont_print_vb == 0)
986 /* Free the space used to deal with the printing
987 of this type from top level. */
988 obstack_free (&dont_print_vb_obstack, last_dont_print);
989 /* Reset watermark so that we can continue protecting
990 ourselves from whatever we were protecting ourselves. */
991 dont_print_vb_obstack = tmp_obstack;
995 /* Print value of a static member.
996 To avoid infinite recursion when printing a class that contains
997 a static instance of the class, we keep the addresses of all printed
998 static member classes in an obstack and refuse to print them more
1001 VAL contains the value to print, STREAM, RECURSE, and PRETTY
1002 have the same meanings as in c_val_print. */
1005 pascal_object_print_static_field (struct value *val,
1006 struct ui_file *stream, int format,
1007 int recurse, enum val_prettyprint pretty)
1009 struct type *type = VALUE_TYPE (val);
1011 if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1013 CORE_ADDR *first_dont_print;
1017 = (CORE_ADDR *) obstack_base (&dont_print_statmem_obstack);
1018 i = (CORE_ADDR *) obstack_next_free (&dont_print_statmem_obstack)
1023 if (VALUE_ADDRESS (val) == first_dont_print[i])
1025 fputs_filtered ("<same as static member of an already seen type>",
1031 obstack_grow (&dont_print_statmem_obstack, (char *) &VALUE_ADDRESS (val),
1032 sizeof (CORE_ADDR));
1034 CHECK_TYPEDEF (type);
1035 pascal_object_print_value_fields (type, VALUE_CONTENTS (val), VALUE_ADDRESS (val),
1036 stream, format, recurse, pretty, NULL, 1);
1039 common_val_print (val, stream, format, 0, recurse, pretty);
1043 pascal_object_print_class_member (char *valaddr, struct type *domain,
1044 struct ui_file *stream, char *prefix)
1047 /* VAL is a byte offset into the structure type DOMAIN.
1048 Find the name of the field for that offset and
1053 unsigned len = TYPE_NFIELDS (domain);
1054 /* @@ Make VAL into bit offset */
1055 LONGEST val = unpack_long (builtin_type_int, valaddr) << 3;
1056 for (i = TYPE_N_BASECLASSES (domain); i < len; i++)
1058 int bitpos = TYPE_FIELD_BITPOS (domain, i);
1062 if (val < bitpos && i != 0)
1064 /* Somehow pointing into a field. */
1066 extra = (val - TYPE_FIELD_BITPOS (domain, i));
1077 fputs_filtered (prefix, stream);
1078 name = type_name_no_tag (domain);
1080 fputs_filtered (name, stream);
1082 pascal_type_print_base (domain, stream, 0, 0);
1083 fprintf_filtered (stream, "::");
1084 fputs_filtered (TYPE_FIELD_NAME (domain, i), stream);
1086 fprintf_filtered (stream, " + %d bytes", extra);
1088 fprintf_filtered (stream, " (offset in bits)");
1091 fprintf_filtered (stream, "%ld", (long int) (val >> 3));
1094 extern initialize_file_ftype _initialize_pascal_valprint; /* -Wmissing-prototypes */
1097 _initialize_pascal_valprint (void)
1100 (add_set_cmd ("pascal_static-members", class_support, var_boolean,
1101 (char *) &pascal_static_field_print,
1102 "Set printing of pascal static members.",
1105 /* Turn on printing of static fields. */
1106 pascal_static_field_print = 1;