From gdb-patches-return-33536-listarch-gdb-patches=sources dot redhat dot com at sources dot redhat dot com Wed Jun 02 10:17:17 2004 Return-Path: Delivered-To: listarch-gdb-patches at sources dot redhat dot com Received: (qmail 11944 invoked by alias); 2 Jun 2004 10:17:15 -0000 Mailing-List: contact gdb-patches-help at sources dot redhat dot com; run by ezmlm Precedence: bulk List-Subscribe: List-Archive: List-Post: List-Help: , Sender: gdb-patches-owner at sources dot redhat dot com Delivered-To: mailing list gdb-patches at sources dot redhat dot com Received: (qmail 11801 invoked from network); 2 Jun 2004 10:16:55 -0000 Received: from unknown (HELO nile.gnat.com) (205.232.38.5) by sourceware dot org with SMTP; 2 Jun 2004 10:16:55 -0000 Received: from localhost (localhost [127.0.0.1]) by nile dot gnat dot com (Postfix) with ESMTP id E93EEF28CC for ; Wed, 2 Jun 2004 06:16:49 -0400 (EDT) Received: from nile.gnat.com ([127.0.0.1]) by localhost (nile dot gnat dot com [127 dot 0 dot 0 dot 1]) (amavisd-new, port 10024) with LMTP id 16597-01-4 for ; Wed, 2 Jun 2004 06:16:49 -0400 (EDT) Received: by nile.gnat.com (Postfix, from userid 1345) id 1C85DF28D3; Wed, 2 Jun 2004 06:16:49 -0400 (EDT) From: Paul Hilfinger To: gdb-patches at sources dot redhat dot com Subject: [PATCH]: Updates to Ada sources, part 2b (long) Message-Id: <20040602101649.1C85DF28D3@nile.gnat.com> Date: Wed, 2 Jun 2004 06:16:49 -0400 (EDT) X-Virus-Scanned: by amavisd-new at nile.gnat.com 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 (, , <# args>, ). */ + +#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 "". 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, "", objfile); + TARGET_INT_BIT / TARGET_CHAR_BIT, + 0, "", 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