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 *
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 *
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,
{
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);
}
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
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.
default:
*pos -= 1;
arg1 = evaluate_subexp_standard (expect_type, exp, pos, noside);
- arg1 = unwrap_value (arg1);
+
+ if (noside == EVAL_NORMAL)
+ arg1 = unwrap_value (arg1);
/* If evaluating an OP_DOUBLE and an EXPECT_TYPE was provided,
then we need to perform the conversion manually, because
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;
projects / deliverable / binutils-gdb.git / blobdiff