diff options
Diffstat (limited to 'gdb')
| -rw-r--r-- | gdb/ChangeLog | 14 | ||||
| -rw-r--r-- | gdb/ada-lang.c | 158 | ||||
| -rw-r--r-- | gdb/ada-lang.h | 2 | ||||
| -rw-r--r-- | gdb/ada-valprint.c | 6 | ||||
| -rw-r--r-- | gdb/testsuite/ChangeLog | 5 | ||||
| -rw-r--r-- | gdb/testsuite/gdb.ada/ptype_tagged_param.exp | 2 |
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" |