Full view of interface-wide types

For displaying the full view of a class-wide object, GDB relies on
the assumption that this view will have the same address as the
address of the object. In the case of simple inheritance, this
assumption is correct; the proper type is deduced by decoding
the tag of the object and converting the result to this full-view
type.

Consider for example an abstract class Shape, a child Circle
which implements an interface Drawable, and the corresponding
following objects:

   My_Circle   : Circle := ((1, 2), 3);
   My_Shape    : Shape'Class := Shape'Class (My_Circle);
   My_Drawable : Drawable'Class := Drawable'Class (My_Circle);

To display My_Shape, the debugger first extracts the tag (an internal
field, usually the first one of the record):

 (gdb) p my_shape'address
 $2 = (system.address) 0x8063e28
 (gdb) x/x my_shape'address
 0x8063e28 <classes__my_shape>: 0x08059ec4

Then the type specific data and the expanded name of the tag is read
from there:

 (gdb) p my_shape'tag
 $3 = (access ada.tags.dispatch_table) 0x8059ec4 (classes.circle)

To get the full view, the debugger converts to the corresponding type:

 (gdb) p {classes.circle}0x8063e28
 $4 = (center => (x => 1, y => 2), radius => 3)

Now, in the case of multiple inheritance, the assumption does not hold
anymore. The address that we have usually points to some
place lower. The offset to the original address is saved in the field
Offset_To_Top of the metadata that are above the tag, at address
obj'tag - 8. In the case of my_shape, this offset is 0:

 (gdb) x/x my_shape'tag - 8
 0x8059ebc <classes__circleT+12>:        0x00000000

...but in the case of an interface-wide object, it is not null:

 (gdb) x/x my_drawable'tag - 8
 0x8063b28 <classes__classes__circle_classes__drawable1T56s+12>: 0x00000004
 (gdb) p {classes.circle}(my_drawable'address - 4)
 $7 = (center => (x => 1, y => 2), radius => 3)

The following change handles this relocation in the most common cases.
Remaining cases that are still to be investigated are signaled by
comments.

gdb/ChangeLog:

	* ada-lang.h (ada_tag_value_at_base_address): New function
	declaration.
	* ada-lang.c (is_ada95_tag, ada_tag_value_at_base_address):
	New functions.
	(ada_to_fixed_type_1, ada_evaluate_subexp): Let ada_tag_base_address
	relocate the class-wide value if need be.
	(ada_value_struct_elt, ada_value_ind, ada_coerce_ref):
	Let ada_tag_value_at_base_address relocate the class-wide access/ref
	before dereferencing it.
	* ada-valprint.c (ada_val_print_1): Relocate to base address
	before displaying the content of an interface-wide ref.

gdb/testsuite/ChangeLog:

        * gdb.ada/ptype_tagged_param.exp: Adjust expected output in
        ptype test.

6 files changed, 165 insertions, 22 deletions

diff --git a/gdb/ChangeLog b/gdb/ChangeLog
index cd86c84..60d4dc3 100644
--- a/gdb/ChangeLog
+++ b/gdb/ChangeLog
@@ -1,5 +1,19 @@
 2012-11-29  Jerome Guitton  <guitton@adacore.com>
 
+        * ada-lang.h (ada_tag_value_at_base_address): New function
+	declaration.
+	* ada-lang.c (is_ada95_tag, ada_tag_value_at_base_address):
+	New functions.
+	(ada_to_fixed_type_1, ada_evaluate_subexp): Let ada_tag_base_address
+	relocate the class-wide value if need be.
+	(ada_value_struct_elt, ada_value_ind, ada_coerce_ref):
+	Let ada_tag_value_at_base_address relocate the class-wide access/ref
+	before dereferencing it.
+	* ada-valprint.c (ada_val_print_1): Relocate to base address
+	before displaying the content of an interface-wide ref.
+
+2012-11-29  Jerome Guitton  <guitton@adacore.com>
+
 	* ada-lang.c (ada_evaluate_subexp): Unwrap only in EVAL_NORMAL.
 
 2012-11-29  Joel Brobecker  <brobecker@adacore.com>
diff --git a/gdb/ada-lang.c b/gdb/ada-lang.c
index ee2f765..a34ba29 100644
--- a/gdb/ada-lang.c
+++ b/gdb/ada-lang.c
@@ -6009,6 +6009,15 @@ ada_tag_type (struct value *val)
   return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0, NULL);
 }
 
+/* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95,
+   retired at Ada 05).  */
+
+static int
+is_ada95_tag (struct value *tag)
+{
+  return ada_value_struct_elt (tag, "tsd", 1) != NULL;
+}
+
 /* The value of the tag on VAL.  */
 
 struct value *
