From b50d69b5aa88f7d46a360d4d4a5b088f3370ad9d Mon Sep 17 00:00:00 2001
From: Jerome Guitton <guitton@adacore.com>
Date: Thu, 29 Nov 2012 16:28:10 +0000
Subject: 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.
---
 gdb/testsuite/gdb.ada/ptype_tagged_param.exp | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'gdb/testsuite/gdb.ada')

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"
 
-- 
cgit v1.1