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.

1 files changed, 6 insertions, 0 deletions

diff --git a/gdb/ada-valprint.c b/gdb/ada-valprint.c
index ca30e42c5d7..20bb12e0839 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),