@@ -6052,6 +6061,88 @@ type_from_tag (struct value *tag)
   return NULL;
 }
 
+/* Given a value OBJ of a tagged type, return a value of this
+   type at the base address of the object.  The base address, as
+   defined in Ada.Tags, it is the address of the primary tag of
+   the object, and therefore where the field values of its full
+   view can be fetched.  */
+
+struct value *
+ada_tag_value_at_base_address (struct value *obj)
+{
+  volatile struct gdb_exception e;
+  struct value *val;
+  LONGEST offset_to_top = 0;
+  struct type *ptr_type, *obj_type;
+  struct value *tag;
+  CORE_ADDR base_address;
+
+  obj_type = value_type (obj);
+
+  /* It is the responsability of the caller to deref pointers.  */
+
+  if (TYPE_CODE (obj_type) == TYPE_CODE_PTR
+      || TYPE_CODE (obj_type) == TYPE_CODE_REF)
+    return obj;
+
+  tag = ada_value_tag (obj);
+  if (!tag)
+    return obj;
+
+  /* Base addresses only appeared with Ada 05 and multiple inheritance.  */
+
+  if (is_ada95_tag (tag))
+    return obj;
+
+  ptr_type = builtin_type (target_gdbarch ())->builtin_data_ptr;
+  ptr_type = lookup_pointer_type (ptr_type);
+  val = value_cast (ptr_type, tag);
+  if (!val)
+    return obj;
+
+  /* It is perfectly possible that an exception be raised while
+     trying to determine the base address, just like for the tag;
+     see ada_tag_name for more details.  We do not print the error
+     message for the same reason.  */
+
+  TRY_CATCH (e, RETURN_MASK_ERROR)
+    {
+      offset_to_top = value_as_long (value_ind (value_ptradd (val, -2)));
+    }
+
+  if (e.reason < 0)
+    return obj;
+
+  /* If offset is null, nothing to do.  */
+
+  if (offset_to_top == 0)
+    return obj;
+
+  /* -1 is a special case in Ada.Tags; however, what should be done
+     is not quite clear from the documentation.  So do nothing for
+     now.  */
+
+  if (offset_to_top == -1)
+    return obj;
+
+  base_address = value_address (obj) - offset_to_top;
+  tag = value_tag_from_contents_and_address (obj_type, NULL, base_address);
+
+  /* Make sure that we have a proper tag at the new address.
+     Otherwise, offset_to_top is bogus (which can happen when
+     the object is not initialized yet).  */
+
+  if (!tag)
+    return obj;
+
+  obj_type = type_from_tag (tag);
+
+  if (!obj_type)
+    return obj;
+
+  return value_from_contents_and_address (obj_type, NULL, base_address);
+}
+
 /* Return the "ada__tags__type_specific_data" type.  */
 
 static struct type *
@@ -6707,9 +6798,9 @@ ada_value_struct_elt (struct value *arg, char *name, int no_err)
       CORE_ADDR address;
 
       if (TYPE_CODE (t) == TYPE_CODE_PTR)
-        address = value_as_address (arg);
+	address = value_address (ada_value_ind (arg));
       else
-        address = unpack_pointer (t, value_contents (arg));
+	address = value_address (ada_coerce_ref (arg));
 
       t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL, address, NULL, 1);
       if (find_struct_field (name, t1, 0,
@@ -6985,6 +7076,9 @@ ada_value_ind (struct value *val0)
 {
   struct value *val = value_ind (val0);
 
+  if (ada_is_tagged_type (value_type (val), 0))
+    val = ada_tag_value_at_base_address (val);
+
   return ada_to_fixed_value (val);
 }
 
@@ -6999,6 +7093,10 @@ ada_coerce_ref (struct value *val0)
       struct value *val = val0;
 
       val = coerce_ref (val);
+
+      if (ada_is_tagged_type (value_type (val), 0))
+	val = ada_tag_value_at_base_address (val);
+
       return ada_to_fixed_value (val);
     }
   else
@@ -7982,14 +8080,20 @@ ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr,
 
         if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0))
           {
-            struct type *real_type =
-              type_from_tag (value_tag_from_contents_and_address
-                             (fixed_record_type,
-                              valaddr,
-                              address));
-
+	    struct value *tag =
+	      value_tag_from_contents_and_address
+	      (fixed_record_type,
+	       valaddr,
+	       address);
+	    struct type *real_type = type_from_tag (tag);
+	    struct value *obj =
+	      value_from_contents_and_address (fixed_record_type,
+					       valaddr,
+					       address);
             if (real_type != NULL)
-              return to_fixed_record_type (real_type, valaddr, address, NULL);
+              return to_fixed_record_type
+		(real_type, NULL,
+		 value_address (ada_tag_value_at_base_address (obj)), NULL);
           }
 
         /* Check to see if there is a parallel ___XVZ variable.
@@ -9692,19 +9796,31 @@ ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
                a fixed type would result in the loss of that type name,
                thus preventing us from printing the name of the ancestor
                type in the type description.  */
