Rewrite pascal_value_print_inner

This rewrites pascal_value_print_inner, copying in the body of
pascal_val_print_inner and adusting as needed.  This will form the
base of future changes to fully convert this to using the value-based
API.

gdb/ChangeLog
2020-03-13  Tom Tromey  <tom@tromey.com>

	* p-valprint.c (pascal_value_print_inner): Rewrite.

2 files changed, 340 insertions, 2 deletions

diff --git a/gdb/ChangeLog b/gdb/ChangeLog
index 75ac39c..07b5d62 100644
--- a/gdb/ChangeLog
+++ b/gdb/ChangeLog
@@ -1,5 +1,9 @@
 2020-03-13  Tom Tromey  <tom@tromey.com>
 
+	* p-valprint.c (pascal_value_print_inner): Rewrite.
+
+2020-03-13  Tom Tromey  <tom@tromey.com>
+
 	* f-valprint.c (f_value_print_innner): Rewrite.
 
 2020-03-13  Tom Tromey  <tom@tromey.com>
diff --git a/gdb/p-valprint.c b/gdb/p-valprint.c
index 1361fbe..7a54d30 100644
--- a/gdb/p-valprint.c
+++ b/gdb/p-valprint.c
@@ -434,8 +434,342 @@ pascal_value_print_inner (struct value *val, struct ui_file *stream,
 			  const struct value_print_options *options)
 
 {
-  pascal_val_print (value_type (val), value_embedded_offset (val),
-		    value_address (val), stream, recurse, val, options);
+  struct type *type = check_typedef (value_type (val));
+  struct gdbarch *gdbarch = get_type_arch (type);
+  enum bfd_endian byte_order = type_byte_order (type);
+  unsigned int i = 0;	/* Number of characters printed */
+  unsigned len;
+  struct type *elttype;
+  unsigned eltlen;
+  int length_pos, length_size, string_pos;
+  struct type *char_type;
+  CORE_ADDR addr;
+  int want_space = 0;
+  const gdb_byte *valaddr = value_contents_for_printing (val);
+
+  switch (TYPE_CODE (type))
+    {
+    case TYPE_CODE_ARRAY:
+      {
+	LONGEST low_bound, high_bound;
+
+	if (get_array_bounds (type, &low_bound, &high_bound))
+	  {
+	    len = high_bound - low_bound + 1;
+	    elttype = check_typedef (TYPE_TARGET_TYPE (type));
+	    eltlen = TYPE_LENGTH (elttype);
+	    if (options->prettyformat_arrays)
+	      {
+		print_spaces_filtered (2 + 2 * recurse, stream);
+	      }
+	    /* If 's' format is used, try to print out as string.
+	       If no format is given, print as string if element type
+	       is of TYPE_CODE_CHAR and element size is 1,2 or 4.  */
+	    if (options->format == 's'
+		|| ((eltlen == 1 || eltlen == 2 || eltlen == 4)
+		    && TYPE_CODE (elttype) == TYPE_CODE_CHAR
+		    && options->format == 0))
+	      {
+		/* If requested, look for the first null char and only print
+		   elements up to it.  */
+		if (options->stop_print_at_null)
+		  {
+		    unsigned int temp_len;
+
+		    /* Look for a NULL char.  */
+		    for (temp_len = 0;
+			 extract_unsigned_integer (valaddr + temp_len * eltlen,
+						   eltlen, byte_order)
+			   && temp_len < len && temp_len < options->print_max;
+			 temp_len++);
+		    len = temp_len;
+		  }
+
+		LA_PRINT_STRING (stream, TYPE_TARGET_TYPE (type),
+				 valaddr, len, NULL, 0, options);
+		i = len;
+	      }
+	    else
+	      {
+		fprintf_filtered (stream, "{");
+		/* If this is a virtual function table, print the 0th
+		   entry specially, and the rest of the members normally.  */
+		if (pascal_object_is_vtbl_ptr_type (elttype))
+		  {
+		    i = 1;
+		    fprintf_filtered (stream, "%d vtable entries", len - 1);
+		  }
+		else
+		  {
+		    i = 0;
+		  }
+		value_print_array_elements (val, stream, recurse, options, i);
+		fprintf_filtered (stream, "}");
+	      }
+	    break;
+	  }
+	/* Array of unspecified length: treat like pointer to first elt.  */
+	addr = value_address (val);
+      }
+      goto print_unpacked_pointer;
+
+    case TYPE_CODE_PTR:
+      if (options->format && options->format != 's')
+	{
+	  value_print_scalar_formatted (val, options, 0, stream);
+	  break;
+	}
+      if (options->vtblprint && pascal_object_is_vtbl_ptr_type (type))
+	{
+	  /* Print the unmangled name if desired.  */
+	  /* Print vtable entry - we only get here if we ARE using
+	     -fvtable_thunks.  (Otherwise, look under TYPE_CODE_STRUCT.)  */
+	  /* Extract the address, assume that it is unsigned.  */
+	  addr = extract_unsigned_integer (valaddr,
+					   TYPE_LENGTH (type), byte_order);
+	  print_address_demangle (options, gdbarch, addr, stream, demangle);
+	  break;
+	}
+      check_typedef (TYPE_TARGET_TYPE (type));
+
+      addr = unpack_pointer (type, valaddr);
+    print_unpacked_pointer:
+      elttype = check_typedef (TYPE_TARGET_TYPE (type));
+
+      if (TYPE_CODE (elttype) == TYPE_CODE_FUNC)
+	{
+	  /* Try to print what function it points to.  */
+	  print_address_demangle (options, gdbarch, addr, stream, demangle);
+	  return;
+	}
+
+      if (options->addressprint && options->format != 's')
+	{
+	  fputs_filtered (paddress (gdbarch, addr), stream);
+	  want_space = 1;
+	}
+
+      /* For a pointer to char or unsigned char, also print the string
+	 pointed to, unless pointer is null.  */
+      if (((TYPE_LENGTH (elttype) == 1
+	   && (TYPE_CODE (elttype) == TYPE_CODE_INT
+	      || TYPE_CODE (elttype) == TYPE_CODE_CHAR))
+	  || ((TYPE_LENGTH (elttype) == 2 || TYPE_LENGTH (elttype) == 4)
+	      && TYPE_CODE (elttype) == TYPE_CODE_CHAR))
+	  && (options->format == 0 || options->format == 's')
+	  && addr != 0)
+	{
+	  if (want_space)
+	    fputs_filtered (" ", stream);
+	  /* No wide string yet.  */
+	  i = val_print_string (elttype, NULL, addr, -1, stream, options);
+	}
+      /* Also for pointers to pascal strings.  */
+      /* Note: this is Free Pascal specific:
+	 as GDB does not recognize stabs pascal strings
+	 Pascal strings are mapped to records
+	 with lowercase names PM.  */
+      if (is_pascal_string_type (elttype, &length_pos, &length_size,
+				 &string_pos, &char_type, NULL)
+	  && addr != 0)
+	{
+	  ULONGEST string_length;
+	  gdb_byte *buffer;
+
+	  if (want_space)
+	    fputs_filtered (" ", stream);
+	  buffer = (gdb_byte *) xmalloc (length_size);
+	  read_memory (addr + length_pos, buffer, length_size);
+	  string_length = extract_unsigned_integer (buffer, length_size,
+						    byte_order);
+	  xfree (buffer);
+	  i = val_print_string (char_type, NULL,
+				addr + string_pos, string_length,
+				stream, options);
+	}
+      else if (pascal_object_is_vtbl_member (type))
+	{
+	  /* Print vtbl's nicely.  */
+	  CORE_ADDR vt_address = unpack_pointer (type, valaddr);
+	  struct bound_minimal_symbol msymbol =
+	    lookup_minimal_symbol_by_pc (vt_address);
+
+	  /* If 'symbol_print' is set, we did the work above.  */
+	  if (!options->symbol_print
+	      && (msymbol.minsym != NULL)
+	      && (vt_address == BMSYMBOL_VALUE_ADDRESS (msymbol)))
+	    {
+	      if (want_space)
+		fputs_filtered (" ", stream);
+	      fputs_filtered ("<", stream);
+	      fputs_filtered (msymbol.minsym->print_name (), stream);
+	      fputs_filtered (">", stream);
+	      want_space = 1;
+	    }
+	  if (vt_address && options->vtblprint)
+	    {
+	      struct value *vt_val;
+	      struct symbol *wsym = NULL;
+	      struct type *wtype;
+
+	      if (want_space)
+		fputs_filtered (" ", stream);
+
+	      if (msymbol.minsym != NULL)
+		{
+		  const char *search_name = msymbol.minsym->search_name ();
+		  wsym = lookup_symbol_search_name (search_name, NULL,
+						    VAR_DOMAIN).symbol;
+		}
+
+	      if (wsym)
+		{
+		  wtype = SYMBOL_TYPE (wsym);
+		}
+	      else
+		{
+		  wtype = TYPE_TARGET_TYPE (type);
+		}
+	      vt_val = value_at (wtype, vt_address);
+	      common_val_print (vt_val, stream, recurse + 1, options,
+				current_language);
+	      if (options->prettyformat)
+		{
+		  fprintf_filtered (stream, "\n");
+		  print_spaces_filtered (2 + 2 * recurse, stream);
+		}
+	    }
+	}
+
+      return;
+
+    case TYPE_CODE_REF:
+    case TYPE_CODE_ENUM:
+    case TYPE_CODE_FLAGS:
+    case TYPE_CODE_FUNC:
+    case TYPE_CODE_RANGE:
+    case TYPE_CODE_INT:
+    case TYPE_CODE_FLT:
+    case TYPE_CODE_VOID:
+    case TYPE_CODE_ERROR:
+    case TYPE_CODE_UNDEF:
+    case TYPE_CODE_BOOL:
+    case TYPE_CODE_CHAR:
+      generic_value_print (val, stream, recurse, options, &p_decorations);
+      break;
+
+    case TYPE_CODE_UNION:
+      if (recurse && !options->unionprint)
+	{
+	  fprintf_filtered (stream, "{...}");
+	  break;
+	}
+      /* Fall through.  */
+    case TYPE_CODE_STRUCT:
+      if (options->vtblprint && pascal_object_is_vtbl_ptr_type (type))
+	{
+	  /* Print the unmangled name if desired.  */
+	  /* Print vtable entry - we only get here if NOT using
+	     -fvtable_thunks.  (Otherwise, look under TYPE_CODE_PTR.)  */
+	  /* Extract the address, assume that it is unsigned.  */
+	  print_address_demangle
+	    (options, gdbarch,
+	     extract_unsigned_integer (valaddr
+				       + TYPE_FIELD_BITPOS (type,
+							    VTBL_FNADDR_OFFSET) / 8,
+				       TYPE_LENGTH (TYPE_FIELD_TYPE (type,
+								     VTBL_FNADDR_OFFSET)),
+				       byte_order),
+	     stream, demangle);
+	}
+      else
+	{
+          if (is_pascal_string_type (type, &length_pos, &length_size,
+                                     &string_pos, &char_type, NULL))
+	    {
+	      len = extract_unsigned_integer (valaddr + length_pos,
+					      length_size, byte_order);
+	      LA_PRINT_STRING (stream, char_type, valaddr + string_pos,
+			       len, NULL, 0, options);
+	    }
+	  else
+	    pascal_object_print_value_fields (type, valaddr, 0,
+					      value_address (val), stream,
+					      recurse, val, options,
+					      NULL, 0);
+	}
+      break;
+
+    case TYPE_CODE_SET:
+      elttype = TYPE_INDEX_TYPE (type);
+      elttype = check_typedef (elttype);
+      if (TYPE_STUB (elttype))
+	{
+	  fprintf_styled (stream, metadata_style.style (), "<incomplete type>");
+	  break;
+	}
+      else
+	{
+	  struct type *range = elttype;
+	  LONGEST low_bound, high_bound;
+	  int need_comma = 0;
+
+	  fputs_filtered ("[", stream);
+
+	  int bound_info = get_discrete_bounds (range, &low_bound, &high_bound);
+	  if (low_bound == 0 && high_bound == -1 && TYPE_LENGTH (type) > 0)
+	    {
+	      /* If we know the size of the set type, we can figure out the
+	      maximum value.  */
+	      bound_info = 0;
+	      high_bound = TYPE_LENGTH (type) * TARGET_CHAR_BIT - 1;
+	      TYPE_HIGH_BOUND (range) = high_bound;
+	    }
+	maybe_bad_bstring:
+	  if (bound_info < 0)
+	    {
+	      fputs_styled ("<error value>", metadata_style.style (), stream);
+	      goto done;
+	    }
+
+	  for (i = low_bound; i <= high_bound; i++)
+	    {
+	      int element = value_bit_index (type, valaddr, i);
+
+	      if (element < 0)
+		{
+		  i = element;
+		  goto maybe_bad_bstring;
+		}
+	      if (element)
+		{
+		  if (need_comma)
+		    fputs_filtered (", ", stream);
+		  print_type_scalar (range, i, stream);
+		  need_comma = 1;
+
+		  if (i + 1 <= high_bound
+		      && value_bit_index (type, valaddr, ++i))
+		    {
+		      int j = i;
+
+		      fputs_filtered ("..", stream);
+		      while (i + 1 <= high_bound
+			     && value_bit_index (type, valaddr, ++i))
+			j = i;
+		      print_type_scalar (range, j, stream);
+		    }
+		}
+	    }
+	done:
+	  fputs_filtered ("]", stream);
+	}
+      break;
+
+    default:
+      error (_("Invalid pascal type code %d in symbol table."),
+	     TYPE_CODE (type));
+    }
 }