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