-            struct type *actual_type;
-
             arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_NORMAL);
-            actual_type = type_from_tag (ada_value_tag (arg1));
-            if (actual_type == NULL)
-              /* If, for some reason, we were unable to determine
-                 the actual type from the tag, then use the static
-                 approximation that we just computed as a fallback.
-                 This can happen if the debugging information is
-                 incomplete, for instance.  */
-              actual_type = type;
-
-            return value_zero (actual_type, not_lval);
+
+	    if (TYPE_CODE (type) != TYPE_CODE_REF)
+	      {
+		struct type *actual_type;
+
+		actual_type = type_from_tag (ada_value_tag (arg1));
+		if (actual_type == NULL)
+		  /* If, for some reason, we were unable to determine
+		     the actual type from the tag, then use the static
+		     approximation that we just computed as a fallback.
+		     This can happen if the debugging information is
+		     incomplete, for instance.  */
+		  actual_type = type;
+		return value_zero (actual_type, not_lval);
+	      }
+	    else
+	      {
+		/* In the case of a ref, ada_coerce_ref takes care
+		   of determining the actual type.  But the evaluation
+		   should return a ref as it should be valid to ask
+		   for its address; so rebuild a ref after coerce.  */
+		arg1 = ada_coerce_ref (arg1);
+		return value_ref (arg1);
+	      }
           }
 
           *pos += 4;
diff --git a/gdb/ada-lang.h b/gdb/ada-lang.h
index fa6934b..f6154fd 100644
--- a/gdb/ada-lang.h
+++ b/gdb/ada-lang.h
@@ -278,6 +278,8 @@ extern struct value *ada_value_tag (struct value *);
 
 extern const char *ada_tag_name (struct value *);
 
+extern struct value *ada_tag_value_at_base_address (struct value *obj);
+
 extern int ada_is_parent_field (struct type *, int);
 
 extern int ada_is_wrapper_field (struct type *, int);
diff --git a/gdb/ada-valprint.c b/gdb/ada-valprint.c
index ca30e42..20bb12e 100644
--- a/gdb/ada-valprint.c
+++ b/gdb/ada-valprint.c
@@ -891,6 +891,9 @@ ada_val_print_1 (struct type *type, const gdb_byte *valaddr,
 	  deref_val = coerce_ref_if_computed (original_value);
 	  if (deref_val)
 	    {
+	      if (ada_is_tagged_type (value_type (deref_val), 1))
+		deref_val = ada_tag_value_at_base_address (deref_val);
+
 	      common_val_print (deref_val, stream, recurse + 1, options,
 				current_language);
 	      break;
@@ -904,6 +907,9 @@ ada_val_print_1 (struct type *type, const gdb_byte *valaddr,
                                (lookup_pointer_type (elttype),
                                 deref_val_int));
 
+	      if (ada_is_tagged_type (value_type (deref_val), 1))
+		deref_val = ada_tag_value_at_base_address (deref_val);
+
               val_print (value_type (deref_val),
                          value_contents_for_printing (deref_val),
                          value_embedded_offset (deref_val),
diff --git a/gdb/testsuite/ChangeLog b/gdb/testsuite/ChangeLog
index c831c01..7c79f60 100644
--- a/gdb/testsuite/ChangeLog
+++ b/gdb/testsuite/ChangeLog
@@ -1,5 +1,10 @@
 2012-11-29  Jerome Guitton  <guitton@adacore.com>
 
+	* gdb.ada/ptype_tagged_param.exp: Adjust expected output in
+	ptype test.
+
+2012-11-29  Jerome Guitton  <guitton@adacore.com>
+
 	* gdb.ada/variant_record_packed_array.exp: Test expressions of the
 	form {VARIANT_TYPE}ADDRESS.
 
diff --git a/gdb/testsuite/gdb.ada/ptype_tagged_param.exp b/gdb/testsuite/gdb.ada/ptype_tagged_param.exp
index e538b98..98ee548 100644
--- a/gdb/testsuite/gdb.ada/ptype_tagged_param.exp
+++ b/gdb/testsuite/gdb.ada/ptype_tagged_param.exp
@@ -31,6 +31,6 @@ set eol "\[\r\n\]+"
 set sp "\[ \t\]*"
 
 gdb_test "ptype s" \
-         "type = new pck.shape with record${eol}${sp}r: integer;${eol}end record" \
+         "type = <ref> new pck.shape with record${eol}${sp}r: integer;${eol}end record" \
          "ptype s"