p-valprint.c revision 1.5
1/* Support for printing Pascal values for GDB, the GNU debugger.
2
3   Copyright (C) 2000-2015 Free Software Foundation, Inc.
4
5   This file is part of GDB.
6
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.
11
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.
16
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/>.  */
19
20/* This file is derived from c-valprint.c */
21
22#include "defs.h"
23#include "gdb_obstack.h"
24#include "symtab.h"
25#include "gdbtypes.h"
26#include "expression.h"
27#include "value.h"
28#include "command.h"
29#include "gdbcmd.h"
30#include "gdbcore.h"
31#include "demangle.h"
32#include "valprint.h"
33#include "typeprint.h"
34#include "language.h"
35#include "target.h"
36#include "annotate.h"
37#include "p-lang.h"
38#include "cp-abi.h"
39#include "cp-support.h"
40#include "objfiles.h"
41
42
43/* Decorations for Pascal.  */
44
45static const struct generic_val_print_decorations p_decorations =
46{
47  "",
48  " + ",
49  " * I",
50  "true",
51  "false",
52  "void"
53};
54
55/* See val_print for a description of the various parameters of this
56   function; they are identical.  */
57
58void
59pascal_val_print (struct type *type, const gdb_byte *valaddr,
60		  int embedded_offset, CORE_ADDR address,
61		  struct ui_file *stream, int recurse,
62		  const struct value *original_value,
63		  const struct value_print_options *options)
64{
65  struct gdbarch *gdbarch = get_type_arch (type);
66  enum bfd_endian byte_order = gdbarch_byte_order (gdbarch);
67  unsigned int i = 0;	/* Number of characters printed */
68  unsigned len;
69  LONGEST low_bound, high_bound;
70  struct type *elttype;
71  unsigned eltlen;
72  int length_pos, length_size, string_pos;
73  struct type *char_type;
74  CORE_ADDR addr;
75  int want_space = 0;
76
77  CHECK_TYPEDEF (type);
78  switch (TYPE_CODE (type))
79    {
80    case TYPE_CODE_ARRAY:
81      if (get_array_bounds (type, &low_bound, &high_bound))
82	{
83	  len = high_bound - low_bound + 1;
84	  elttype = check_typedef (TYPE_TARGET_TYPE (type));
85	  eltlen = TYPE_LENGTH (elttype);
86	  if (options->prettyformat_arrays)
87	    {
88	      print_spaces_filtered (2 + 2 * recurse, stream);
89	    }
90	  /* If 's' format is used, try to print out as string.
91	     If no format is given, print as string if element type
92	     is of TYPE_CODE_CHAR and element size is 1,2 or 4.  */
93	  if (options->format == 's'
94	      || ((eltlen == 1 || eltlen == 2 || eltlen == 4)
95		  && TYPE_CODE (elttype) == TYPE_CODE_CHAR
96		  && options->format == 0))
97	    {
98	      /* If requested, look for the first null char and only print
99	         elements up to it.  */
100	      if (options->stop_print_at_null)
101		{
102		  unsigned int temp_len;
103
104		  /* Look for a NULL char.  */
105		  for (temp_len = 0;
106		       extract_unsigned_integer (valaddr + embedded_offset +
107						 temp_len * eltlen, eltlen,
108						 byte_order)
109		       && temp_len < len && temp_len < options->print_max;
110		       temp_len++);
111		  len = temp_len;
112		}
113
114	      LA_PRINT_STRING (stream, TYPE_TARGET_TYPE (type),
115			       valaddr + embedded_offset, len, NULL, 0,
116			       options);
117	      i = len;
118	    }
119	  else
120	    {
121	      fprintf_filtered (stream, "{");
122	      /* If this is a virtual function table, print the 0th
123	         entry specially, and the rest of the members normally.  */
124	      if (pascal_object_is_vtbl_ptr_type (elttype))
125		{
126		  i = 1;
127		  fprintf_filtered (stream, "%d vtable entries", len - 1);
128		}
129	      else
130		{
131		  i = 0;
132		}
133	      val_print_array_elements (type, valaddr, embedded_offset,
134					address, stream, recurse,
135					original_value, options, i);
136	      fprintf_filtered (stream, "}");
137	    }
138	  break;
139	}
140      /* Array of unspecified length: treat like pointer to first elt.  */
141      addr = address + embedded_offset;
142      goto print_unpacked_pointer;
143
144    case TYPE_CODE_PTR:
145      if (options->format && options->format != 's')
146	{
147	  val_print_scalar_formatted (type, valaddr, embedded_offset,
148				      original_value, options, 0, stream);
149	  break;
150	}
151      if (options->vtblprint && pascal_object_is_vtbl_ptr_type (type))
152	{
153	  /* Print the unmangled name if desired.  */
154	  /* Print vtable entry - we only get here if we ARE using
155	     -fvtable_thunks.  (Otherwise, look under TYPE_CODE_STRUCT.)  */
156	  /* Extract the address, assume that it is unsigned.  */
157	  addr = extract_unsigned_integer (valaddr + embedded_offset,
158					   TYPE_LENGTH (type), byte_order);
159	  print_address_demangle (options, gdbarch, addr, stream, demangle);
160	  break;
161	}
162      check_typedef (TYPE_TARGET_TYPE (type));
163
164      addr = unpack_pointer (type, valaddr + embedded_offset);
165    print_unpacked_pointer:
166      elttype = check_typedef (TYPE_TARGET_TYPE (type));
167
168      if (TYPE_CODE (elttype) == TYPE_CODE_FUNC)
169	{
170	  /* Try to print what function it points to.  */
171	  print_address_demangle (options, gdbarch, addr, stream, demangle);
172	  return;
173	}
174
175      if (options->addressprint && options->format != 's')
176	{
177	  fputs_filtered (paddress (gdbarch, addr), stream);
178	  want_space = 1;
179	}
180
181      /* For a pointer to char or unsigned char, also print the string
182	 pointed to, unless pointer is null.  */
183      if (((TYPE_LENGTH (elttype) == 1
184	   && (TYPE_CODE (elttype) == TYPE_CODE_INT
185	      || TYPE_CODE (elttype) == TYPE_CODE_CHAR))
186	  || ((TYPE_LENGTH (elttype) == 2 || TYPE_LENGTH (elttype) == 4)
187	      && TYPE_CODE (elttype) == TYPE_CODE_CHAR))
188	  && (options->format == 0 || options->format == 's')
189	  && addr != 0)
190	{
191	  if (want_space)
192	    fputs_filtered (" ", stream);
193	  /* No wide string yet.  */
194	  i = val_print_string (elttype, NULL, addr, -1, stream, options);
195	}
196      /* Also for pointers to pascal strings.  */
197      /* Note: this is Free Pascal specific:
198	 as GDB does not recognize stabs pascal strings
199	 Pascal strings are mapped to records
200	 with lowercase names PM.  */
201      if (is_pascal_string_type (elttype, &length_pos, &length_size,
202				 &string_pos, &char_type, NULL)
203	  && addr != 0)
204	{
205	  ULONGEST string_length;
206	  void *buffer;
207
208	  if (want_space)
209	    fputs_filtered (" ", stream);
210	  buffer = xmalloc (length_size);
211	  read_memory (addr + length_pos, buffer, length_size);
212	  string_length = extract_unsigned_integer (buffer, length_size,
213						    byte_order);
214	  xfree (buffer);
215	  i = val_print_string (char_type, NULL,
216				addr + string_pos, string_length,
217				stream, options);
218	}
219      else if (pascal_object_is_vtbl_member (type))
220	{
221	  /* Print vtbl's nicely.  */
222	  CORE_ADDR vt_address = unpack_pointer (type,
223						 valaddr + embedded_offset);
224	  struct bound_minimal_symbol msymbol =
225	    lookup_minimal_symbol_by_pc (vt_address);
226
227	  /* If 'symbol_print' is set, we did the work above.  */
228	  if (!options->symbol_print
229	      && (msymbol.minsym != NULL)
230	      && (vt_address == BMSYMBOL_VALUE_ADDRESS (msymbol)))
231	    {
232	      if (want_space)
233		fputs_filtered (" ", stream);
234	      fputs_filtered ("<", stream);
235	      fputs_filtered (MSYMBOL_PRINT_NAME (msymbol.minsym), stream);
236	      fputs_filtered (">", stream);
237	      want_space = 1;
238	    }
239	  if (vt_address && options->vtblprint)
240	    {
241	      struct value *vt_val;
242	      struct symbol *wsym = (struct symbol *) NULL;
243	      struct type *wtype;
244	      struct block *block = (struct block *) NULL;
245	      struct field_of_this_result is_this_fld;
246
247	      if (want_space)
248		fputs_filtered (" ", stream);
249
250	      if (msymbol.minsym != NULL)
251		wsym = lookup_symbol (MSYMBOL_LINKAGE_NAME (msymbol.minsym),
252				      block,
253				      VAR_DOMAIN, &is_this_fld);
254
255	      if (wsym)
256		{
257		  wtype = SYMBOL_TYPE (wsym);
258		}
259	      else
260		{
261		  wtype = TYPE_TARGET_TYPE (type);
262		}
263	      vt_val = value_at (wtype, vt_address);
264	      common_val_print (vt_val, stream, recurse + 1, options,
265				current_language);
266	      if (options->prettyformat)
267		{
268		  fprintf_filtered (stream, "\n");
269		  print_spaces_filtered (2 + 2 * recurse, stream);
270		}
271	    }
272	}
273
274      return;
275
276    case TYPE_CODE_REF:
277    case TYPE_CODE_ENUM:
278    case TYPE_CODE_FLAGS:
279    case TYPE_CODE_FUNC:
280    case TYPE_CODE_RANGE:
281    case TYPE_CODE_INT:
282    case TYPE_CODE_FLT:
283    case TYPE_CODE_VOID:
284    case TYPE_CODE_ERROR:
285    case TYPE_CODE_UNDEF:
286    case TYPE_CODE_BOOL:
287    case TYPE_CODE_CHAR:
288      generic_val_print (type, valaddr, embedded_offset, address,
289			 stream, recurse, original_value, options,
290			 &p_decorations);
291      break;
292
293    case TYPE_CODE_UNION:
294      if (recurse && !options->unionprint)
295	{
296	  fprintf_filtered (stream, "{...}");
297	  break;
298	}
299      /* Fall through.  */
300    case TYPE_CODE_STRUCT:
301      if (options->vtblprint && pascal_object_is_vtbl_ptr_type (type))
302	{
303	  /* Print the unmangled name if desired.  */
304	  /* Print vtable entry - we only get here if NOT using
305	     -fvtable_thunks.  (Otherwise, look under TYPE_CODE_PTR.)  */
306	  /* Extract the address, assume that it is unsigned.  */
307	  print_address_demangle
308	    (options, gdbarch,
309	     extract_unsigned_integer (valaddr + embedded_offset
310				       + TYPE_FIELD_BITPOS (type,
311							    VTBL_FNADDR_OFFSET) / 8,
312				       TYPE_LENGTH (TYPE_FIELD_TYPE (type,
313								     VTBL_FNADDR_OFFSET)),
314				       byte_order),
315	     stream, demangle);
316	}
317      else
318	{
319          if (is_pascal_string_type (type, &length_pos, &length_size,
320                                     &string_pos, &char_type, NULL))
321	    {
322	      len = extract_unsigned_integer (valaddr + embedded_offset
323					      + length_pos, length_size,
324					      byte_order);
325	      LA_PRINT_STRING (stream, char_type,
326			       valaddr + embedded_offset + string_pos,
327			       len, NULL, 0, options);
328	    }
329	  else
330	    pascal_object_print_value_fields (type, valaddr, embedded_offset,
331					      address, stream, recurse,
332					      original_value, options,
333					      NULL, 0);
334	}
335      break;
336
337    case TYPE_CODE_SET:
338      elttype = TYPE_INDEX_TYPE (type);
339      CHECK_TYPEDEF (elttype);
340      if (TYPE_STUB (elttype))
341	{
342	  fprintf_filtered (stream, "<incomplete type>");
343	  gdb_flush (stream);
344	  break;
345	}
346      else
347	{
348	  struct type *range = elttype;
349	  LONGEST low_bound, high_bound;
350	  int i;
351	  int need_comma = 0;
352
353	  fputs_filtered ("[", stream);
354
355	  i = get_discrete_bounds (range, &low_bound, &high_bound);
356	  if (low_bound == 0 && high_bound == -1 && TYPE_LENGTH (type) > 0)
357	    {
358	      /* If we know the size of the set type, we can figure out the
359	      maximum value.  */
360	      i = 0;
361	      high_bound = TYPE_LENGTH (type) * TARGET_CHAR_BIT - 1;
362	      TYPE_HIGH_BOUND (range) = high_bound;
363	    }
364	maybe_bad_bstring:
365	  if (i < 0)
366	    {
367	      fputs_filtered ("<error value>", stream);
368	      goto done;
369	    }
370
371	  for (i = low_bound; i <= high_bound; i++)
372	    {
373	      int element = value_bit_index (type,
374					     valaddr + embedded_offset, i);
375
376	      if (element < 0)
377		{
378		  i = element;
379		  goto maybe_bad_bstring;
380		}
381	      if (element)
382		{
383		  if (need_comma)
384		    fputs_filtered (", ", stream);
385		  print_type_scalar (range, i, stream);
386		  need_comma = 1;
387
388		  if (i + 1 <= high_bound
389		      && value_bit_index (type,
390					  valaddr + embedded_offset, ++i))
391		    {
392		      int j = i;
393
394		      fputs_filtered ("..", stream);
395		      while (i + 1 <= high_bound
396			     && value_bit_index (type,
397						 valaddr + embedded_offset,
398						 ++i))
399			j = i;
400		      print_type_scalar (range, j, stream);
401		    }
402		}
403	    }
404	done:
405	  fputs_filtered ("]", stream);
406	}
407      break;
408
409    default:
410      error (_("Invalid pascal type code %d in symbol table."),
411	     TYPE_CODE (type));
412    }
413  gdb_flush (stream);
414}
415
416void
417pascal_value_print (struct value *val, struct ui_file *stream,
418		    const struct value_print_options *options)
419{
420  struct type *type = value_type (val);
421  struct value_print_options opts = *options;
422
423  opts.deref_ref = 1;
424
425  /* If it is a pointer, indicate what it points to.
426
427     Print type also if it is a reference.
428
429     Object pascal: if it is a member pointer, we will take care
430     of that when we print it.  */
431  if (TYPE_CODE (type) == TYPE_CODE_PTR
432      || TYPE_CODE (type) == TYPE_CODE_REF)
433    {
434      /* Hack:  remove (char *) for char strings.  Their
435         type is indicated by the quoted string anyway.  */
436      if (TYPE_CODE (type) == TYPE_CODE_PTR
437	  && TYPE_NAME (type) == NULL
438	  && TYPE_NAME (TYPE_TARGET_TYPE (type)) != NULL
439	  && strcmp (TYPE_NAME (TYPE_TARGET_TYPE (type)), "char") == 0)
440	{
441	  /* Print nothing.  */
442	}
443      else
444	{
445	  fprintf_filtered (stream, "(");
446	  type_print (type, "", stream, -1);
447	  fprintf_filtered (stream, ") ");
448	}
449    }
450  common_val_print (val, stream, 0, &opts, current_language);
451}
452
453
454static void
455show_pascal_static_field_print (struct ui_file *file, int from_tty,
456				struct cmd_list_element *c, const char *value)
457{
458  fprintf_filtered (file, _("Printing of pascal static members is %s.\n"),
459		    value);
460}
461
462static struct obstack dont_print_vb_obstack;
463static struct obstack dont_print_statmem_obstack;
464
465static void pascal_object_print_static_field (struct value *,
466					      struct ui_file *, int,
467					      const struct value_print_options *);
468
469static void pascal_object_print_value (struct type *, const gdb_byte *,
470				       int,
471				       CORE_ADDR, struct ui_file *, int,
472				       const struct value *,
473				       const struct value_print_options *,
474				       struct type **);
475
476/* It was changed to this after 2.4.5.  */
477const char pascal_vtbl_ptr_name[] =
478{'_', '_', 'v', 't', 'b', 'l', '_', 'p', 't', 'r', '_', 't', 'y', 'p', 'e', 0};
479
480/* Return truth value for assertion that TYPE is of the type
481   "pointer to virtual function".  */
482
483int
484pascal_object_is_vtbl_ptr_type (struct type *type)
485{
486  const char *type_name = type_name_no_tag (type);
487
488  return (type_name != NULL
489	  && strcmp (type_name, pascal_vtbl_ptr_name) == 0);
490}
491
492/* Return truth value for the assertion that TYPE is of the type
493   "pointer to virtual function table".  */
494
495int
496pascal_object_is_vtbl_member (struct type *type)
497{
498  if (TYPE_CODE (type) == TYPE_CODE_PTR)
499    {
500      type = TYPE_TARGET_TYPE (type);
501      if (TYPE_CODE (type) == TYPE_CODE_ARRAY)
502	{
503	  type = TYPE_TARGET_TYPE (type);
504	  if (TYPE_CODE (type) == TYPE_CODE_STRUCT	/* If not using
505							   thunks.  */
506	      || TYPE_CODE (type) == TYPE_CODE_PTR)	/* If using thunks.  */
507	    {
508	      /* Virtual functions tables are full of pointers
509	         to virtual functions.  */
510	      return pascal_object_is_vtbl_ptr_type (type);
511	    }
512	}
513    }
514  return 0;
515}
516
517/* Mutually recursive subroutines of pascal_object_print_value and
518   c_val_print to print out a structure's fields:
519   pascal_object_print_value_fields and pascal_object_print_value.
520
521   TYPE, VALADDR, ADDRESS, STREAM, RECURSE, and OPTIONS have the
522   same meanings as in pascal_object_print_value and c_val_print.
523
524   DONT_PRINT is an array of baseclass types that we
525   should not print, or zero if called from top level.  */
526
527void
528pascal_object_print_value_fields (struct type *type, const gdb_byte *valaddr,
529				  int offset,
530				  CORE_ADDR address, struct ui_file *stream,
531				  int recurse,
532				  const struct value *val,
533				  const struct value_print_options *options,
534				  struct type **dont_print_vb,
535				  int dont_print_statmem)
536{
537  int i, len, n_baseclasses;
538  char *last_dont_print = obstack_next_free (&dont_print_statmem_obstack);
539
540  CHECK_TYPEDEF (type);
541
542  fprintf_filtered (stream, "{");
543  len = TYPE_NFIELDS (type);
544  n_baseclasses = TYPE_N_BASECLASSES (type);
545
546  /* Print out baseclasses such that we don't print
547     duplicates of virtual baseclasses.  */
548  if (n_baseclasses > 0)
549    pascal_object_print_value (type, valaddr, offset, address,
550			       stream, recurse + 1, val,
551			       options, dont_print_vb);
552
553  if (!len && n_baseclasses == 1)
554    fprintf_filtered (stream, "<No data fields>");
555  else
556    {
557      struct obstack tmp_obstack = dont_print_statmem_obstack;
558      int fields_seen = 0;
559
560      if (dont_print_statmem == 0)
561	{
562	  /* If we're at top level, carve out a completely fresh
563	     chunk of the obstack and use that until this particular
564	     invocation returns.  */
565	  obstack_finish (&dont_print_statmem_obstack);
566	}
567
568      for (i = n_baseclasses; i < len; i++)
569	{
570	  /* If requested, skip printing of static fields.  */
571	  if (!options->pascal_static_field_print
572	      && field_is_static (&TYPE_FIELD (type, i)))
573	    continue;
574	  if (fields_seen)
575	    fprintf_filtered (stream, ", ");
576	  else if (n_baseclasses > 0)
577	    {
578	      if (options->prettyformat)
579		{
580		  fprintf_filtered (stream, "\n");
581		  print_spaces_filtered (2 + 2 * recurse, stream);
582		  fputs_filtered ("members of ", stream);
583		  fputs_filtered (type_name_no_tag (type), stream);
584		  fputs_filtered (": ", stream);
585		}
586	    }
587	  fields_seen = 1;
588
589	  if (options->prettyformat)
590	    {
591	      fprintf_filtered (stream, "\n");
592	      print_spaces_filtered (2 + 2 * recurse, stream);
593	    }
594	  else
595	    {
596	      wrap_here (n_spaces (2 + 2 * recurse));
597	    }
598
599	  annotate_field_begin (TYPE_FIELD_TYPE (type, i));
600
601	  if (field_is_static (&TYPE_FIELD (type, i)))
602	    fputs_filtered ("static ", stream);
603	  fprintf_symbol_filtered (stream, TYPE_FIELD_NAME (type, i),
604				   language_cplus,
605				   DMGL_PARAMS | DMGL_ANSI);
606	  annotate_field_name_end ();
607	  fputs_filtered (" = ", stream);
608	  annotate_field_value ();
609
610	  if (!field_is_static (&TYPE_FIELD (type, i))
611	      && TYPE_FIELD_PACKED (type, i))
612	    {
613	      struct value *v;
614
615	      /* Bitfields require special handling, especially due to byte
616	         order problems.  */
617	      if (TYPE_FIELD_IGNORE (type, i))
618		{
619		  fputs_filtered ("<optimized out or zero length>", stream);
620		}
621	      else if (value_bits_synthetic_pointer (val,
622						     TYPE_FIELD_BITPOS (type,
623									i),
624						     TYPE_FIELD_BITSIZE (type,
625									 i)))
626		{
627		  fputs_filtered (_("<synthetic pointer>"), stream);
628		}
629	      else
630		{
631		  struct value_print_options opts = *options;
632
633		  v = value_field_bitfield (type, i, valaddr, offset, val);
634
635		  opts.deref_ref = 0;
636		  common_val_print (v, stream, recurse + 1, &opts,
637				    current_language);
638		}
639	    }
640	  else
641	    {
642	      if (TYPE_FIELD_IGNORE (type, i))
643		{
644		  fputs_filtered ("<optimized out or zero length>", stream);
645		}
646	      else if (field_is_static (&TYPE_FIELD (type, i)))
647		{
648		  /* struct value *v = value_static_field (type, i);
649		     v4.17 specific.  */
650		  struct value *v;
651
652		  v = value_field_bitfield (type, i, valaddr, offset, val);
653
654		  if (v == NULL)
655		    val_print_optimized_out (NULL, stream);
656		  else
657		    pascal_object_print_static_field (v, stream, recurse + 1,
658						      options);
659		}
660	      else
661		{
662		  struct value_print_options opts = *options;
663
664		  opts.deref_ref = 0;
665		  /* val_print (TYPE_FIELD_TYPE (type, i),
666		     valaddr + TYPE_FIELD_BITPOS (type, i) / 8,
667		     address + TYPE_FIELD_BITPOS (type, i) / 8, 0,
668		     stream, format, 0, recurse + 1, pretty); */
669		  val_print (TYPE_FIELD_TYPE (type, i),
670			     valaddr, offset + TYPE_FIELD_BITPOS (type, i) / 8,
671			     address, stream, recurse + 1, val, &opts,
672			     current_language);
673		}
674	    }
675	  annotate_field_end ();
676	}
677
678      if (dont_print_statmem == 0)
679	{
680	  /* Free the space used to deal with the printing
681	     of the members from top level.  */
682	  obstack_free (&dont_print_statmem_obstack, last_dont_print);
683	  dont_print_statmem_obstack = tmp_obstack;
684	}
685
686      if (options->prettyformat)
687	{
688	  fprintf_filtered (stream, "\n");
689	  print_spaces_filtered (2 * recurse, stream);
690	}
691    }
692  fprintf_filtered (stream, "}");
693}
694
695/* Special val_print routine to avoid printing multiple copies of virtual
696   baseclasses.  */
697
698static void
699pascal_object_print_value (struct type *type, const gdb_byte *valaddr,
700			   int offset,
701			   CORE_ADDR address, struct ui_file *stream,
702			   int recurse,
703			   const struct value *val,
704			   const struct value_print_options *options,
705			   struct type **dont_print_vb)
706{
707  struct type **last_dont_print
708    = (struct type **) obstack_next_free (&dont_print_vb_obstack);
709  struct obstack tmp_obstack = dont_print_vb_obstack;
710  int i, n_baseclasses = TYPE_N_BASECLASSES (type);
711
712  if (dont_print_vb == 0)
713    {
714      /* If we're at top level, carve out a completely fresh
715         chunk of the obstack and use that until this particular
716         invocation returns.  */
717      /* Bump up the high-water mark.  Now alpha is omega.  */
718      obstack_finish (&dont_print_vb_obstack);
719    }
720
721  for (i = 0; i < n_baseclasses; i++)
722    {
723      int boffset = 0;
724      struct type *baseclass = check_typedef (TYPE_BASECLASS (type, i));
725      const char *basename = type_name_no_tag (baseclass);
726      const gdb_byte *base_valaddr = NULL;
727      int thisoffset;
728      int skip = 0;
729
730      if (BASETYPE_VIA_VIRTUAL (type, i))
731	{
732	  struct type **first_dont_print
733	    = (struct type **) obstack_base (&dont_print_vb_obstack);
734
735	  int j = (struct type **) obstack_next_free (&dont_print_vb_obstack)
736	    - first_dont_print;
737
738	  while (--j >= 0)
739	    if (baseclass == first_dont_print[j])
740	      goto flush_it;
741
742	  obstack_ptr_grow (&dont_print_vb_obstack, baseclass);
743	}
744
745      thisoffset = offset;
746
747      TRY
748	{
749	  boffset = baseclass_offset (type, i, valaddr, offset, address, val);
750	}
751      CATCH (ex, RETURN_MASK_ERROR)
752	{
753	  if (ex.error == NOT_AVAILABLE_ERROR)
754	    skip = -1;
755	  else
756	    skip = 1;
757	}
758      END_CATCH
759
760      if (skip == 0)
761	{
762	  /* The virtual base class pointer might have been clobbered by the
763	     user program. Make sure that it still points to a valid memory
764	     location.  */
765
766	  if (boffset < 0 || boffset >= TYPE_LENGTH (type))
767	    {
768	      gdb_byte *buf;
769	      struct cleanup *back_to;
770
771	      buf = xmalloc (TYPE_LENGTH (baseclass));
772	      back_to = make_cleanup (xfree, buf);
773
774	      base_valaddr = buf;
775	      if (target_read_memory (address + boffset, buf,
776				      TYPE_LENGTH (baseclass)) != 0)
777		skip = 1;
778	      address = address + boffset;
779	      thisoffset = 0;
780	      boffset = 0;
781	      do_cleanups (back_to);
782	    }
783	  else
784	    base_valaddr = valaddr;
785	}
786
787      if (options->prettyformat)
788	{
789	  fprintf_filtered (stream, "\n");
790	  print_spaces_filtered (2 * recurse, stream);
791	}
792      fputs_filtered ("<", stream);
793      /* Not sure what the best notation is in the case where there is no
794         baseclass name.  */
795
796      fputs_filtered (basename ? basename : "", stream);
797      fputs_filtered ("> = ", stream);
798
799      if (skip < 0)
800	val_print_unavailable (stream);
801      else if (skip > 0)
802	val_print_invalid_address (stream);
803      else
804	pascal_object_print_value_fields (baseclass, base_valaddr,
805					  thisoffset + boffset, address,
806					  stream, recurse, val, options,
807		     (struct type **) obstack_base (&dont_print_vb_obstack),
808					  0);
809      fputs_filtered (", ", stream);
810
811    flush_it:
812      ;
813    }
814
815  if (dont_print_vb == 0)
816    {
817      /* Free the space used to deal with the printing
818         of this type from top level.  */
819      obstack_free (&dont_print_vb_obstack, last_dont_print);
820      /* Reset watermark so that we can continue protecting
821         ourselves from whatever we were protecting ourselves.  */
822      dont_print_vb_obstack = tmp_obstack;
823    }
824}
825
826/* Print value of a static member.
827   To avoid infinite recursion when printing a class that contains
828   a static instance of the class, we keep the addresses of all printed
829   static member classes in an obstack and refuse to print them more
830   than once.
831
832   VAL contains the value to print, STREAM, RECURSE, and OPTIONS
833   have the same meanings as in c_val_print.  */
834
835static void
836pascal_object_print_static_field (struct value *val,
837				  struct ui_file *stream,
838				  int recurse,
839				  const struct value_print_options *options)
840{
841  struct type *type = value_type (val);
842  struct value_print_options opts;
843
844  if (value_entirely_optimized_out (val))
845    {
846      val_print_optimized_out (val, stream);
847      return;
848    }
849
850  if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
851    {
852      CORE_ADDR *first_dont_print, addr;
853      int i;
854
855      first_dont_print
856	= (CORE_ADDR *) obstack_base (&dont_print_statmem_obstack);
857      i = (CORE_ADDR *) obstack_next_free (&dont_print_statmem_obstack)
858	- first_dont_print;
859
860      while (--i >= 0)
861	{
862	  if (value_address (val) == first_dont_print[i])
863	    {
864	      fputs_filtered ("\
865<same as static member of an already seen type>",
866			      stream);
867	      return;
868	    }
869	}
870
871      addr = value_address (val);
872      obstack_grow (&dont_print_statmem_obstack, (char *) &addr,
873		    sizeof (CORE_ADDR));
874
875      CHECK_TYPEDEF (type);
876      pascal_object_print_value_fields (type,
877					value_contents_for_printing (val),
878					value_embedded_offset (val),
879					addr,
880					stream, recurse,
881					val, options, NULL, 1);
882      return;
883    }
884
885  opts = *options;
886  opts.deref_ref = 0;
887  common_val_print (val, stream, recurse, &opts, current_language);
888}
889
890/* -Wmissing-prototypes */
891extern initialize_file_ftype _initialize_pascal_valprint;
892
893void
894_initialize_pascal_valprint (void)
895{
896  add_setshow_boolean_cmd ("pascal_static-members", class_support,
897			   &user_print_options.pascal_static_field_print, _("\
898Set printing of pascal static members."), _("\
899Show printing of pascal static members."), NULL,
900			   NULL,
901			   show_pascal_static_field_print,
902			   &setprintlist, &showprintlist);
903}
904