This is the mail archive of the
gdb-patches@sources.redhat.com
mailing list for the GDB project.
[PATCH]: Updates to Ada sources, part 2b (long)
- From: Paul Hilfinger <hilfingr at gnat dot com>
- To: gdb-patches at sources dot redhat dot com
- Date: Wed, 2 Jun 2004 06:16:49 -0400 (EDT)
- Subject: [PATCH]: Updates to Ada sources, part 2b (long)
Index: gdb/ada-lang.c
===================================================================
RCS file: /cvs/src/src/gdb/ada-lang.c,v
retrieving revision 1.35
diff -u -p -r1.35 ada-lang.c
--- gdb/ada-lang.c 23 Jan 2004 23:03:28 -0000 1.35
+++ gdb/ada-lang.c 2 Jun 2004 09:52:56 -0000
@@ -6573,26 +8293,25 @@ ada_is_string_type (struct type *type)
/* True if TYPE is a struct type introduced by the compiler to force the
alignment of a value. Such types have a single field with a
- distinctive name. */
+ distinctive name. */
int
ada_is_aligner_type (struct type *type)
{
CHECK_TYPEDEF (type);
return (TYPE_CODE (type) == TYPE_CODE_STRUCT
- && TYPE_NFIELDS (type) == 1
- && DEPRECATED_STREQ (TYPE_FIELD_NAME (type, 0), "F"));
+ && TYPE_NFIELDS (type) == 1
+ && strcmp (TYPE_FIELD_NAME (type, 0), "F") == 0);
}
/* If there is an ___XVS-convention type parallel to SUBTYPE, return
- the parallel type. */
+ the parallel type. */
struct type *
ada_get_base_type (struct type *raw_type)
{
struct type *real_type_namer;
struct type *raw_real_type;
- struct type *real_type;
if (raw_type == NULL || TYPE_CODE (raw_type) != TYPE_CODE_STRUCT)
return raw_type;
@@ -6610,7 +8329,7 @@ ada_get_base_type (struct type *raw_type
return raw_real_type;
}
-/* The type of value designated by TYPE, with all aligners removed. */
+/* The type of value designated by TYPE, with all aligners removed. */
struct type *
ada_aligned_type (struct type *type)
@@ -6623,82 +8342,110 @@ ada_aligned_type (struct type *type)
/* The address of the aligned value in an object at address VALADDR
- having type TYPE. Assumes ada_is_aligner_type (TYPE). */
+ having type TYPE. Assumes ada_is_aligner_type (TYPE). */
char *
ada_aligned_value_addr (struct type *type, char *valaddr)
{
if (ada_is_aligner_type (type))
return ada_aligned_value_addr (TYPE_FIELD_TYPE (type, 0),
- valaddr +
- TYPE_FIELD_BITPOS (type,
- 0) / TARGET_CHAR_BIT);
+ valaddr +
+ TYPE_FIELD_BITPOS (type,
+ 0) / TARGET_CHAR_BIT);
else
return valaddr;
}
+
+
/* The printed representation of an enumeration literal with encoded
- name NAME. The value is good to the next call of ada_enum_name. */
+ name NAME. The value is good to the next call of ada_enum_name. */
const char *
ada_enum_name (const char *name)
{
+ static char *result;
+ static size_t result_len = 0;
char *tmp;
- while (1)
- {
- if ((tmp = strstr (name, "__")) != NULL)
- name = tmp + 2;
- else if ((tmp = strchr (name, '.')) != NULL)
- name = tmp + 1;
- else
- break;
+ /* First, unqualify the enumeration name:
+ 1. Search for the last '.' character. If we find one, then skip
+ all the preceeding characters, the unqualified name starts
+ right after that dot.
+ 2. Otherwise, we may be debugging on a target where the compiler
+ translates dots into "__". Search forward for double underscores,
+ but stop searching when we hit an overloading suffix, which is
+ of the form "__" followed by digits. */
+
+ if ((tmp = strrchr (name, '.')) != NULL)
+ name = tmp + 1;
+ else
+ {
+ while ((tmp = strstr (name, "__")) != NULL)
+ {
+ if (isdigit (tmp[2]))
+ break;
+ else
+ name = tmp + 2;
+ }
}
if (name[0] == 'Q')
{
- static char result[16];
int v;
if (name[1] == 'U' || name[1] == 'W')
- {
- if (sscanf (name + 2, "%x", &v) != 1)
- return name;
- }
+ {
+ if (sscanf (name + 2, "%x", &v) != 1)
+ return name;
+ }
else
- return name;
+ return name;
+ GROW_VECT (result, result_len, 16);
if (isascii (v) && isprint (v))
- sprintf (result, "'%c'", v);
+ sprintf (result, "'%c'", v);
else if (name[1] == 'U')
- sprintf (result, "[\"%02x\"]", v);
+ sprintf (result, "[\"%02x\"]", v);
else
- sprintf (result, "[\"%04x\"]", v);
+ sprintf (result, "[\"%04x\"]", v);
return result;
}
else
- return name;
+ {
+ if ((tmp = strstr (name, "__")) != NULL
+ || (tmp = strstr (name, "$")) != NULL)
+ {
+ GROW_VECT (result, result_len, tmp - name + 1);
+ strncpy (result, name, tmp - name);
+ result[tmp - name] = '\0';
+ return result;
+ }
+
+ return name;
+ }
}
static struct value *
evaluate_subexp (struct type *expect_type, struct expression *exp, int *pos,
- enum noside noside)
+ enum noside noside)
{
- return (*exp->language_defn->evaluate_exp) (expect_type, exp, pos, noside);
+ return (*exp->language_defn->la_exp_desc->evaluate_exp)
+ (expect_type, exp, pos, noside);
}
/* Evaluate the subexpression of EXP starting at *POS as for
evaluate_type, updating *POS to point just past the evaluated
- expression. */
+ expression. */
static struct value *
evaluate_subexp_type (struct expression *exp, int *pos)
{
- return (*exp->language_defn->evaluate_exp)
+ return (*exp->language_defn->la_exp_desc->evaluate_exp)
(NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
}
/* If VAL is wrapped in an aligner or subtype wrapper, return the
- value it wraps. */
+ value it wraps. */
static struct value *
unwrap_value (struct value *val)
@@ -6707,26 +8454,26 @@ unwrap_value (struct value *val)
if (ada_is_aligner_type (type))
{
struct value *v = value_struct_elt (&val, NULL, "F",
- NULL, "internal structure");
+ NULL, "internal structure");
struct type *val_type = check_typedef (VALUE_TYPE (v));
if (ada_type_name (val_type) == NULL)
- TYPE_NAME (val_type) = ada_type_name (type);
+ TYPE_NAME (val_type) = ada_type_name (type);
return unwrap_value (v);
}
else
{
struct type *raw_real_type =
- ada_completed_type (ada_get_base_type (type));
+ ada_completed_type (ada_get_base_type (type));
if (type == raw_real_type)
- return val;
+ return val;
return
- coerce_unspec_val_to_type
- (val, 0, ada_to_fixed_type (raw_real_type, 0,
- VALUE_ADDRESS (val) + VALUE_OFFSET (val),
- NULL));
+ coerce_unspec_val_to_type
+ (val, ada_to_fixed_type (raw_real_type, 0,
+ VALUE_ADDRESS (val) + VALUE_OFFSET (val),
+ NULL));
}
}
@@ -6739,12 +8486,12 @@ cast_to_fixed (struct type *type, struct
return arg;
else if (ada_is_fixed_point_type (VALUE_TYPE (arg)))
val = ada_float_to_fixed (type,
- ada_fixed_to_float (VALUE_TYPE (arg),
- value_as_long (arg)));
+ ada_fixed_to_float (VALUE_TYPE (arg),
+ value_as_long (arg)));
else
{
DOUBLEST argd =
- value_as_double (value_cast (builtin_type_double, value_copy (arg)));
+ value_as_double (value_cast (builtin_type_double, value_copy (arg)));
val = ada_float_to_fixed (type, argd);
}
@@ -6755,12 +8502,13 @@ static struct value *
cast_from_fixed_to_double (struct value *arg)
{
DOUBLEST val = ada_fixed_to_float (VALUE_TYPE (arg),
- value_as_long (arg));
+ value_as_long (arg));
return value_from_double (builtin_type_double, val);
}
-/* Coerce VAL as necessary for assignment to an lval of type TYPE, and
- * return the converted value. */
+/* Coerce VAL as necessary for assignment to an lval of type TYPE, and
+ return the converted value. */
+
static struct value *
coerce_for_assign (struct type *type, struct value *val)
{
@@ -6782,20 +8530,98 @@ coerce_for_assign (struct type *type, st
&& TYPE_CODE (type) == TYPE_CODE_ARRAY)
{
if (TYPE_LENGTH (type2) != TYPE_LENGTH (type)
- || TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
- != TYPE_LENGTH (TYPE_TARGET_TYPE (type2)))
- error ("Incompatible types in assignment");
+ || TYPE_LENGTH (TYPE_TARGET_TYPE (type2))
+ != TYPE_LENGTH (TYPE_TARGET_TYPE (type2)))
+ error ("Incompatible types in assignment");
VALUE_TYPE (val) = type;
}
return val;
}
+static struct value *
+ada_value_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
+{
+ struct value *val;
+ struct type *type1, *type2;
+ LONGEST v, v1, v2;
+
+ COERCE_REF (arg1);
+ COERCE_REF (arg2);
+ type1 = base_type (check_typedef (VALUE_TYPE (arg1)));
+ type2 = base_type (check_typedef (VALUE_TYPE (arg2)));
+
+ if (TYPE_CODE (type1) != TYPE_CODE_INT || TYPE_CODE (type2) != TYPE_CODE_INT)
+ return value_binop (arg1, arg2, op);
+
+ switch (op)
+ {
+ case BINOP_MOD:
+ case BINOP_DIV:
+ case BINOP_REM:
+ break;
+ default:
+ return value_binop (arg1, arg2, op);
+ }
+
+ v2 = value_as_long (arg2);
+ if (v2 == 0)
+ error ("second operand of %s must not be zero.", op_string (op));
+
+ if (TYPE_UNSIGNED (type1) || op == BINOP_MOD)
+ return value_binop (arg1, arg2, op);
+
+ v1 = value_as_long (arg1);
+ switch (op)
+ {
+ case BINOP_DIV:
+ v = v1 / v2;
+ if (! TRUNCATION_TOWARDS_ZERO && v1 * (v1%v2) < 0)
+ v += v > 0 ? -1 : 1;
+ break;
+ case BINOP_REM:
+ v = v1 % v2;
+ if (v*v1 < 0)
+ v -= v2;
+ break;
+ default:
+ /* Should not reach this point. */
+ v = 0;
+ }
+
+ val = allocate_value (type1);
+ store_unsigned_integer (VALUE_CONTENTS_RAW (val),
+ TYPE_LENGTH (VALUE_TYPE (val)),
+ v);
+ return val;
+}
+
+static int
+ada_value_equal (struct value *arg1, struct value *arg2)
+{
+ if (ada_is_direct_array_type (VALUE_TYPE (arg1))
+ || ada_is_direct_array_type (VALUE_TYPE (arg2)))
+ {
+ arg1 = ada_coerce_to_simple_array (arg1);
+ arg2 = ada_coerce_to_simple_array (arg2);
+ if (TYPE_CODE (VALUE_TYPE (arg1)) != TYPE_CODE_ARRAY
+ || TYPE_CODE (VALUE_TYPE (arg2)) != TYPE_CODE_ARRAY)
+ error ("Attempt to compare array with non-array");
+ /* FIXME: The following works only for types whose
+ representations use all bits (no padding or undefined bits)
+ and do not have user-defined equality. */
+ return
+ TYPE_LENGTH (VALUE_TYPE (arg1)) == TYPE_LENGTH (VALUE_TYPE (arg2))
+ && memcmp (VALUE_CONTENTS (arg1), VALUE_CONTENTS (arg2),
+ TYPE_LENGTH (VALUE_TYPE (arg1))) == 0;
+ }
+ return value_equal (arg1, arg2);
+}
+
struct value *
ada_evaluate_subexp (struct type *expect_type, struct expression *exp,
- int *pos, enum noside noside)
+ int *pos, enum noside noside)
{
enum exp_opcode op;
- enum ada_attribute atr;
int tem, tem2, tem3;
int pc;
struct value *arg1 = NULL, *arg2 = NULL, *arg3;
@@ -6812,752 +8638,734 @@ ada_evaluate_subexp (struct type *expect
default:
*pos -= 1;
return
- unwrap_value (evaluate_subexp_standard
- (expect_type, exp, pos, noside));
+ unwrap_value (evaluate_subexp_standard
+ (expect_type, exp, pos, noside));
+
+ case OP_STRING:
+ {
+ struct value *result;
+ *pos -= 1;
+ result = evaluate_subexp_standard (expect_type, exp, pos, noside);
+ /* The result type will have code OP_STRING, bashed there from
+ OP_ARRAY. Bash it back. */
+ if (TYPE_CODE (VALUE_TYPE (result)) == TYPE_CODE_STRING)
+ TYPE_CODE (VALUE_TYPE (result)) = TYPE_CODE_ARRAY;
+ return result;
+ }
case UNOP_CAST:
(*pos) += 2;
type = exp->elts[pc + 1].type;
arg1 = evaluate_subexp (type, exp, pos, noside);
if (noside == EVAL_SKIP)
- goto nosideret;
+ goto nosideret;
if (type != check_typedef (VALUE_TYPE (arg1)))
- {
- if (ada_is_fixed_point_type (type))
- arg1 = cast_to_fixed (type, arg1);
- else if (ada_is_fixed_point_type (VALUE_TYPE (arg1)))
- arg1 = value_cast (type, cast_from_fixed_to_double (arg1));
- else if (VALUE_LVAL (arg1) == lval_memory)
- {
- /* This is in case of the really obscure (and undocumented,
- but apparently expected) case of (Foo) Bar.all, where Bar
- is an integer constant and Foo is a dynamic-sized type.
- If we don't do this, ARG1 will simply be relabeled with
- TYPE. */
- if (noside == EVAL_AVOID_SIDE_EFFECTS)
- return value_zero (to_static_fixed_type (type), not_lval);
- arg1 =
- ada_to_fixed_value
- (type, 0, VALUE_ADDRESS (arg1) + VALUE_OFFSET (arg1), 0);
- }
- else
- arg1 = value_cast (type, arg1);
- }
+ {
+ if (ada_is_fixed_point_type (type))
+ arg1 = cast_to_fixed (type, arg1);
+ else if (ada_is_fixed_point_type (VALUE_TYPE (arg1)))
+ arg1 = value_cast (type, cast_from_fixed_to_double (arg1));
+ else if (VALUE_LVAL (arg1) == lval_memory)
+ {
+ /* This is in case of the really obscure (and undocumented,
+ but apparently expected) case of (Foo) Bar.all, where Bar
+ is an integer constant and Foo is a dynamic-sized type.
+ If we don't do this, ARG1 will simply be relabeled with
+ TYPE. */
+ if (noside == EVAL_AVOID_SIDE_EFFECTS)
+ return value_zero (to_static_fixed_type (type), not_lval);
+ arg1 =
+ ada_to_fixed_value_create
+ (type, VALUE_ADDRESS (arg1) + VALUE_OFFSET (arg1), 0);
+ }
+ else
+ arg1 = value_cast (type, arg1);
+ }
return arg1;
- /* FIXME: UNOP_QUAL should be defined in expression.h */
- /* case UNOP_QUAL:
- (*pos) += 2;
- type = exp->elts[pc + 1].type;
- return ada_evaluate_subexp (type, exp, pos, noside);
- */
+ case UNOP_QUAL:
+ (*pos) += 2;
+ type = exp->elts[pc + 1].type;
+ return ada_evaluate_subexp (type, exp, pos, noside);
+
case BINOP_ASSIGN:
arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
arg2 = evaluate_subexp (VALUE_TYPE (arg1), exp, pos, noside);
if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
- return arg1;
- if (binop_user_defined_p (op, arg1, arg2))
- return value_x_binop (arg1, arg2, op, OP_NULL, EVAL_NORMAL);
+ return arg1;
+ if (ada_is_fixed_point_type (VALUE_TYPE (arg1)))
+ arg2 = cast_to_fixed (VALUE_TYPE (arg1), arg2);
+ else if (ada_is_fixed_point_type (VALUE_TYPE (arg2)))
+ error
+ ("Fixed-point values must be assigned to fixed-point variables");
else
- {
- if (ada_is_fixed_point_type (VALUE_TYPE (arg1)))
- arg2 = cast_to_fixed (VALUE_TYPE (arg1), arg2);
- else if (ada_is_fixed_point_type (VALUE_TYPE (arg2)))
- error
- ("Fixed-point values must be assigned to fixed-point variables");
- else
- arg2 = coerce_for_assign (VALUE_TYPE (arg1), arg2);
- return ada_value_assign (arg1, arg2);
- }
+ arg2 = coerce_for_assign (VALUE_TYPE (arg1), arg2);
+ return ada_value_assign (arg1, arg2);
case BINOP_ADD:
arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
if (noside == EVAL_SKIP)
- goto nosideret;
- if (binop_user_defined_p (op, arg1, arg2))
- return value_x_binop (arg1, arg2, op, OP_NULL, EVAL_NORMAL);
- else
- {
- if ((ada_is_fixed_point_type (VALUE_TYPE (arg1))
- || ada_is_fixed_point_type (VALUE_TYPE (arg2)))
- && VALUE_TYPE (arg1) != VALUE_TYPE (arg2))
- error
- ("Operands of fixed-point addition must have the same type");
- return value_cast (VALUE_TYPE (arg1), value_add (arg1, arg2));
- }
+ goto nosideret;
+ if ((ada_is_fixed_point_type (VALUE_TYPE (arg1))
+ || ada_is_fixed_point_type (VALUE_TYPE (arg2)))
+ && VALUE_TYPE (arg1) != VALUE_TYPE (arg2))
+ error
+ ("Operands of fixed-point addition must have the same type");
+ return value_cast (VALUE_TYPE (arg1), value_add (arg1, arg2));
case BINOP_SUB:
arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
if (noside == EVAL_SKIP)
- goto nosideret;
- if (binop_user_defined_p (op, arg1, arg2))
- return value_x_binop (arg1, arg2, op, OP_NULL, EVAL_NORMAL);
- else
- {
- if ((ada_is_fixed_point_type (VALUE_TYPE (arg1))
- || ada_is_fixed_point_type (VALUE_TYPE (arg2)))
- && VALUE_TYPE (arg1) != VALUE_TYPE (arg2))
- error
- ("Operands of fixed-point subtraction must have the same type");
- return value_cast (VALUE_TYPE (arg1), value_sub (arg1, arg2));
- }
+ goto nosideret;
+ if ((ada_is_fixed_point_type (VALUE_TYPE (arg1))
+ || ada_is_fixed_point_type (VALUE_TYPE (arg2)))
+ && VALUE_TYPE (arg1) != VALUE_TYPE (arg2))
+ error
+ ("Operands of fixed-point subtraction must have the same type");
+ return value_cast (VALUE_TYPE (arg1), value_sub (arg1, arg2));
case BINOP_MUL:
case BINOP_DIV:
arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
if (noside == EVAL_SKIP)
+ goto nosideret;
+ else if (noside == EVAL_AVOID_SIDE_EFFECTS
+ && (op == BINOP_DIV || op == BINOP_REM || op == BINOP_MOD))
+ return value_zero (VALUE_TYPE (arg1), not_lval);
+ else
+ {
+ if (ada_is_fixed_point_type (VALUE_TYPE (arg1)))
+ arg1 = cast_from_fixed_to_double (arg1);
+ if (ada_is_fixed_point_type (VALUE_TYPE (arg2)))
+ arg2 = cast_from_fixed_to_double (arg2);
+ return ada_value_binop (arg1, arg2, op);
+ }
+
+ case BINOP_REM:
+ case BINOP_MOD:
+ arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
+ arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
+ if (noside == EVAL_SKIP)
goto nosideret;
- if (binop_user_defined_p (op, arg1, arg2))
- return value_x_binop (arg1, arg2, op, OP_NULL, EVAL_NORMAL);
- else
- if (noside == EVAL_AVOID_SIDE_EFFECTS
- && (op == BINOP_DIV || op == BINOP_REM || op == BINOP_MOD))
+ else if (noside == EVAL_AVOID_SIDE_EFFECTS
+ && (op == BINOP_DIV || op == BINOP_REM || op == BINOP_MOD))
return value_zero (VALUE_TYPE (arg1), not_lval);
else
- {
- if (ada_is_fixed_point_type (VALUE_TYPE (arg1)))
- arg1 = cast_from_fixed_to_double (arg1);
- if (ada_is_fixed_point_type (VALUE_TYPE (arg2)))
- arg2 = cast_from_fixed_to_double (arg2);
- return value_binop (arg1, arg2, op);
- }
+ return ada_value_binop (arg1, arg2, op);
- case UNOP_NEG:
+ case BINOP_EQUAL:
+ case BINOP_NOTEQUAL:
arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
+ arg2 = evaluate_subexp (VALUE_TYPE (arg1), exp, pos, noside);
if (noside == EVAL_SKIP)
goto nosideret;
- if (unop_user_defined_p (op, arg1))
- return value_x_unop (arg1, op, EVAL_NORMAL);
+ if (noside == EVAL_AVOID_SIDE_EFFECTS)
+ tem = 0;
+ else
+ tem = ada_value_equal (arg1, arg2);
+ if (op == BINOP_NOTEQUAL)
+ tem = ! tem;
+ return value_from_longest (LA_BOOL_TYPE, (LONGEST) tem);
+
+ case UNOP_NEG:
+ arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
+ if (noside == EVAL_SKIP)
+ goto nosideret;
else if (ada_is_fixed_point_type (VALUE_TYPE (arg1)))
- return value_cast (VALUE_TYPE (arg1), value_neg (arg1));
+ return value_cast (VALUE_TYPE (arg1), value_neg (arg1));
else
- return value_neg (arg1);
+ return value_neg (arg1);
- /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
- /* case OP_UNRESOLVED_VALUE:
- /* Only encountered when an unresolved symbol occurs in a
- context other than a function call, in which case, it is
- illegal. *//*
- (*pos) += 3;
- if (noside == EVAL_SKIP)
- goto nosideret;
- else
- error ("Unexpected unresolved symbol, %s, during evaluation",
- ada_demangle (exp->elts[pc + 2].name));
- */
case OP_VAR_VALUE:
*pos -= 1;
if (noside == EVAL_SKIP)
- {
- *pos += 4;
- goto nosideret;
- }
+ {
+ *pos += 4;
+ goto nosideret;
+ }
+ else if (SYMBOL_DOMAIN (exp->elts[pc + 2].symbol) == UNDEF_DOMAIN)
+ /* Only encountered when an unresolved symbol occurs in a
+ context other than a function call, in which case, it is
+ illegal. */
+ error ("Unexpected unresolved symbol, %s, during evaluation",
+ SYMBOL_PRINT_NAME (exp->elts[pc + 2].symbol));
else if (noside == EVAL_AVOID_SIDE_EFFECTS)
- {
- *pos += 4;
- return value_zero
- (to_static_fixed_type
- (static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol))),
- not_lval);
- }
- else
- {
- arg1 =
- unwrap_value (evaluate_subexp_standard
- (expect_type, exp, pos, noside));
- return ada_to_fixed_value (VALUE_TYPE (arg1), 0,
- VALUE_ADDRESS (arg1) +
- VALUE_OFFSET (arg1), arg1);
- }
+ {
+ *pos += 4;
+ return value_zero
+ (to_static_fixed_type
+ (static_unwrap_type (SYMBOL_TYPE (exp->elts[pc + 2].symbol))),
+ not_lval);
+ }
+ else
+ {
+ arg1 =
+ unwrap_value (evaluate_subexp_standard
+ (expect_type, exp, pos, noside));
+ return ada_to_fixed_value (arg1);
+ }
+
+ case OP_FUNCALL:
+ (*pos) += 2;
+
+ /* Allocate arg vector, including space for the function to be
+ called in argvec[0] and a terminating NULL. */
+ nargs = longest_to_int (exp->elts[pc + 1].longconst);
+ argvec =
+ (struct value **) alloca (sizeof (struct value *) * (nargs + 2));
+
+ if (exp->elts[*pos].opcode == OP_VAR_VALUE
+ && SYMBOL_DOMAIN (exp->elts[pc + 5].symbol) == UNDEF_DOMAIN)
+ error ("Unexpected unresolved symbol, %s, during evaluation",
+ SYMBOL_PRINT_NAME (exp->elts[pc + 5].symbol));
+ else
+ {
+ for (tem = 0; tem <= nargs; tem += 1)
+ argvec[tem] = evaluate_subexp (NULL_TYPE, exp, pos, noside);
+ argvec[tem] = 0;
+
+ if (noside == EVAL_SKIP)
+ goto nosideret;
+ }
+
+ if (ada_is_packed_array_type (desc_base_type (VALUE_TYPE (argvec[0]))))
+ argvec[0] = ada_coerce_to_simple_array (argvec[0]);
+ else if (TYPE_CODE (VALUE_TYPE (argvec[0])) == TYPE_CODE_REF
+ || (TYPE_CODE (VALUE_TYPE (argvec[0])) == TYPE_CODE_ARRAY
+ && VALUE_LVAL (argvec[0]) == lval_memory))
+ argvec[0] = value_addr (argvec[0]);
+
+ type = check_typedef (VALUE_TYPE (argvec[0]));
+ if (TYPE_CODE (type) == TYPE_CODE_PTR)
+ {
+ switch (TYPE_CODE (check_typedef (TYPE_TARGET_TYPE (type))))
+ {
+ case TYPE_CODE_FUNC:
+ type = check_typedef (TYPE_TARGET_TYPE (type));
+ break;
+ case TYPE_CODE_ARRAY:
+ break;
+ case TYPE_CODE_STRUCT:
+ if (noside != EVAL_AVOID_SIDE_EFFECTS)
+ argvec[0] = ada_value_ind (argvec[0]);
+ type = check_typedef (TYPE_TARGET_TYPE (type));
+ break;
+ default:
+ error ("cannot subscript or call something of type `%s'",
+ ada_type_name (VALUE_TYPE (argvec[0])));
+ break;
+ }
+ }
+
+ switch (TYPE_CODE (type))
+ {
+ case TYPE_CODE_FUNC:
+ if (noside == EVAL_AVOID_SIDE_EFFECTS)
+ return allocate_value (TYPE_TARGET_TYPE (type));
+ return call_function_by_hand (argvec[0], nargs, argvec + 1);
+ case TYPE_CODE_STRUCT:
+ {
+ int arity;
+
+ /* Make sure to use the parallel ___XVS type if any.
+ Otherwise, we won't be able to find the array arity
+ and element type. */
+ type = ada_get_base_type (type);
+
+ arity = ada_array_arity (type);
+ type = ada_array_element_type (type, nargs);
+ if (type == NULL)
+ error ("cannot subscript or call a record");
+ if (arity != nargs)
+ error ("wrong number of subscripts; expecting %d", arity);
+ if (noside == EVAL_AVOID_SIDE_EFFECTS)
+ return allocate_value (ada_aligned_type (type));
+ return
+ unwrap_value (ada_value_subscript
+ (argvec[0], nargs, argvec + 1));
+ }
+ case TYPE_CODE_ARRAY:
+ if (noside == EVAL_AVOID_SIDE_EFFECTS)
+ {
+ type = ada_array_element_type (type, nargs);
+ if (type == NULL)
+ error ("element type of array unknown");
+ else
+ return allocate_value (ada_aligned_type (type));
+ }
+ return
+ unwrap_value (ada_value_subscript
+ (ada_coerce_to_simple_array (argvec[0]),
+ nargs, argvec + 1));
+ case TYPE_CODE_PTR: /* Pointer to array */
+ type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
+ if (noside == EVAL_AVOID_SIDE_EFFECTS)
+ {
+ type = ada_array_element_type (type, nargs);
+ if (type == NULL)
+ error ("element type of array unknown");
+ else
+ return allocate_value (ada_aligned_type (type));
+ }
+ return
+ unwrap_value (ada_value_ptr_subscript (argvec[0], type,
+ nargs, argvec + 1));
+
+ default:
+ error ("Internal error in evaluate_subexp");
+ }
+
+ case TERNOP_SLICE:
+ {
+ struct value *array = evaluate_subexp (NULL_TYPE, exp, pos, noside);
+ struct value *low_bound_val =
+ evaluate_subexp (NULL_TYPE, exp, pos, noside);
+ LONGEST low_bound = pos_atr (low_bound_val);
+ LONGEST high_bound
+ = pos_atr (evaluate_subexp (NULL_TYPE, exp, pos, noside));
+ if (noside == EVAL_SKIP)
+ goto nosideret;
+
+ /* If this is a reference type or a pointer type, and
+ the target type has an XVS parallel type, then get
+ the real target type. */
+ if (TYPE_CODE (VALUE_TYPE (array)) == TYPE_CODE_REF
+ || TYPE_CODE (VALUE_TYPE (array)) == TYPE_CODE_PTR)
+ TYPE_TARGET_TYPE (VALUE_TYPE (array)) =
+ ada_get_base_type (TYPE_TARGET_TYPE (VALUE_TYPE (array)));
+
+ /* If this is a reference to an aligner type, then remove all
+ the aligners. */
+ if (TYPE_CODE (VALUE_TYPE (array)) == TYPE_CODE_REF
+ && ada_is_aligner_type (TYPE_TARGET_TYPE (VALUE_TYPE (array))))
+ TYPE_TARGET_TYPE (VALUE_TYPE (array)) =
+ ada_aligned_type (TYPE_TARGET_TYPE (VALUE_TYPE (array)));
+
+ if (ada_is_packed_array_type (VALUE_TYPE (array)))
+ error ("cannot slice a packed array");
+
+ /* If this is a reference to an array or an array lvalue,
+ convert to a pointer. */
+ if (TYPE_CODE (VALUE_TYPE (array)) == TYPE_CODE_REF
+ || (TYPE_CODE (VALUE_TYPE (array)) == TYPE_CODE_ARRAY
+ && VALUE_LVAL (array) == lval_memory))
+ array = value_addr (array);
+
+ if (noside == EVAL_AVOID_SIDE_EFFECTS &&
+ ada_is_array_descriptor_type (check_typedef (VALUE_TYPE (array))))
+ {
+ /* Try dereferencing the array, in case it is an access
+ to array. */
+ struct type *arrType = ada_type_of_array (array, 0);
+ if (arrType != NULL)
+ array = value_at_lazy (arrType, 0, NULL);
+ }
+
+ array = ada_coerce_to_simple_array_ptr (array);
+
+ /* When EVAL_AVOID_SIDE_EFFECTS, we may get the bounds wrong,
+ but only in contexts where the value is not being requested
+ (FIXME?). */
+ if (TYPE_CODE (VALUE_TYPE (array)) == TYPE_CODE_PTR)
+ {
+ if (noside == EVAL_AVOID_SIDE_EFFECTS)
+ return ada_value_ind (array);
+ else if (high_bound < low_bound)
+ return empty_array (TYPE_TARGET_TYPE (VALUE_TYPE (array)),
+ low_bound);
+ else
+ {
+ struct type *arr_type0 =
+ to_fixed_array_type (TYPE_TARGET_TYPE (VALUE_TYPE (array)),
+ NULL, 1);
+ struct value *item0 =
+ ada_value_ptr_subscript (array, arr_type0, 1,
+ &low_bound_val);
+ struct value *slice =
+ value_repeat (item0, high_bound - low_bound + 1);
+ struct type *arr_type1 = VALUE_TYPE (slice);
+ TYPE_LOW_BOUND (TYPE_INDEX_TYPE (arr_type1)) = low_bound;
+ TYPE_HIGH_BOUND (TYPE_INDEX_TYPE (arr_type1)) += low_bound;
+ return slice;
+ }
+ }
+ else if (noside == EVAL_AVOID_SIDE_EFFECTS)
+ return array;
+ else if (high_bound < low_bound)
+ return empty_array (VALUE_TYPE (array), low_bound);
+ else
+ return value_slice (array, low_bound, high_bound - low_bound + 1);
+ }
+
+ case UNOP_IN_RANGE:
+ (*pos) += 2;
+ arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
+ type = exp->elts[pc + 1].type;
+
+ if (noside == EVAL_SKIP)
+ goto nosideret;
+
+ switch (TYPE_CODE (type))
+ {
+ default:
+ lim_warning ("Membership test incompletely implemented; "
+ "always returns true", 0);
+ return value_from_longest (builtin_type_int, (LONGEST) 1);
+
+ case TYPE_CODE_RANGE:
+ arg2 = value_from_longest (builtin_type_int,
+ TYPE_LOW_BOUND (type));
+ arg3 = value_from_longest (builtin_type_int,
+ TYPE_HIGH_BOUND (type));
+ return
+ value_from_longest (builtin_type_int,
+ (value_less (arg1, arg3)
+ || value_equal (arg1, arg3))
+ && (value_less (arg2, arg1)
+ || value_equal (arg2, arg1)));
+ }
- case OP_ARRAY:
- (*pos) += 3;
- tem2 = longest_to_int (exp->elts[pc + 1].longconst);
- tem3 = longest_to_int (exp->elts[pc + 2].longconst);
- nargs = tem3 - tem2 + 1;
- type = expect_type ? check_typedef (expect_type) : NULL_TYPE;
+ case BINOP_IN_BOUNDS:
+ (*pos) += 2;
+ arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
+ arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
- argvec =
- (struct value * *) alloca (sizeof (struct value *) * (nargs + 1));
- for (tem = 0; tem == 0 || tem < nargs; tem += 1)
- /* At least one element gets inserted for the type */
- {
- /* Ensure that array expressions are coerced into pointer objects. */
- argvec[tem] = evaluate_subexp_with_coercion (exp, pos, noside);
- }
if (noside == EVAL_SKIP)
- goto nosideret;
- return value_array (tem2, tem3, argvec);
+ goto nosideret;
- case OP_FUNCALL:
- (*pos) += 2;
+ if (noside == EVAL_AVOID_SIDE_EFFECTS)
+ return value_zero (builtin_type_int, not_lval);
- /* Allocate arg vector, including space for the function to be
- called in argvec[0] and a terminating NULL */
- nargs = longest_to_int (exp->elts[pc + 1].longconst);
- argvec =
- (struct value * *) alloca (sizeof (struct value *) * (nargs + 2));
+ tem = longest_to_int (exp->elts[pc + 1].longconst);
- /* FIXME: OP_UNRESOLVED_VALUE should be defined in expression.h */
- /* FIXME: name should be defined in expresion.h */
- /* if (exp->elts[*pos].opcode == OP_UNRESOLVED_VALUE)
- error ("Unexpected unresolved symbol, %s, during evaluation",
- ada_demangle (exp->elts[pc + 5].name));
- */
- if (0)
- {
- error ("unexpected code path, FIXME");
- }
- else
- {
- for (tem = 0; tem <= nargs; tem += 1)
- argvec[tem] = evaluate_subexp (NULL_TYPE, exp, pos, noside);
- argvec[tem] = 0;
+ if (tem < 1 || tem > ada_array_arity (VALUE_TYPE (arg2)))
+ error ("invalid dimension number to '%s", "range");
- if (noside == EVAL_SKIP)
- goto nosideret;
- }
+ arg3 = ada_array_bound (arg2, tem, 1);
+ arg2 = ada_array_bound (arg2, tem, 0);
- if (TYPE_CODE (VALUE_TYPE (argvec[0])) == TYPE_CODE_REF)
- argvec[0] = value_addr (argvec[0]);
+ return
+ value_from_longest (builtin_type_int,
+ (value_less (arg1, arg3)
+ || value_equal (arg1, arg3))
+ && (value_less (arg2, arg1)
+ || value_equal (arg2, arg1)));
- if (ada_is_packed_array_type (VALUE_TYPE (argvec[0])))
- argvec[0] = ada_coerce_to_simple_array (argvec[0]);
+ case TERNOP_IN_RANGE:
+ arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
+ arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
+ arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
- type = check_typedef (VALUE_TYPE (argvec[0]));
- if (TYPE_CODE (type) == TYPE_CODE_PTR)
- {
- switch (TYPE_CODE (check_typedef (TYPE_TARGET_TYPE (type))))
- {
- case TYPE_CODE_FUNC:
- type = check_typedef (TYPE_TARGET_TYPE (type));
- break;
- case TYPE_CODE_ARRAY:
- break;
- case TYPE_CODE_STRUCT:
- if (noside != EVAL_AVOID_SIDE_EFFECTS)
- argvec[0] = ada_value_ind (argvec[0]);
- type = check_typedef (TYPE_TARGET_TYPE (type));
- break;
- default:
- error ("cannot subscript or call something of type `%s'",
- ada_type_name (VALUE_TYPE (argvec[0])));
- break;
- }
- }
+ if (noside == EVAL_SKIP)
+ goto nosideret;
- switch (TYPE_CODE (type))
- {
- case TYPE_CODE_FUNC:
- if (noside == EVAL_AVOID_SIDE_EFFECTS)
- return allocate_value (TYPE_TARGET_TYPE (type));
- return call_function_by_hand (argvec[0], nargs, argvec + 1);
- case TYPE_CODE_STRUCT:
+ return
+ value_from_longest (builtin_type_int,
+ (value_less (arg1, arg3)
+ || value_equal (arg1, arg3))
+ && (value_less (arg2, arg1)
+ || value_equal (arg2, arg1)));
+
+ case OP_ATR_FIRST:
+ case OP_ATR_LAST:
+ case OP_ATR_LENGTH:
+ {
+ struct type *type_arg;
+ if (exp->elts[*pos].opcode == OP_TYPE)
{
- int arity = ada_array_arity (type);
- type = ada_array_element_type (type, nargs);
- if (type == NULL)
- error ("cannot subscript or call a record");
- if (arity != nargs)
- error ("wrong number of subscripts; expecting %d", arity);
- if (noside == EVAL_AVOID_SIDE_EFFECTS)
- return allocate_value (ada_aligned_type (type));
- return
- unwrap_value (ada_value_subscript
- (argvec[0], nargs, argvec + 1));
+ evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
+ arg1 = NULL;
+ type_arg = exp->elts[pc + 2].type;
+ }
+ else
+ {
+ arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
+ type_arg = NULL;
}
- case TYPE_CODE_ARRAY:
- if (noside == EVAL_AVOID_SIDE_EFFECTS)
- {
- type = ada_array_element_type (type, nargs);
- if (type == NULL)
- error ("element type of array unknown");
- else
- return allocate_value (ada_aligned_type (type));
- }
- return
- unwrap_value (ada_value_subscript
- (ada_coerce_to_simple_array (argvec[0]),
- nargs, argvec + 1));
- case TYPE_CODE_PTR: /* Pointer to array */
- type = to_fixed_array_type (TYPE_TARGET_TYPE (type), NULL, 1);
- if (noside == EVAL_AVOID_SIDE_EFFECTS)
- {
- type = ada_array_element_type (type, nargs);
- if (type == NULL)
- error ("element type of array unknown");
- else
- return allocate_value (ada_aligned_type (type));
- }
- return
- unwrap_value (ada_value_ptr_subscript (argvec[0], type,
- nargs, argvec + 1));
- default:
- error ("Internal error in evaluate_subexp");
- }
+ if (exp->elts[*pos].opcode != OP_LONG)
+ error ("illegal operand to '%s", ada_attribute_name (op));
+ tem = longest_to_int (exp->elts[*pos + 2].longconst);
+ *pos += 4;
- case TERNOP_SLICE:
- {
- struct value *array = evaluate_subexp (NULL_TYPE, exp, pos, noside);
- int lowbound
- = value_as_long (evaluate_subexp (NULL_TYPE, exp, pos, noside));
- int upper
- = value_as_long (evaluate_subexp (NULL_TYPE, exp, pos, noside));
if (noside == EVAL_SKIP)
goto nosideret;
- /* If this is a reference to an array, then dereference it */
- if (TYPE_CODE (VALUE_TYPE (array)) == TYPE_CODE_REF
- && TYPE_TARGET_TYPE (VALUE_TYPE (array)) != NULL
- && TYPE_CODE (TYPE_TARGET_TYPE (VALUE_TYPE (array))) ==
- TYPE_CODE_ARRAY
- && !ada_is_array_descriptor (check_typedef (VALUE_TYPE (array))))
+ if (type_arg == NULL)
{
- array = ada_coerce_ref (array);
- }
+ arg1 = ada_coerce_ref (arg1);
- if (noside == EVAL_AVOID_SIDE_EFFECTS &&
- ada_is_array_descriptor (check_typedef (VALUE_TYPE (array))))
- {
- /* Try to dereference the array, in case it is an access to array */
- struct type *arrType = ada_type_of_array (array, 0);
- if (arrType != NULL)
- array = value_at_lazy (arrType, 0, NULL);
- }
- if (ada_is_array_descriptor (VALUE_TYPE (array)))
- array = ada_coerce_to_simple_array (array);
+ if (ada_is_packed_array_type (VALUE_TYPE (arg1)))
+ arg1 = ada_coerce_to_simple_array (arg1);
+
+ if (tem < 1 || tem > ada_array_arity (VALUE_TYPE (arg1)))
+ error ("invalid dimension number to '%s",
+ ada_attribute_name (op));
+
+ if (noside == EVAL_AVOID_SIDE_EFFECTS)
+ {
+ type = ada_index_type (VALUE_TYPE (arg1), tem);
+ if (type == NULL)
+ error
+ ("attempt to take bound of something that is not an array");
+ return allocate_value (type);
+ }
- /* If at this point we have a pointer to an array, it means that
- it is a pointer to a simple (non-ada) array. We just then
- dereference it */
- if (TYPE_CODE (VALUE_TYPE (array)) == TYPE_CODE_PTR
- && TYPE_TARGET_TYPE (VALUE_TYPE (array)) != NULL
- && TYPE_CODE (TYPE_TARGET_TYPE (VALUE_TYPE (array))) ==
- TYPE_CODE_ARRAY)
+ switch (op)
+ {
+ default: /* Should never happen. */
+ error ("unexpected attribute encountered");
+ case OP_ATR_FIRST:
+ return ada_array_bound (arg1, tem, 0);
+ case OP_ATR_LAST:
+ return ada_array_bound (arg1, tem, 1);
+ case OP_ATR_LENGTH:
+ return ada_array_length (arg1, tem);
+ }
+ }
+ else if (discrete_type_p (type_arg))
{
- array = ada_value_ind (array);
+ struct type *range_type;
+ char *name = ada_type_name (type_arg);
+ range_type = NULL;
+ if (name != NULL && TYPE_CODE (type_arg) != TYPE_CODE_ENUM)
+ range_type =
+ to_fixed_range_type (name, NULL, TYPE_OBJFILE (type_arg));
+ if (range_type == NULL)
+ range_type = type_arg;
+ switch (op)
+ {
+ default:
+ error ("unexpected attribute encountered");
+ case OP_ATR_FIRST:
+ return discrete_type_low_bound (range_type);
+ case OP_ATR_LAST:
+ return discrete_type_high_bound (range_type);
+ case OP_ATR_LENGTH:
+ error ("the 'length attribute applies only to array types");
+ }
}
-
- if (noside == EVAL_AVOID_SIDE_EFFECTS)
- /* The following will get the bounds wrong, but only in contexts
- where the value is not being requested (FIXME?). */
- return array;
+ else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT)
+ error ("unimplemented type attribute");
else
- return value_slice (array, lowbound, upper - lowbound + 1);
+ {
+ LONGEST low, high;
+
+ if (ada_is_packed_array_type (type_arg))
+ type_arg = decode_packed_array_type (type_arg);
+
+ if (tem < 1 || tem > ada_array_arity (type_arg))
+ error ("invalid dimension number to '%s",
+ ada_attribute_name (op));
+
+ type = ada_index_type (type_arg, tem);
+ if (type == NULL)
+ error ("attempt to take bound of something that is not an array");
+ if (noside == EVAL_AVOID_SIDE_EFFECTS)
+ return allocate_value (type);
+
+ switch (op)
+ {
+ default:
+ error ("unexpected attribute encountered");
+ case OP_ATR_FIRST:
+ low = ada_array_bound_from_type (type_arg, tem, 0, &type);
+ return value_from_longest (type, low);
+ case OP_ATR_LAST:
+ high =
+ ada_array_bound_from_type (type_arg, tem, 1, &type);
+ return value_from_longest (type, high);
+ case OP_ATR_LENGTH:
+ low = ada_array_bound_from_type (type_arg, tem, 0, &type);
+ high = ada_array_bound_from_type (type_arg, tem, 1, NULL);
+ return value_from_longest (type, high - low + 1);
+ }
+ }
}
- /* FIXME: UNOP_MBR should be defined in expression.h */
- /* case UNOP_MBR:
- (*pos) += 2;
- arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
- type = exp->elts[pc + 1].type;
-
- if (noside == EVAL_SKIP)
- goto nosideret;
-
- switch (TYPE_CODE (type))
- {
- default:
- warning ("Membership test incompletely implemented; always returns true");
- return value_from_longest (builtin_type_int, (LONGEST) 1);
-
- case TYPE_CODE_RANGE:
- arg2 = value_from_longest (builtin_type_int,
- (LONGEST) TYPE_LOW_BOUND (type));
- arg3 = value_from_longest (builtin_type_int,
- (LONGEST) TYPE_HIGH_BOUND (type));
- return
- value_from_longest (builtin_type_int,
- (value_less (arg1,arg3)
- || value_equal (arg1,arg3))
- && (value_less (arg2,arg1)
- || value_equal (arg2,arg1)));
- }
- */
- /* FIXME: BINOP_MBR should be defined in expression.h */
- /* case BINOP_MBR:
- (*pos) += 2;
- arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
- arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
-
- if (noside == EVAL_SKIP)
- goto nosideret;
-
- if (noside == EVAL_AVOID_SIDE_EFFECTS)
- return value_zero (builtin_type_int, not_lval);
-
- tem = longest_to_int (exp->elts[pc + 1].longconst);
-
- if (tem < 1 || tem > ada_array_arity (VALUE_TYPE (arg2)))
- error ("invalid dimension number to '%s", "range");
-
- arg3 = ada_array_bound (arg2, tem, 1);
- arg2 = ada_array_bound (arg2, tem, 0);
-
- return
- value_from_longest (builtin_type_int,
- (value_less (arg1,arg3)
- || value_equal (arg1,arg3))
- && (value_less (arg2,arg1)
- || value_equal (arg2,arg1)));
- */
- /* FIXME: TERNOP_MBR should be defined in expression.h */
- /* case TERNOP_MBR:
- arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
- arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
- arg3 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
-
- if (noside == EVAL_SKIP)
- goto nosideret;
-
- return
- value_from_longest (builtin_type_int,
- (value_less (arg1,arg3)
- || value_equal (arg1,arg3))
- && (value_less (arg2,arg1)
- || value_equal (arg2,arg1)));
- */
- /* FIXME: OP_ATTRIBUTE should be defined in expression.h */
- /* case OP_ATTRIBUTE:
- *pos += 3;
- atr = (enum ada_attribute) longest_to_int (exp->elts[pc + 2].longconst);
- switch (atr)
- {
- default:
- error ("unexpected attribute encountered");
-
- case ATR_FIRST:
- case ATR_LAST:
- case ATR_LENGTH:
- {
- struct type* type_arg;
- if (exp->elts[*pos].opcode == OP_TYPE)
- {
- evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
- arg1 = NULL;
- type_arg = exp->elts[pc + 5].type;
- }
- else
- {
- arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
- type_arg = NULL;
- }
-
- if (exp->elts[*pos].opcode != OP_LONG)
- error ("illegal operand to '%s", ada_attribute_name (atr));
- tem = longest_to_int (exp->elts[*pos+2].longconst);
- *pos += 4;
-
- if (noside == EVAL_SKIP)
- goto nosideret;
-
- if (type_arg == NULL)
- {
- arg1 = ada_coerce_ref (arg1);
-
- if (ada_is_packed_array_type (VALUE_TYPE (arg1)))
- arg1 = ada_coerce_to_simple_array (arg1);
-
- if (tem < 1 || tem > ada_array_arity (VALUE_TYPE (arg1)))
- error ("invalid dimension number to '%s",
- ada_attribute_name (atr));
-
- if (noside == EVAL_AVOID_SIDE_EFFECTS)
- {
- type = ada_index_type (VALUE_TYPE (arg1), tem);
- if (type == NULL)
- error ("attempt to take bound of something that is not an array");
- return allocate_value (type);
- }
-
- switch (atr)
- {
- default:
- error ("unexpected attribute encountered");
- case ATR_FIRST:
- return ada_array_bound (arg1, tem, 0);
- case ATR_LAST:
- return ada_array_bound (arg1, tem, 1);
- case ATR_LENGTH:
- return ada_array_length (arg1, tem);
- }
- }
- else if (TYPE_CODE (type_arg) == TYPE_CODE_RANGE
- || TYPE_CODE (type_arg) == TYPE_CODE_INT)
- {
- struct type* range_type;
- char* name = ada_type_name (type_arg);
- if (name == NULL)
- {
- if (TYPE_CODE (type_arg) == TYPE_CODE_RANGE)
- range_type = type_arg;
- else
- error ("unimplemented type attribute");
- }
- else
- range_type =
- to_fixed_range_type (name, NULL, TYPE_OBJFILE (type_arg));
- switch (atr)
- {
- default:
- error ("unexpected attribute encountered");
- case ATR_FIRST:
- return value_from_longest (TYPE_TARGET_TYPE (range_type),
- TYPE_LOW_BOUND (range_type));
- case ATR_LAST:
- return value_from_longest (TYPE_TARGET_TYPE (range_type),
- TYPE_HIGH_BOUND (range_type));
- }
- }
- else if (TYPE_CODE (type_arg) == TYPE_CODE_ENUM)
- {
- switch (atr)
- {
- default:
- error ("unexpected attribute encountered");
- case ATR_FIRST:
- return value_from_longest
- (type_arg, TYPE_FIELD_BITPOS (type_arg, 0));
- case ATR_LAST:
- return value_from_longest
- (type_arg,
- TYPE_FIELD_BITPOS (type_arg,
- TYPE_NFIELDS (type_arg) - 1));
- }
- }
- else if (TYPE_CODE (type_arg) == TYPE_CODE_FLT)
- error ("unimplemented type attribute");
- else
- {
- LONGEST low, high;
-
- if (ada_is_packed_array_type (type_arg))
- type_arg = decode_packed_array_type (type_arg);
-
- if (tem < 1 || tem > ada_array_arity (type_arg))
- error ("invalid dimension number to '%s",
- ada_attribute_name (atr));
-
- if (noside == EVAL_AVOID_SIDE_EFFECTS)
- {
- type = ada_index_type (type_arg, tem);
- if (type == NULL)
- error ("attempt to take bound of something that is not an array");
- return allocate_value (type);
- }
-
- switch (atr)
- {
- default:
- error ("unexpected attribute encountered");
- case ATR_FIRST:
- low = ada_array_bound_from_type (type_arg, tem, 0, &type);
- return value_from_longest (type, low);
- case ATR_LAST:
- high = ada_array_bound_from_type (type_arg, tem, 1, &type);
- return value_from_longest (type, high);
- case ATR_LENGTH:
- low = ada_array_bound_from_type (type_arg, tem, 0, &type);
- high = ada_array_bound_from_type (type_arg, tem, 1, NULL);
- return value_from_longest (type, high-low+1);
- }
- }
- }
-
- case ATR_TAG:
- arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
- if (noside == EVAL_SKIP)
- goto nosideret;
-
- if (noside == EVAL_AVOID_SIDE_EFFECTS)
- return
- value_zero (ada_tag_type (arg1), not_lval);
-
- return ada_value_tag (arg1);
-
- case ATR_MIN:
- case ATR_MAX:
- evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
- arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
- arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
- if (noside == EVAL_SKIP)
- goto nosideret;
- else if (noside == EVAL_AVOID_SIDE_EFFECTS)
- return value_zero (VALUE_TYPE (arg1), not_lval);
- else
- return value_binop (arg1, arg2,
- atr == ATR_MIN ? BINOP_MIN : BINOP_MAX);
-
- case ATR_MODULUS:
- {
- struct type* type_arg = exp->elts[pc + 5].type;
- evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
- *pos += 4;
-
- if (noside == EVAL_SKIP)
- goto nosideret;
-
- if (! ada_is_modular_type (type_arg))
- error ("'modulus must be applied to modular type");
-
- return value_from_longest (TYPE_TARGET_TYPE (type_arg),
- ada_modulus (type_arg));
- }
-
-
- case ATR_POS:
- evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
- arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
- if (noside == EVAL_SKIP)
- goto nosideret;
- else if (noside == EVAL_AVOID_SIDE_EFFECTS)
- return value_zero (builtin_type_ada_int, not_lval);
- else
- return value_pos_atr (arg1);
-
- case ATR_SIZE:
- arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
- if (noside == EVAL_SKIP)
- goto nosideret;
- else if (noside == EVAL_AVOID_SIDE_EFFECTS)
- return value_zero (builtin_type_ada_int, not_lval);
- else
- return value_from_longest (builtin_type_ada_int,
- TARGET_CHAR_BIT
- * TYPE_LENGTH (VALUE_TYPE (arg1)));
-
- case ATR_VAL:
- evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
- arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
- type = exp->elts[pc + 5].type;
- if (noside == EVAL_SKIP)
- goto nosideret;
- else if (noside == EVAL_AVOID_SIDE_EFFECTS)
- return value_zero (type, not_lval);
- else
- return value_val_atr (type, arg1);
- } */
- case BINOP_EXP:
+ case OP_ATR_TAG:
+ arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
+ if (noside == EVAL_SKIP)
+ goto nosideret;
+
+ if (noside == EVAL_AVOID_SIDE_EFFECTS)
+ return value_zero (ada_tag_type (arg1), not_lval);
+
+ return ada_value_tag (arg1);
+
+ case OP_ATR_MIN:
+ case OP_ATR_MAX:
+ evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
if (noside == EVAL_SKIP)
goto nosideret;
- if (binop_user_defined_p (op, arg1, arg2))
- return unwrap_value (value_x_binop (arg1, arg2, op, OP_NULL,
- EVAL_NORMAL));
else if (noside == EVAL_AVOID_SIDE_EFFECTS)
return value_zero (VALUE_TYPE (arg1), not_lval);
else
- return value_binop (arg1, arg2, op);
+ return value_binop (arg1, arg2,
+ op == OP_ATR_MIN ? BINOP_MIN : BINOP_MAX);
- case UNOP_PLUS:
+ case OP_ATR_MODULUS:
+ {
+ struct type *type_arg = exp->elts[pc + 2].type;
+ evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
+
+ if (noside == EVAL_SKIP)
+ goto nosideret;
+
+ if (!ada_is_modular_type (type_arg))
+ error ("'modulus must be applied to modular type");
+
+ return value_from_longest (TYPE_TARGET_TYPE (type_arg),
+ ada_modulus (type_arg));
+ }
+
+
+ case OP_ATR_POS:
+ evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
if (noside == EVAL_SKIP)
goto nosideret;
- if (unop_user_defined_p (op, arg1))
- return unwrap_value (value_x_unop (arg1, op, EVAL_NORMAL));
+ else if (noside == EVAL_AVOID_SIDE_EFFECTS)
+ return value_zero (builtin_type_ada_int, not_lval);
else
- return arg1;
+ return value_pos_atr (arg1);
- case UNOP_ABS:
+ case OP_ATR_SIZE:
+ arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
+ if (noside == EVAL_SKIP)
+ goto nosideret;
+ else if (noside == EVAL_AVOID_SIDE_EFFECTS)
+ return value_zero (builtin_type_ada_int, not_lval);
+ else
+ return value_from_longest (builtin_type_ada_int,
+ TARGET_CHAR_BIT
+ * TYPE_LENGTH (VALUE_TYPE (arg1)));
+
+ case OP_ATR_VAL:
+ evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
+ type = exp->elts[pc + 2].type;
if (noside == EVAL_SKIP)
goto nosideret;
+ else if (noside == EVAL_AVOID_SIDE_EFFECTS)
+ return value_zero (type, not_lval);
+ else
+ return value_val_atr (type, arg1);
+
+ case BINOP_EXP:
+ arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
+ arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
+ if (noside == EVAL_SKIP)
+ goto nosideret;
+ else if (noside == EVAL_AVOID_SIDE_EFFECTS)
+ return value_zero (VALUE_TYPE (arg1), not_lval);
+ else
+ return value_binop (arg1, arg2, op);
+
+ case UNOP_PLUS:
+ arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
+ if (noside == EVAL_SKIP)
+ goto nosideret;
+ else
+ return arg1;
+
+ case UNOP_ABS:
+ arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
+ if (noside == EVAL_SKIP)
+ goto nosideret;
if (value_less (arg1, value_zero (VALUE_TYPE (arg1), not_lval)))
- return value_neg (arg1);
+ return value_neg (arg1);
else
- return arg1;
+ return arg1;
case UNOP_IND:
if (expect_type && TYPE_CODE (expect_type) == TYPE_CODE_PTR)
- expect_type = TYPE_TARGET_TYPE (check_typedef (expect_type));
+ expect_type = TYPE_TARGET_TYPE (check_typedef (expect_type));
arg1 = evaluate_subexp (expect_type, exp, pos, noside);
if (noside == EVAL_SKIP)
- goto nosideret;
+ goto nosideret;
type = check_typedef (VALUE_TYPE (arg1));
if (noside == EVAL_AVOID_SIDE_EFFECTS)
- {
- if (ada_is_array_descriptor (type))
- /* GDB allows dereferencing GNAT array descriptors. */
- {
- struct type *arrType = ada_type_of_array (arg1, 0);
- if (arrType == NULL)
- error ("Attempt to dereference null array pointer.");
- return value_at_lazy (arrType, 0, NULL);
- }
- else if (TYPE_CODE (type) == TYPE_CODE_PTR
- || TYPE_CODE (type) == TYPE_CODE_REF
- /* In C you can dereference an array to get the 1st elt. */
- || TYPE_CODE (type) == TYPE_CODE_ARRAY)
- return
- value_zero
- (to_static_fixed_type
- (ada_aligned_type (check_typedef (TYPE_TARGET_TYPE (type)))),
- lval_memory);
- else if (TYPE_CODE (type) == TYPE_CODE_INT)
- /* GDB allows dereferencing an int. */
- return value_zero (builtin_type_int, lval_memory);
- else
- error ("Attempt to take contents of a non-pointer value.");
- }
- arg1 = ada_coerce_ref (arg1);
+ {
+ if (ada_is_array_descriptor_type (type))
+ /* GDB allows dereferencing GNAT array descriptors. */
+ {
+ struct type *arrType = ada_type_of_array (arg1, 0);
+ if (arrType == NULL)
+ error ("Attempt to dereference null array pointer.");
+ return value_at_lazy (arrType, 0, NULL);
+ }
+ else if (TYPE_CODE (type) == TYPE_CODE_PTR
+ || TYPE_CODE (type) == TYPE_CODE_REF
+ /* In C you can dereference an array to get the 1st elt. */
+ || TYPE_CODE (type) == TYPE_CODE_ARRAY)
+ return
+ value_zero
+ (to_static_fixed_type
+ (ada_aligned_type (check_typedef (TYPE_TARGET_TYPE (type)))),
+ lval_memory);
+ else if (TYPE_CODE (type) == TYPE_CODE_INT)
+ /* GDB allows dereferencing an int. */
+ return value_zero (builtin_type_int, lval_memory);
+ else
+ error ("Attempt to take contents of a non-pointer value.");
+ }
+ arg1 = ada_coerce_ref (arg1); /* FIXME: What is this for?? */
type = check_typedef (VALUE_TYPE (arg1));
- if (ada_is_array_descriptor (type))
- /* GDB allows dereferencing GNAT array descriptors. */
- return ada_coerce_to_simple_array (arg1);
+ if (ada_is_array_descriptor_type (type))
+ /* GDB allows dereferencing GNAT array descriptors. */
+ return ada_coerce_to_simple_array (arg1);
else
- return ada_value_ind (arg1);
+ return ada_value_ind (arg1);
case STRUCTOP_STRUCT:
tem = longest_to_int (exp->elts[pc + 1].longconst);
(*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1);
arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
if (noside == EVAL_SKIP)
- goto nosideret;
+ goto nosideret;
if (noside == EVAL_AVOID_SIDE_EFFECTS)
- return value_zero (ada_aligned_type
- (ada_lookup_struct_elt_type (VALUE_TYPE (arg1),
- &exp->elts[pc +
- 2].string,
- 0, NULL)),
- lval_memory);
- else
- return unwrap_value (ada_value_struct_elt (arg1,
- &exp->elts[pc + 2].string,
- "record"));
+ {
+ struct type *type1 = VALUE_TYPE (arg1);
+ if (ada_is_tagged_type (type1, 1))
+ {
+ type = ada_lookup_struct_elt_type (type1,
+ &exp->elts[pc + 2].string,
+ 1, 1, NULL);
+ if (type == NULL)
+ /* In this case, we assume that the field COULD exist
+ in some extension of the type. Return an object of
+ "type" void, which will match any formal
+ (see ada_type_match). */
+ return value_zero (builtin_type_void, lval_memory);
+ }
+ else
+ type = ada_lookup_struct_elt_type (type1, &exp->elts[pc + 2].string,
+ 1, 0, NULL);
+
+ return value_zero (ada_aligned_type (type), lval_memory);
+ }
+ else
+ return
+ ada_to_fixed_value (unwrap_value
+ (ada_value_struct_elt
+ (arg1, &exp->elts[pc + 2].string, "record")));
case OP_TYPE:
- /* The value is not supposed to be used. This is here to make it
- easier to accommodate expressions that contain types. */
+ /* The value is not supposed to be used. This is here to make it
+ easier to accommodate expressions that contain types. */
(*pos) += 2;
if (noside == EVAL_SKIP)
- goto nosideret;
+ goto nosideret;
else if (noside == EVAL_AVOID_SIDE_EFFECTS)
- return allocate_value (builtin_type_void);
+ return allocate_value (builtin_type_void);
else
- error ("Attempt to use a type name as an expression");
-
- case STRUCTOP_PTR:
- tem = longest_to_int (exp->elts[pc + 1].longconst);
- (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1);
- arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
- if (noside == EVAL_SKIP)
- goto nosideret;
- if (noside == EVAL_AVOID_SIDE_EFFECTS)
- return value_zero (ada_aligned_type
- (ada_lookup_struct_elt_type (VALUE_TYPE (arg1),
- &exp->elts[pc +
- 2].string,
- 0, NULL)),
- lval_memory);
- else
- return unwrap_value (ada_value_struct_elt (arg1,
- &exp->elts[pc + 2].string,
- "record access"));
+ error ("Attempt to use a type name as an expression");
}
nosideret:
@@ -7565,11 +9373,11 @@ nosideret:
}
- /* Fixed point */
+ /* Fixed point */
/* If TYPE encodes an Ada fixed-point type, return the suffix of the
type name that encodes the 'small and 'delta information.
- Otherwise, return NULL. */
+ Otherwise, return NULL. */
static const char *
fixed_type_info (struct type *type)
@@ -7581,9 +9389,9 @@ fixed_type_info (struct type *type)
{
const char *tail = strstr (name, "___XF_");
if (tail == NULL)
- return NULL;
+ return NULL;
else
- return tail + 5;
+ return tail + 5;
}
else if (code == TYPE_CODE_RANGE && TYPE_TARGET_TYPE (type) != type)
return fixed_type_info (TYPE_TARGET_TYPE (type));
@@ -7591,7 +9399,7 @@ fixed_type_info (struct type *type)
return NULL;
}
-/* Returns non-zero iff TYPE represents an Ada fixed-point type. */
+/* Returns non-zero iff TYPE represents an Ada fixed-point type. */
int
ada_is_fixed_point_type (struct type *type)
@@ -7599,9 +9407,18 @@ ada_is_fixed_point_type (struct type *ty
return fixed_type_info (type) != NULL;
}
+/* Return non-zero iff TYPE represents a System.Address type. */
+
+int
+ada_is_system_address_type (struct type *type)
+{
+ return (TYPE_NAME (type)
+ && strcmp (TYPE_NAME (type), "system__address") == 0);
+}
+
/* Assuming that TYPE is the representation of an Ada fixed-point
type, return its delta, or -1 if the type is malformed and the
- delta cannot be determined. */
+ delta cannot be determined. */
DOUBLEST
ada_delta (struct type *type)
@@ -7616,7 +9433,7 @@ ada_delta (struct type *type)
}
/* Assuming that ada_is_fixed_point_type (TYPE), return the scaling
- factor ('SMALL value) associated with the type. */
+ factor ('SMALL value) associated with the type. */
static DOUBLEST
scaling_factor (struct type *type)
@@ -7637,7 +9454,7 @@ scaling_factor (struct type *type)
/* Assuming that X is the representation of a value of fixed-point
- type TYPE, return its floating-point equivalent. */
+ type TYPE, return its floating-point equivalent. */
DOUBLEST
ada_fixed_to_float (struct type *type, LONGEST x)
@@ -7645,8 +9462,8 @@ ada_fixed_to_float (struct type *type, L
return (DOUBLEST) x *scaling_factor (type);
}
-/* The representation of a fixed-point value of type TYPE
- corresponding to the value X. */
+/* The representation of a fixed-point value of type TYPE
+ corresponding to the value X. */
LONGEST
ada_float_to_fixed (struct type *type, DOUBLEST x)
@@ -7655,10 +9472,11 @@ ada_float_to_fixed (struct type *type, D
}
- /* VAX floating formats */
+ /* VAX floating formats */
/* Non-zero iff TYPE represents one of the special VAX floating-point
- types. */
+ types. */
+
int
ada_is_vax_floating_type (struct type *type)
{
@@ -7667,21 +9485,23 @@ ada_is_vax_floating_type (struct type *t
return
name_len > 6
&& (TYPE_CODE (type) == TYPE_CODE_INT
- || TYPE_CODE (type) == TYPE_CODE_RANGE)
- && DEPRECATED_STREQN (ada_type_name (type) + name_len - 6, "___XF", 5);
+ || TYPE_CODE (type) == TYPE_CODE_RANGE)
+ && strncmp (ada_type_name (type) + name_len - 6, "___XF", 5) == 0;
}
/* The type of special VAX floating-point type this is, assuming
- ada_is_vax_floating_point */
+ ada_is_vax_floating_point. */
+
int
ada_vax_float_type_suffix (struct type *type)
{
return ada_type_name (type)[strlen (ada_type_name (type)) - 1];
}
-/* A value representing the special debugging function that outputs
+/* A value representing the special debugging function that outputs
VAX floating-point values of the type represented by TYPE. Assumes
- ada_is_vax_floating_type (TYPE). */
+ ada_is_vax_floating_type (TYPE). */
+
struct value *
ada_vax_float_print_function (struct type *type)
{
@@ -7699,13 +9519,13 @@ ada_vax_float_print_function (struct typ
}
- /* Range types */
+ /* Range types */
/* Scan STR beginning at position K for a discriminant name, and
return the value of that discriminant field of DVAL in *PX. If
PNEW_K is not null, put the position of the character beyond the
name scanned in *PNEW_K. Return 1 if successful; return 0 and do
- not alter *PX and *PNEW_K if unsuccessful. */
+ not alter *PX and *PNEW_K if unsuccessful. */
static int
scan_discrim_bound (char *str, int k, struct value *dval, LONGEST * px,
@@ -7747,47 +9567,47 @@ scan_discrim_bound (char *str, int k, st
/* Value of variable named NAME in the current environment. If
no such variable found, then if ERR_MSG is null, returns 0, and
- otherwise causes an error with message ERR_MSG. */
+ otherwise causes an error with message ERR_MSG. */
+
static struct value *
get_var_value (char *name, char *err_msg)
{
- struct symbol **syms;
- struct block **blocks;
+ struct ada_symbol_info *syms;
int nsyms;
- nsyms =
- ada_lookup_symbol_list (name, get_selected_block (NULL), VAR_DOMAIN,
- &syms, &blocks);
+ nsyms = ada_lookup_symbol_list (name, get_selected_block (0), VAR_DOMAIN,
+ &syms);
if (nsyms != 1)
{
if (err_msg == NULL)
- return 0;
+ return 0;
else
- error ("%s", err_msg);
+ error ("%s", err_msg);
}
- return value_of_variable (syms[0], blocks[0]);
+ return value_of_variable (syms[0].sym, syms[0].block);
}
/* Value of integer variable named NAME in the current environment. If
- no such variable found, then if ERR_MSG is null, returns 0, and sets
- *FLAG to 0. If successful, sets *FLAG to 1. */
+ no such variable found, returns 0, and sets *FLAG to 0. If
+ successful, sets *FLAG to 1. */
+
LONGEST
-get_int_var_value (char *name, char *err_msg, int *flag)
+get_int_var_value (char *name, int *flag)
{
- struct value *var_val = get_var_value (name, err_msg);
+ struct value *var_val = get_var_value (name, 0);
if (var_val == 0)
{
if (flag != NULL)
- *flag = 0;
+ *flag = 0;
return 0;
}
else
{
if (flag != NULL)
- *flag = 1;
+ *flag = 1;
return value_as_long (var_val);
}
}
@@ -7795,18 +9615,17 @@ get_int_var_value (char *name, char *err
/* Return a range type whose base type is that of the range type named
NAME in the current environment, and whose bounds are calculated
- from NAME according to the GNAT range encoding conventions.
+ from NAME according to the GNAT range encoding conventions.
Extract discriminant values, if needed, from DVAL. If a new type
must be created, allocate in OBJFILE's space. The bounds
information, in general, is encoded in NAME, the base type given in
- the named range type. */
+ the named range type. */
static struct type *
to_fixed_range_type (char *name, struct value *dval, struct objfile *objfile)
{
struct type *raw_type = ada_find_any_type (name);
struct type *base_type;
- LONGEST low, high;
char *subtype_info;
if (raw_type == NULL)
@@ -7838,43 +9657,56 @@ to_fixed_range_type (char *name, struct
n = 1;
if (*subtype_info == 'L')
- {
- if (!ada_scan_number (bounds_str, n, &L, &n)
- && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
- return raw_type;
- if (bounds_str[n] == '_')
- n += 2;
- else if (bounds_str[n] == '.') /* FIXME? SGI Workshop kludge. */
- n += 1;
- subtype_info += 1;
- }
- else
- {
- strcpy (name_buf + prefix_len, "___L");
- L = get_int_var_value (name_buf, "Index bound unknown.", NULL);
- }
+ {
+ if (!ada_scan_number (bounds_str, n, &L, &n)
+ && !scan_discrim_bound (bounds_str, n, dval, &L, &n))
+ return raw_type;
+ if (bounds_str[n] == '_')
+ n += 2;
+ else if (bounds_str[n] == '.') /* FIXME? SGI Workshop kludge. */
+ n += 1;
+ subtype_info += 1;
+ }
+ else
+ {
+ int ok;
+ strcpy (name_buf + prefix_len, "___L");
+ L = get_int_var_value (name_buf, &ok);
+ if (!ok)
+ {
+ lim_warning ("Unknown lower bound, using 1.", 1);
+ L = 1;
+ }
+ }
if (*subtype_info == 'U')
- {
- if (!ada_scan_number (bounds_str, n, &U, &n)
- && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
- return raw_type;
- }
- else
- {
- strcpy (name_buf + prefix_len, "___U");
- U = get_int_var_value (name_buf, "Index bound unknown.", NULL);
- }
+ {
+ if (!ada_scan_number (bounds_str, n, &U, &n)
+ && !scan_discrim_bound (bounds_str, n, dval, &U, &n))
+ return raw_type;
+ }
+ else
+ {
+ int ok;
+ strcpy (name_buf + prefix_len, "___U");
+ U = get_int_var_value (name_buf, &ok);
+ if (!ok)
+ {
+ lim_warning ("Unknown upper bound, using %ld.", (long) L);
+ U = L;
+ }
+ }
if (objfile == NULL)
- objfile = TYPE_OBJFILE (base_type);
+ objfile = TYPE_OBJFILE (base_type);
type = create_range_type (alloc_type (objfile), base_type, L, U);
TYPE_NAME (type) = name;
return type;
}
}
-/* True iff NAME is the name of a range type. */
+/* True iff NAME is the name of a range type. */
+
int
ada_is_range_type_name (const char *name)
{
@@ -7882,31 +9714,246 @@ ada_is_range_type_name (const char *name
}
- /* Modular types */
+ /* Modular types */
+
+/* True iff TYPE is an Ada modular type. */
-/* True iff TYPE is an Ada modular type. */
int
ada_is_modular_type (struct type *type)
{
- /* FIXME: base_type should be declared in gdbtypes.h, implemented in
- valarith.c */
- struct type *subranged_type; /* = base_type (type); */
+ struct type *subranged_type = base_type (type);
return (subranged_type != NULL && TYPE_CODE (type) == TYPE_CODE_RANGE
- && TYPE_CODE (subranged_type) != TYPE_CODE_ENUM
- && TYPE_UNSIGNED (subranged_type));
+ && TYPE_CODE (subranged_type) != TYPE_CODE_ENUM
+ && TYPE_UNSIGNED (subranged_type));
}
-/* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
+/* Assuming ada_is_modular_type (TYPE), the modulus of TYPE. */
+
LONGEST
ada_modulus (struct type * type)
{
return TYPE_HIGH_BOUND (type) + 1;
}
+ /* Operators */
+/* Information about operators given special treatment in functions
+ below. */
+/* Format: OP_DEFN (<operator>, <operator length>, <# args>, <binop>). */
+
+#define ADA_OPERATORS \
+ OP_DEFN (OP_VAR_VALUE, 4, 0, 0) \
+ OP_DEFN (BINOP_IN_BOUNDS, 3, 2, 0) \
+ OP_DEFN (TERNOP_IN_RANGE, 1, 3, 0) \
+ OP_DEFN (OP_ATR_FIRST, 1, 2, 0) \
+ OP_DEFN (OP_ATR_LAST, 1, 2, 0) \
+ OP_DEFN (OP_ATR_LENGTH, 1, 2, 0) \
+ OP_DEFN (OP_ATR_IMAGE, 1, 2, 0) \
+ OP_DEFN (OP_ATR_MAX, 1, 3, 0) \
+ OP_DEFN (OP_ATR_MIN, 1, 3, 0) \
+ OP_DEFN (OP_ATR_MODULUS, 1, 1, 0) \
+ OP_DEFN (OP_ATR_POS, 1, 2, 0) \
+ OP_DEFN (OP_ATR_SIZE, 1, 1, 0) \
+ OP_DEFN (OP_ATR_TAG, 1, 1, 0) \
+ OP_DEFN (OP_ATR_VAL, 1, 2, 0) \
+ OP_DEFN (UNOP_QUAL, 3, 1, 0) \
+ OP_DEFN (UNOP_IN_RANGE, 3, 1, 0)
+
+static void
+ada_operator_length (struct expression *exp, int pc, int *oplenp, int *argsp)
+{
+ switch (exp->elts[pc - 1].opcode)
+ {
+ default:
+ operator_length_standard (exp, pc, oplenp, argsp);
+ break;
+
+#define OP_DEFN(op, len, args, binop) \
+ case op: *oplenp = len; *argsp = args; break;
+ ADA_OPERATORS;
+#undef OP_DEFN
+ }
+}
+
+static char *
+ada_op_name (enum exp_opcode opcode)
+{
+ switch (opcode)
+ {
+ default:
+ return op_name_standard (opcode);
+#define OP_DEFN(op, len, args, binop) case op: return #op;
+ ADA_OPERATORS;
+#undef OP_DEFN
+ }
+}
+
+/* As for operator_length, but assumes PC is pointing at the first
+ element of the operator, and gives meaningful results only for the
+ Ada-specific operators. */
+
+static void
+ada_forward_operator_length (struct expression *exp, int pc,
+ int *oplenp, int *argsp)
+{
+ switch (exp->elts[pc].opcode)
+ {
+ default:
+ *oplenp = *argsp = 0;
+ break;
+#define OP_DEFN(op, len, args, binop) \
+ case op: *oplenp = len; *argsp = args; break;
+ ADA_OPERATORS;
+#undef OP_DEFN
+ }
+}
+
+static int
+ada_dump_subexp_body (struct expression *exp, struct ui_file *stream, int elt)
+{
+ enum exp_opcode op = exp->elts[elt].opcode;
+ int oplen, nargs;
+ int pc = elt;
+ int i;
+
+ ada_forward_operator_length (exp, elt, &oplen, &nargs);
+
+ switch (op)
+ {
+ /* Ada attributes ('Foo). */
+ case OP_ATR_FIRST:
+ case OP_ATR_LAST:
+ case OP_ATR_LENGTH:
+ case OP_ATR_IMAGE:
+ case OP_ATR_MAX:
+ case OP_ATR_MIN:
+ case OP_ATR_MODULUS:
+ case OP_ATR_POS:
+ case OP_ATR_SIZE:
+ case OP_ATR_TAG:
+ case OP_ATR_VAL:
+ break;
+
+ case UNOP_IN_RANGE:
+ case UNOP_QUAL:
+ fprintf_filtered (stream, "Type @");
+ gdb_print_host_address (exp->elts[pc + 1].type, stream);
+ fprintf_filtered (stream, " (");
+ type_print (exp->elts[pc + 1].type, NULL, stream, 0);
+ fprintf_filtered (stream, ")");
+ break;
+ case BINOP_IN_BOUNDS:
+ fprintf_filtered (stream, " (%d)", (int) exp->elts[pc + 2].longconst);
+ break;
+ case TERNOP_IN_RANGE:
+ break;
+
+ default:
+ return dump_subexp_body_standard (exp, stream, elt);
+ }
+
+ elt += oplen;
+ for (i = 0; i < nargs; i += 1)
+ elt = dump_subexp (exp, stream, elt);
+
+ return elt;
+}
+/* The Ada extension of print_subexp (q.v.). */
+
+static void
+ada_print_subexp (struct expression *exp, int *pos,
+ struct ui_file *stream, enum precedence prec)
+{
+ int oplen, nargs;
+ int pc = *pos;
+ enum exp_opcode op = exp->elts[pc].opcode;
+
+ ada_forward_operator_length (exp, pc, &oplen, &nargs);
+
+ switch (op)
+ {
+ default:
+ print_subexp_standard (exp, pos, stream, prec);
+ return;
+
+ case OP_VAR_VALUE:
+ *pos += oplen;
+ fputs_filtered (SYMBOL_NATURAL_NAME (exp->elts[pc + 2].symbol), stream);
+ return;
+
+ case BINOP_IN_BOUNDS:
+ *pos += oplen;
+ print_subexp (exp, pos, stream, PREC_SUFFIX);
+ fputs_filtered (" in ", stream);
+ print_subexp (exp, pos, stream, PREC_SUFFIX);
+ fputs_filtered ("'range", stream);
+ if (exp->elts[pc + 1].longconst > 1)
+ fprintf_filtered (stream, "(%ld)", (long) exp->elts[pc + 1].longconst);
+ return;
+
+ case TERNOP_IN_RANGE:
+ *pos += oplen;
+ if (prec >= PREC_EQUAL)
+ fputs_filtered ("(", stream);
+ print_subexp (exp, pos, stream, PREC_SUFFIX);
+ fputs_filtered (" in ", stream);
+ print_subexp (exp, pos, stream, PREC_EQUAL);
+ fputs_filtered (" .. ", stream);
+ print_subexp (exp, pos, stream, PREC_EQUAL);
+ if (prec >= PREC_EQUAL)
+ fputs_filtered (")", stream);
+ return;
+
+ case OP_ATR_FIRST:
+ case OP_ATR_LAST:
+ case OP_ATR_LENGTH:
+ case OP_ATR_IMAGE:
+ case OP_ATR_MAX:
+ case OP_ATR_MIN:
+ case OP_ATR_MODULUS:
+ case OP_ATR_POS:
+ case OP_ATR_SIZE:
+ case OP_ATR_TAG:
+ case OP_ATR_VAL:
+ *pos += oplen;
+ if (exp->elts[*pos].opcode == OP_TYPE)
+ {
+ if (TYPE_CODE (exp->elts[*pos + 1].type) != TYPE_CODE_VOID)
+ LA_PRINT_TYPE (exp->elts[*pos + 1].type, "", stream, 0, 0);
+ *pos += 3;
+ }
+ else
+ print_subexp (exp, pos, stream, PREC_SUFFIX);
+ fprintf_filtered (stream, "'%s", ada_attribute_name (op));
+ if (nargs > 1)
+ {
+ int tem;
+ for (tem = 1; tem < nargs; tem += 1)
+ {
+ fputs_filtered ( (tem == 1) ? " (" : ", ", stream);
+ print_subexp (exp, pos, stream, PREC_ABOVE_COMMA);
+ }
+ fputs_filtered (")", stream);
+ }
+ return;
- /* Operators */
+ case UNOP_QUAL:
+ *pos += oplen;
+ type_print (exp->elts[pc + 1].type, "", stream, 0);
+ fputs_filtered ("'(", stream);
+ print_subexp (exp, pos, stream, PREC_PREFIX);
+ fputs_filtered (")", stream);
+ return;
+
+ case UNOP_IN_RANGE:
+ *pos += oplen;
+ print_subexp (exp, pos, stream, PREC_SUFFIX);
+ fputs_filtered (" in ", stream);
+ LA_PRINT_TYPE (exp->elts[pc + 1].type, "", stream, 1, 0);
+ return;
+ }
+}
/* Table mapping opcodes into strings for printing operators
and precedences of the operators. */
@@ -7940,12 +9987,13 @@ static const struct op_print ada_op_prin
{"not ", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
{"not ", UNOP_COMPLEMENT, PREC_PREFIX, 0},
{"abs ", UNOP_ABS, PREC_PREFIX, 0},
- {".all", UNOP_IND, PREC_SUFFIX, 1}, /* FIXME: postfix .ALL */
- {"'access", UNOP_ADDR, PREC_SUFFIX, 1}, /* FIXME: postfix 'ACCESS */
+ {".all", UNOP_IND, PREC_SUFFIX, 1},
+ {"'access", UNOP_ADDR, PREC_SUFFIX, 1},
+ {"'size", OP_ATR_SIZE, PREC_SUFFIX, 1},
{NULL, 0, 0, 0}
};
- /* Assorted Types and Interfaces */
+ /* Assorted Types and Interfaces */
struct type *builtin_type_ada_int;
struct type *builtin_type_ada_short;
@@ -7961,54 +10009,76 @@ struct type *builtin_type_ada_system_add
struct type **const (ada_builtin_types[]) =
{
-
&builtin_type_ada_int,
- &builtin_type_ada_long,
- &builtin_type_ada_short,
- &builtin_type_ada_char,
- &builtin_type_ada_float,
- &builtin_type_ada_double,
- &builtin_type_ada_long_long,
- &builtin_type_ada_long_double,
- &builtin_type_ada_natural, &builtin_type_ada_positive,
- /* The following types are carried over from C for convenience. */
-&builtin_type_int,
- &builtin_type_long,
- &builtin_type_short,
- &builtin_type_char,
- &builtin_type_float,
- &builtin_type_double,
- &builtin_type_long_long,
- &builtin_type_void,
- &builtin_type_signed_char,
- &builtin_type_unsigned_char,
- &builtin_type_unsigned_short,
- &builtin_type_unsigned_int,
- &builtin_type_unsigned_long,
- &builtin_type_unsigned_long_long,
- &builtin_type_long_double,
- &builtin_type_complex, &builtin_type_double_complex, 0};
+ &builtin_type_ada_long,
+ &builtin_type_ada_short,
+ &builtin_type_ada_char,
+ &builtin_type_ada_float,
+ &builtin_type_ada_double,
+ &builtin_type_ada_long_long,
+ &builtin_type_ada_long_double,
+ &builtin_type_ada_natural, &builtin_type_ada_positive,
+ /* The following types are carried over from C for convenience. */
+ &builtin_type_int,
+ &builtin_type_long,
+ &builtin_type_short,
+ &builtin_type_char,
+ &builtin_type_float,
+ &builtin_type_double,
+ &builtin_type_long_long,
+ &builtin_type_void,
+ &builtin_type_signed_char,
+ &builtin_type_unsigned_char,
+ &builtin_type_unsigned_short,
+ &builtin_type_unsigned_int,
+ &builtin_type_unsigned_long,
+ &builtin_type_unsigned_long_long,
+ &builtin_type_long_double,
+ &builtin_type_complex,
+ &builtin_type_double_complex,
+ 0
+};
+
+/* Not really used, but needed in the ada_language_defn. */
-/* Not really used, but needed in the ada_language_defn. */
static void
emit_char (int c, struct ui_file *stream, int quoter)
{
ada_emit_char (c, stream, quoter, 1);
}
+static int
+parse ()
+{
+ warnings_issued = 0;
+ return ada_parse ();
+}
+
+static const struct exp_descriptor ada_exp_descriptor =
+{
+ ada_print_subexp,
+ ada_operator_length,
+ ada_op_name,
+ ada_dump_subexp_body,
+ ada_evaluate_subexp
+};
+
const struct language_defn ada_language_defn = {
- "ada", /* Language name */
- /* language_ada, */
- language_unknown,
- /* FIXME: language_ada should be defined in defs.h */
+ "ada", /* Language name */
+ language_ada,
ada_builtin_types,
range_check_off,
type_check_off,
- case_sensitive_on, /* Yes, Ada is case-insensitive, but
- * that's not quite what this means. */
- ada_parse,
+ case_sensitive_on, /* Yes, Ada is case-insensitive, but
+ that's not quite what this means. */
+#ifdef GNAT_GDB
+ ada_lookup_symbol,
+ ada_lookup_minimal_symbol,
+#endif
+ &ada_exp_descriptor,
+ parse,
ada_error,
- ada_evaluate_subexp,
+ resolve,
ada_printchar, /* Print a character constant */
ada_printstr, /* Function to print string constant */
emit_char, /* Function to print single char (not used) */
@@ -8017,84 +10087,97 @@ const struct language_defn ada_language_
ada_val_print, /* Print a value using appropriate syntax */
ada_value_print, /* Print a top-level value */
NULL, /* Language specific skip_trampoline */
- value_of_this, /* value_of_this */
- basic_lookup_symbol_nonlocal, /* lookup_symbol_nonlocal */
+ NULL, /* value_of_this */
+ ada_lookup_symbol_nonlocal, /* Looking up non-local symbols. */
basic_lookup_transparent_type,/* lookup_transparent_type */
- NULL, /* Language specific symbol demangler */
+ ada_la_decode, /* Language specific symbol demangler */
{"", "", "", ""}, /* Binary format info */
#if 0
- {"8#%lo#", "8#", "o", "#"}, /* Octal format info */
- {"%ld", "", "d", ""}, /* Decimal format info */
- {"16#%lx#", "16#", "x", "#"}, /* Hex format info */
+ {"8#%lo#", "8#", "o", "#"}, /* Octal format info */
+ {"%ld", "", "d", ""}, /* Decimal format info */
+ {"16#%lx#", "16#", "x", "#"}, /* Hex format info */
#else
- /* Copied from c-lang.c. */
- {"0%lo", "0", "o", ""}, /* Octal format info */
- {"%ld", "", "d", ""}, /* Decimal format info */
- {"0x%lx", "0x", "x", ""}, /* Hex format info */
+ /* Copied from c-lang.c. */
+ {"0%lo", "0", "o", ""}, /* Octal format info */
+ {"%ld", "", "d", ""}, /* Decimal format info */
+ {"0x%lx", "0x", "x", ""}, /* Hex format info */
#endif
- ada_op_print_tab, /* expression operators for printing */
- 1, /* c-style arrays (FIXME?) */
- 0, /* String lower bound (FIXME?) */
+ ada_op_print_tab, /* expression operators for printing */
+ 0, /* c-style arrays */
+ 1, /* String lower bound */
&builtin_type_ada_char,
- default_word_break_characters,
+ ada_get_gdb_completer_word_break_characters,
+#ifdef GNAT_GDB
+ ada_translate_error_message, /* Substitute Ada-specific terminology
+ in errors and warnings. */
+#endif
LANG_MAGIC
};
-void
-_initialize_ada_language (void)
-{
+static void
+build_ada_types (void) {
builtin_type_ada_int =
init_type (TYPE_CODE_INT, TARGET_INT_BIT / TARGET_CHAR_BIT,
- 0, "integer", (struct objfile *) NULL);
+ 0, "integer", (struct objfile *) NULL);
builtin_type_ada_long =
init_type (TYPE_CODE_INT, TARGET_LONG_BIT / TARGET_CHAR_BIT,
- 0, "long_integer", (struct objfile *) NULL);
+ 0, "long_integer", (struct objfile *) NULL);
builtin_type_ada_short =
init_type (TYPE_CODE_INT, TARGET_SHORT_BIT / TARGET_CHAR_BIT,
- 0, "short_integer", (struct objfile *) NULL);
+ 0, "short_integer", (struct objfile *) NULL);
builtin_type_ada_char =
init_type (TYPE_CODE_INT, TARGET_CHAR_BIT / TARGET_CHAR_BIT,
- 0, "character", (struct objfile *) NULL);
+ 0, "character", (struct objfile *) NULL);
builtin_type_ada_float =
init_type (TYPE_CODE_FLT, TARGET_FLOAT_BIT / TARGET_CHAR_BIT,
- 0, "float", (struct objfile *) NULL);
+ 0, "float", (struct objfile *) NULL);
builtin_type_ada_double =
init_type (TYPE_CODE_FLT, TARGET_DOUBLE_BIT / TARGET_CHAR_BIT,
- 0, "long_float", (struct objfile *) NULL);
+ 0, "long_float", (struct objfile *) NULL);
builtin_type_ada_long_long =
init_type (TYPE_CODE_INT, TARGET_LONG_LONG_BIT / TARGET_CHAR_BIT,
- 0, "long_long_integer", (struct objfile *) NULL);
+ 0, "long_long_integer", (struct objfile *) NULL);
builtin_type_ada_long_double =
init_type (TYPE_CODE_FLT, TARGET_LONG_DOUBLE_BIT / TARGET_CHAR_BIT,
- 0, "long_long_float", (struct objfile *) NULL);
+ 0, "long_long_float", (struct objfile *) NULL);
builtin_type_ada_natural =
init_type (TYPE_CODE_INT, TARGET_INT_BIT / TARGET_CHAR_BIT,
- 0, "natural", (struct objfile *) NULL);
+ 0, "natural", (struct objfile *) NULL);
builtin_type_ada_positive =
init_type (TYPE_CODE_INT, TARGET_INT_BIT / TARGET_CHAR_BIT,
- 0, "positive", (struct objfile *) NULL);
+ 0, "positive", (struct objfile *) NULL);
builtin_type_ada_system_address =
lookup_pointer_type (init_type (TYPE_CODE_VOID, 1, 0, "void",
- (struct objfile *) NULL));
+ (struct objfile *) NULL));
TYPE_NAME (builtin_type_ada_system_address) = "system__address";
+}
+
+void
+_initialize_ada_language (void)
+{
+ build_ada_types ();
+ deprecated_register_gdbarch_swap (NULL, 0, build_ada_types);
add_language (&ada_language_defn);
+#ifdef GNAT_GDB
add_show_from_set
(add_set_cmd ("varsize-limit", class_support, var_uinteger,
- (char *) &varsize_limit,
- "Set maximum bytes in dynamic-sized object.",
- &setlist), &showlist);
+ (char *) &varsize_limit,
+ "Set maximum bytes in dynamic-sized object.",
+ &setlist), &showlist);
+#endif
varsize_limit = 65536;
- add_com ("begin", class_breakpoint, begin_command,
- "Start the debugged program, stopping at the beginning of the\n\
-main program. You may specify command-line arguments to give it, as for\n\
-the \"run\" command (q.v.).");
-}
+ obstack_init (&symbol_list_obstack);
+ obstack_init (&cache_space);
+ decoded_names_store = htab_create_alloc_ex
+ (256, htab_hash_string, (int (*) (const void *, const void *)) streq,
+ NULL, NULL, xmcalloc, xmfree);
+}
/* Create a fundamental Ada type using default reasonable for the current
target machine.
@@ -8130,104 +10213,104 @@ ada_create_fundamental_type (struct objf
/* FIXME: For now, if we are asked to produce a type not in this
language, create the equivalent of a C integer type with the
name "<?type?>". When all the dust settles from the type
- reconstruction work, this should probably become an error. */
+ reconstruction work, this should probably become an error. */
type = init_type (TYPE_CODE_INT,
- TARGET_INT_BIT / TARGET_CHAR_BIT,
- 0, "<?type?>", objfile);
+ TARGET_INT_BIT / TARGET_CHAR_BIT,
+ 0, "<?type?>", objfile);
warning ("internal error: no Ada fundamental type %d", typeid);
break;
case FT_VOID:
type = init_type (TYPE_CODE_VOID,
- TARGET_CHAR_BIT / TARGET_CHAR_BIT,
- 0, "void", objfile);
+ TARGET_CHAR_BIT / TARGET_CHAR_BIT,
+ 0, "void", objfile);
break;
case FT_CHAR:
type = init_type (TYPE_CODE_INT,
- TARGET_CHAR_BIT / TARGET_CHAR_BIT,
- 0, "character", objfile);
+ TARGET_CHAR_BIT / TARGET_CHAR_BIT,
+ 0, "character", objfile);
break;
case FT_SIGNED_CHAR:
type = init_type (TYPE_CODE_INT,
- TARGET_CHAR_BIT / TARGET_CHAR_BIT,
- 0, "signed char", objfile);
+ TARGET_CHAR_BIT / TARGET_CHAR_BIT,
+ 0, "signed char", objfile);
break;
case FT_UNSIGNED_CHAR:
type = init_type (TYPE_CODE_INT,
- TARGET_CHAR_BIT / TARGET_CHAR_BIT,
- TYPE_FLAG_UNSIGNED, "unsigned char", objfile);
+ TARGET_CHAR_BIT / TARGET_CHAR_BIT,
+ TYPE_FLAG_UNSIGNED, "unsigned char", objfile);
break;
case FT_SHORT:
type = init_type (TYPE_CODE_INT,
- TARGET_SHORT_BIT / TARGET_CHAR_BIT,
- 0, "short_integer", objfile);
+ TARGET_SHORT_BIT / TARGET_CHAR_BIT,
+ 0, "short_integer", objfile);
break;
case FT_SIGNED_SHORT:
type = init_type (TYPE_CODE_INT,
- TARGET_SHORT_BIT / TARGET_CHAR_BIT,
- 0, "short_integer", objfile);
+ TARGET_SHORT_BIT / TARGET_CHAR_BIT,
+ 0, "short_integer", objfile);
break;
case FT_UNSIGNED_SHORT:
type = init_type (TYPE_CODE_INT,
- TARGET_SHORT_BIT / TARGET_CHAR_BIT,
- TYPE_FLAG_UNSIGNED, "unsigned short", objfile);
+ TARGET_SHORT_BIT / TARGET_CHAR_BIT,
+ TYPE_FLAG_UNSIGNED, "unsigned short", objfile);
break;
case FT_INTEGER:
type = init_type (TYPE_CODE_INT,
- TARGET_INT_BIT / TARGET_CHAR_BIT,
- 0, "integer", objfile);
+ TARGET_INT_BIT / TARGET_CHAR_BIT,
+ 0, "integer", objfile);
break;
case FT_SIGNED_INTEGER:
- type = init_type (TYPE_CODE_INT, TARGET_INT_BIT / TARGET_CHAR_BIT, 0, "integer", objfile); /* FIXME -fnf */
+ type = init_type (TYPE_CODE_INT, TARGET_INT_BIT / TARGET_CHAR_BIT, 0, "integer", objfile); /* FIXME -fnf */
break;
case FT_UNSIGNED_INTEGER:
type = init_type (TYPE_CODE_INT,
- TARGET_INT_BIT / TARGET_CHAR_BIT,
- TYPE_FLAG_UNSIGNED, "unsigned int", objfile);
+ TARGET_INT_BIT / TARGET_CHAR_BIT,
+ TYPE_FLAG_UNSIGNED, "unsigned int", objfile);
break;
case FT_LONG:
type = init_type (TYPE_CODE_INT,
- TARGET_LONG_BIT / TARGET_CHAR_BIT,
- 0, "long_integer", objfile);
+ TARGET_LONG_BIT / TARGET_CHAR_BIT,
+ 0, "long_integer", objfile);
break;
case FT_SIGNED_LONG:
type = init_type (TYPE_CODE_INT,
- TARGET_LONG_BIT / TARGET_CHAR_BIT,
- 0, "long_integer", objfile);
+ TARGET_LONG_BIT / TARGET_CHAR_BIT,
+ 0, "long_integer", objfile);
break;
case FT_UNSIGNED_LONG:
type = init_type (TYPE_CODE_INT,
- TARGET_LONG_BIT / TARGET_CHAR_BIT,
- TYPE_FLAG_UNSIGNED, "unsigned long", objfile);
+ TARGET_LONG_BIT / TARGET_CHAR_BIT,
+ TYPE_FLAG_UNSIGNED, "unsigned long", objfile);
break;
case FT_LONG_LONG:
type = init_type (TYPE_CODE_INT,
- TARGET_LONG_LONG_BIT / TARGET_CHAR_BIT,
- 0, "long_long_integer", objfile);
+ TARGET_LONG_LONG_BIT / TARGET_CHAR_BIT,
+ 0, "long_long_integer", objfile);
break;
case FT_SIGNED_LONG_LONG:
type = init_type (TYPE_CODE_INT,
- TARGET_LONG_LONG_BIT / TARGET_CHAR_BIT,
- 0, "long_long_integer", objfile);
+ TARGET_LONG_LONG_BIT / TARGET_CHAR_BIT,
+ 0, "long_long_integer", objfile);
break;
case FT_UNSIGNED_LONG_LONG:
type = init_type (TYPE_CODE_INT,
- TARGET_LONG_LONG_BIT / TARGET_CHAR_BIT,
- TYPE_FLAG_UNSIGNED, "unsigned long long", objfile);
+ TARGET_LONG_LONG_BIT / TARGET_CHAR_BIT,
+ TYPE_FLAG_UNSIGNED, "unsigned long long", objfile);
break;
case FT_FLOAT:
type = init_type (TYPE_CODE_FLT,
- TARGET_FLOAT_BIT / TARGET_CHAR_BIT,
- 0, "float", objfile);
+ TARGET_FLOAT_BIT / TARGET_CHAR_BIT,
+ 0, "float", objfile);
break;
case FT_DBL_PREC_FLOAT:
type = init_type (TYPE_CODE_FLT,
- TARGET_DOUBLE_BIT / TARGET_CHAR_BIT,
- 0, "long_float", objfile);
+ TARGET_DOUBLE_BIT / TARGET_CHAR_BIT,
+ 0, "long_float", objfile);
break;
case FT_EXT_PREC_FLOAT:
type = init_type (TYPE_CODE_FLT,
- TARGET_LONG_DOUBLE_BIT / TARGET_CHAR_BIT,
- 0, "long_long_float", objfile);
+ TARGET_LONG_DOUBLE_BIT / TARGET_CHAR_BIT,
+ 0, "long_long_float", objfile);
break;
}
return (type);
@@ -8239,16 +10322,16 @@ ada_dump_symtab (struct symtab *s)
int i;
fprintf (stderr, "New symtab: [\n");
fprintf (stderr, " Name: %s/%s;\n",
- s->dirname ? s->dirname : "?", s->filename ? s->filename : "?");
+ s->dirname ? s->dirname : "?", s->filename ? s->filename : "?");
fprintf (stderr, " Format: %s;\n", s->debugformat);
if (s->linetable != NULL)
{
fprintf (stderr, " Line table (section %d):\n", s->block_line_section);
for (i = 0; i < s->linetable->nitems; i += 1)
- {
- struct linetable_entry *e = s->linetable->item + i;
- fprintf (stderr, " %4ld: %8lx\n", (long) e->line, (long) e->pc);
- }
+ {
+ struct linetable_entry *e = s->linetable->item + i;
+ fprintf (stderr, " %4ld: %8lx\n", (long) e->line, (long) e->pc);
+ }
}
fprintf (stderr, "]\n");
}
Index: gdb/ada-lang.h
===================================================================
RCS file: /cvs/src/src/gdb/ada-lang.h,v
retrieving revision 1.6
diff -u -p -r1.6 ada-lang.h
--- gdb/ada-lang.h 24 May 2003 03:21:42 -0000 1.6
+++ gdb/ada-lang.h 2 Jun 2004 09:52:56 -0000
@@ -1,5 +1,6 @@
/* Ada language support definitions for GDB, the GNU debugger.
- Copyright 1992, 1997 Free Software Foundation, Inc.
+ Copyright 1992, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004
+ Free Software Foundation, Inc.
This file is part of GDB.
@@ -24,130 +25,103 @@ struct partial_symbol;
#include "value.h"
#include "gdbtypes.h"
+#include "breakpoint.h"
-struct block;
+/* Names of specific files known to be part of the runtime
+ system and that might consider (confusing) debugging information.
+ Each name (a basic regular expression string) is followed by a
+ comma. FIXME: Should be part of a configuration file. */
+#if defined(__alpha__) && defined(__osf__) && !defined(VXWORKS_TARGET)
+#define ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS \
+ "^[agis]-.*\\.ad[bs]$", \
+ "/usr/shlib/libpthread\\.so",
+#elif defined (__linux__)
+#define ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS \
+ "^[agis]-.*\\.ad[bs]$", \
+ "/lib.*/libpthread\\.so[.0-9]*$", "/lib.*/libpthread\\.a$", \
+ "/lib.*/libc\\.so[.0-9]*$", "/lib.*/libc\\.a$",
+#endif
+
+#if !defined (ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS)
+#define ADA_KNOWN_RUNTIME_FILE_NAME_PATTERNS \
+ "^[agis]-.*\\.ad[bs]$",
+#endif
-/* A macro to reorder the bytes of an address depending on the
- endiannes of the target. */
-#define EXTRACT_ADDRESS(x) ((void *) extract_unsigned_integer (&(x), sizeof (x)))
-/* A macro to reorder the bytes of an int depending on the endiannes
- of the target */
-#define EXTRACT_INT(x) ((int) extract_signed_integer (&(x), sizeof (x)))
-
-/* Chain of cleanups for arguments of OP_UNRESOLVED_VALUE names. Created in
- yyparse and freed in ada_resolve. */
-extern struct cleanup *unresolved_names;
+/* Names of compiler-generated auxiliary functions probably of no
+ interest to users. Each name (a basic regular expression string)
+ is followed by a comma. */
+#define ADA_KNOWN_AUXILIARY_FUNCTION_NAME_PATTERNS \
+ "___clean[.a-zA-Z0-9_]*$",
+
+/* The maximum number of frame levels searched for non-local,
+ * non-global symbols. This limit exists as a precaution to prevent
+ * infinite search loops when the stack is screwed up. */
+#define MAX_ENCLOSING_FRAME_LEVELS 7
+
+/* Maximum number of steps followed in looking for the ultimate
+ referent of a renaming. This prevents certain infinite loops that
+ can otherwise result. */
+#define MAX_RENAMING_CHAIN_LENGTH 10
-/* Corresponding mangled/demangled names and opcodes for Ada user-definable
+struct block;
+
+/* Corresponding encoded/decoded names and opcodes for Ada user-definable
operators. */
struct ada_opname_map
{
- const char *mangled;
- const char *demangled;
+ const char *encoded;
+ const char *decoded;
enum exp_opcode op;
};
-/* Table of Ada operators in mangled and demangled forms. */
+/* Table of Ada operators in encoded and decoded forms. */
/* Defined in ada-lang.c */
extern const struct ada_opname_map ada_opname_table[];
-/* The maximum number of tasks known to the Ada runtime */
-extern const int MAX_NUMBER_OF_KNOWN_TASKS;
-
-/* Identifiers for Ada attributes that need special processing. Be sure
- to update the table attribute_names in ada-lang.c whenever you change this.
- */
-
-enum ada_attribute
-{
- /* Invalid attribute for error checking. */
- ATR_INVALID,
-
- ATR_FIRST,
- ATR_LAST,
- ATR_LENGTH,
- ATR_IMAGE,
- ATR_IMG,
- ATR_MAX,
- ATR_MIN,
- ATR_MODULUS,
- ATR_POS,
- ATR_SIZE,
- ATR_TAG,
- ATR_VAL,
-
- /* Dummy last attribute. */
- ATR_END
-};
-
-enum task_states
-{
- Unactivated,
- Runnable,
- Terminated,
- Activator_Sleep,
- Acceptor_Sleep,
- Entry_Caller_Sleep,
- Async_Select_Sleep,
- Delay_Sleep,
- Master_Completion_Sleep,
- Master_Phase_2_Sleep
-};
-
-extern char *ada_task_states[];
-
-typedef struct
-{
- char *P_ARRAY;
- int *P_BOUNDS;
-}
-fat_string;
-
-typedef struct entry_call
-{
- void *self;
-}
- *entry_call_link;
-
-struct task_fields
-{
- int entry_num;
-#if (defined (VXWORKS_TARGET) || !defined (i386)) \
- && !(defined (VXWORKS_TARGET) && defined (M68K_TARGET))
- int pad1;
-#endif
- char state;
-#if (defined (VXWORKS_TARGET) && defined (M68K_TARGET))
- char pad_8bits;
-#endif
- void *parent;
- int priority;
- int current_priority;
- fat_string image;
- entry_call_link call;
-#if (defined (sun) && defined (__SVR4)) && !defined (VXWORKS_TARGET)
- int pad2;
- unsigned thread;
- unsigned lwp;
-#else
- void *thread;
- void *lwp;
-#endif
-}
-#if (defined (VXWORKS_TARGET) && defined (M68K_TARGET))
-__attribute__ ((packed))
-#endif
- ;
-
-struct task_entry
-{
- void *task_id;
- int task_num;
- int known_tasks_index;
- struct task_entry *next_task;
- void *thread;
- void *lwp;
- int stack_per;
+enum ada_operator
+ {
+ /* X IN A'RANGE(N). N is an immediate operand, surrounded by
+ BINOP_IN_BOUNDS before and after. A is an array, X an index
+ value. Evaluates to true iff X is within range of the Nth
+ dimension (1-based) of A. (A multi-dimensional array
+ type is represented as array of array of ...) */
+ BINOP_IN_BOUNDS = OP_EXTENDED0,
+
+ /* X IN L .. U. True iff L <= X <= U. */
+ TERNOP_IN_RANGE,
+
+ /* Ada attributes ('Foo). */
+ OP_ATR_FIRST,
+ OP_ATR_LAST,
+ OP_ATR_LENGTH,
+ OP_ATR_IMAGE,
+ OP_ATR_MAX,
+ OP_ATR_MIN,
+ OP_ATR_MODULUS,
+ OP_ATR_POS,
+ OP_ATR_SIZE,
+ OP_ATR_TAG,
+ OP_ATR_VAL,
+
+ /* Ada type qualification. It is encoded as for UNOP_CAST, above,
+ and denotes the TYPE'(EXPR) construct. */
+ UNOP_QUAL,
+
+ /* X IN TYPE. The `TYPE' argument is immediate, with
+ UNOP_IN_RANGE before and after it. True iff X is a member of
+ type TYPE (typically a subrange). */
+ UNOP_IN_RANGE,
+
+ /* End marker */
+ OP_ADA_LAST
+ };
+
+/* A triple, (symbol, block, symtab), representing one instance of a
+ * symbol-lookup operation. */
+struct ada_symbol_info {
+ struct symbol* sym;
+ struct block* block;
+ struct symtab* symtab;
};
extern struct type *builtin_type_ada_int;
@@ -162,33 +136,40 @@ extern struct type *builtin_type_ada_nat
extern struct type *builtin_type_ada_positive;
extern struct type *builtin_type_ada_system_address;
-/* Assuming V points to an array of S objects, make sure that it contains at
+/* The maximum number of tasks known to the Ada runtime */
+extern const int MAX_NUMBER_OF_KNOWN_TASKS;
+
+/* Assuming V points to an array of S objects, make sure that it contains at
least M objects, updating V and S as necessary. */
-#define GROW_VECT(v, s, m) \
+#define GROW_VECT(v, s, m) \
if ((s) < (m)) grow_vect ((void**) &(v), &(s), (m), sizeof(*(v)));
extern void grow_vect (void **, size_t *, size_t, int);
-extern int ada_parse (void); /* Defined in ada-exp.y */
+extern int ada_get_field_index (const struct type *type,
+ const char *field_name,
+ int maybe_missing);
+
+extern int ada_parse (void); /* Defined in ada-exp.y */
-extern void ada_error (char *); /* Defined in ada-exp.y */
+extern void ada_error (char *); /* Defined in ada-exp.y */
- /* Defined in ada-typeprint.c */
+ /* Defined in ada-typeprint.c */
extern void ada_print_type (struct type *, char *, struct ui_file *, int,
- int);
+ int);
extern int ada_val_print (struct type *, char *, int, CORE_ADDR,
- struct ui_file *, int, int, int,
- enum val_prettyprint);
+ struct ui_file *, int, int, int,
+ enum val_prettyprint);
extern int ada_value_print (struct value *, struct ui_file *, int,
- enum val_prettyprint);
+ enum val_prettyprint);
- /* Defined in ada-lang.c */
+ /* Defined in ada-lang.c */
extern struct value *value_from_contents_and_address (struct type *, char *,
- CORE_ADDR);
+ CORE_ADDR);
extern void ada_emit_char (int, struct ui_file *, int, int);
@@ -197,10 +178,10 @@ extern void ada_printchar (int, struct u
extern void ada_printstr (struct ui_file *, char *, unsigned int, int, int);
extern void ada_convert_actuals (struct value *, int, struct value **,
- CORE_ADDR *);
+ CORE_ADDR *);
extern struct value *ada_value_subscript (struct value *, int,
- struct value **);
+ struct value **);
extern struct type *ada_array_element_type (struct type *, int);
@@ -208,13 +189,11 @@ extern int ada_array_arity (struct type
struct type *ada_type_of_array (struct value *, int);
-extern struct value *ada_coerce_to_simple_array (struct value *);
-
extern struct value *ada_coerce_to_simple_array_ptr (struct value *);
-extern int ada_is_simple_array (struct type *);
+extern int ada_is_simple_array_type (struct type *);
-extern int ada_is_array_descriptor (struct type *);
+extern int ada_is_array_descriptor_type (struct type *);
extern int ada_is_bogus_array_descriptor (struct type *);
@@ -222,34 +201,43 @@ extern struct type *ada_index_type (stru
extern struct value *ada_array_bound (struct value *, int, int);
-extern int ada_lookup_symbol_list (const char *, struct block *,
- domain_enum, struct symbol ***,
- struct block ***);
+extern char *ada_decode_symbol (const struct general_symbol_info*);
-extern char *ada_fold_name (const char *);
+extern const char *ada_decode (const char*);
+
+extern enum language ada_update_initial_language (enum language,
+ struct partial_symtab*);
-extern struct symbol *ada_lookup_symbol (const char *, struct block *,
- domain_enum);
+extern void clear_ada_sym_cache (void);
-extern struct minimal_symbol *ada_lookup_minimal_symbol (const char *);
+extern char **ada_make_symbol_completion_list (const char *text0,
+ const char *word);
-extern void ada_resolve (struct expression **, struct type *);
+extern int ada_lookup_symbol_list (const char *, const struct block *,
+ domain_enum, struct ada_symbol_info**);
+
+extern char *ada_fold_name (const char *);
-extern int ada_resolve_function (struct symbol **, struct block **, int,
- struct value **, int, const char *,
- struct type *);
+extern struct symbol *ada_lookup_symbol (const char *, const struct block *,
+ domain_enum, int *,
+ struct symtab **);
+
+extern struct minimal_symbol *ada_lookup_simple_minsym (const char *);
extern void ada_fill_in_ada_prototype (struct symbol *);
-extern int user_select_syms (struct symbol **, struct block **, int, int);
+extern int user_select_syms (struct ada_symbol_info *, int, int);
extern int get_selections (int *, int, int, int, char *);
extern char *ada_start_decode_line_1 (char *);
extern struct symtabs_and_lines ada_finish_decode_line_1 (char **,
- struct symtab *,
- int, char ***);
+ struct symtab *,
+ int, char ***);
+
+extern struct symtabs_and_lines ada_sals_for_line (const char*, int,
+ int, char***, int);
extern int ada_scan_number (const char *, int, LONGEST *, int *);
@@ -260,8 +248,8 @@ extern int ada_is_ignored_field (struct
extern int ada_is_packed_array_type (struct type *);
extern struct value *ada_value_primitive_packed_val (struct value *, char *,
- long, int, int,
- struct type *);
+ long, int, int,
+ struct type *);
extern struct type *ada_coerce_to_simple_array_type (struct type *);
@@ -269,12 +257,16 @@ extern int ada_is_character_type (struct
extern int ada_is_string_type (struct type *);
-extern int ada_is_tagged_type (struct type *);
+extern int ada_is_tagged_type (struct type *, int);
+
+extern int ada_is_tag_type (struct type *);
extern struct type *ada_tag_type (struct value *);
extern struct value *ada_value_tag (struct value *);
+extern const char *ada_tag_name (struct value *);
+
extern int ada_is_parent_field (struct type *, int);
extern int ada_is_wrapper_field (struct type *, int);
@@ -289,24 +281,20 @@ extern int ada_in_variant (LONGEST, stru
extern char *ada_variant_discrim_name (struct type *);
-extern struct type *ada_lookup_struct_elt_type (struct type *, char *, int,
- int *);
-
extern struct value *ada_value_struct_elt (struct value *, char *, char *);
-extern struct value *ada_search_struct_field (char *, struct value *, int,
- struct type *);
-
extern int ada_is_aligner_type (struct type *);
extern struct type *ada_aligned_type (struct type *);
extern char *ada_aligned_value_addr (struct type *, char *);
-extern const char *ada_attribute_name (int);
+extern const char *ada_attribute_name (enum exp_opcode);
extern int ada_is_fixed_point_type (struct type *);
+extern int ada_is_system_address_type (struct type *);
+
extern DOUBLEST ada_delta (struct type *);
extern DOUBLEST ada_fixed_to_float (struct type *, LONGEST);
@@ -323,30 +311,37 @@ extern struct type *ada_system_address_t
extern int ada_which_variant_applies (struct type *, struct type *, char *);
-extern struct value *ada_to_fixed_value (struct type *, char *, CORE_ADDR,
- struct value *);
-
extern struct type *ada_to_fixed_type (struct type *, char *, CORE_ADDR,
- struct value *);
+ struct value *);
+
+extern struct type *
+ ada_template_to_fixed_record_type_1 (struct type *type, char *valaddr,
+ CORE_ADDR address, struct value *dval0,
+ int keep_dynamic_fields);
extern int ada_name_prefix_len (const char *);
extern char *ada_type_name (struct type *);
extern struct type *ada_find_parallel_type (struct type *,
- const char *suffix);
+ const char *suffix);
+
+extern LONGEST get_int_var_value (char *, int *);
-extern LONGEST get_int_var_value (char *, char *, int *);
+extern struct symbol *ada_find_any_symbol (const char *name);
extern struct type *ada_find_any_type (const char *name);
+extern struct symbol *ada_find_renaming_symbol (const char *name,
+ struct block *block);
+
extern int ada_prefer_type (struct type *, struct type *);
extern struct type *ada_get_base_type (struct type *);
extern struct type *ada_completed_type (struct type *);
-extern char *ada_mangle (const char *);
+extern char *ada_encode (const char *);
extern const char *ada_enum_name (const char *);
@@ -364,29 +359,38 @@ extern const char *ada_renaming_type (st
extern int ada_is_object_renaming (struct symbol *);
-extern const char *ada_simple_renamed_entity (struct symbol *);
+extern char *ada_simple_renamed_entity (struct symbol *);
extern char *ada_breakpoint_rewrite (char *, int *);
+extern char *ada_main_name (void);
+
/* Tasking-related: ada-tasks.c */
extern int valid_task_id (int);
-extern int get_current_task (void);
-
extern void init_task_list (void);
-extern void *get_self_id (void);
+extern int ada_is_exception_breakpoint (bpstat bs);
+
+extern void ada_adjust_exception_stop (bpstat bs);
-extern int get_current_task (void);
+extern void ada_print_exception_stop (bpstat bs);
-extern int get_entry_number (void *);
+extern int ada_get_current_task (ptid_t);
-extern void ada_report_exception_break (struct breakpoint *);
+extern int breakpoint_ada_task_match (CORE_ADDR, ptid_t);
+
+extern int ada_print_exception_breakpoint_nontask (struct breakpoint *);
+
+extern void ada_print_exception_breakpoint_task (struct breakpoint *);
extern int ada_maybe_exception_partial_symbol (struct partial_symbol *sym);
extern int ada_is_exception_sym (struct symbol *sym);
+extern void ada_find_printable_frame (struct frame_info *fi);
+
+extern void ada_reset_thread_registers (void);
#endif