enum noside noside,
enum exp_opcode opcode,
struct value *arg1, struct value *arg2);
+
+/* Implement expression evaluation for Fortran's CEILING intrinsic function
+ called with one argument. For EXPECT_TYPE, EXP, and NOSIDE see
+ expression::evaluate (in expression.h). OPCODE will always be
+ FORTRAN_CEILING and ARG1 is the argument passed to CEILING. */
+
extern struct value *eval_op_f_ceil (struct type *expect_type,
struct expression *exp,
enum noside noside,
enum exp_opcode opcode,
struct value *arg1);
+
+/* Implement expression evaluation for Fortran's CEILING intrinsic function
+ called with two arguments. For EXPECT_TYPE, EXP, and NOSIDE see
+ expression::evaluate (in expression.h). OPCODE will always be
+ FORTRAN_CEILING, ARG1 is the first argument passed to CEILING, and KIND_ARG
+ is the type corresponding to the KIND parameter passed to CEILING. */
+
+extern value *eval_op_f_ceil (type *expect_type, expression *exp,
+ noside noside, exp_opcode opcode, value *arg1,
+ type *kind_arg);
+
+/* Implement expression evaluation for Fortran's FLOOR intrinsic function
+ called with one argument. For EXPECT_TYPE, EXP, and NOSIDE see
+ expression::evaluate (in expression.h). OPCODE will always be FORTRAN_FLOOR
+ and ARG1 is the argument passed to FLOOR. */
+
extern struct value *eval_op_f_floor (struct type *expect_type,
struct expression *exp,
enum noside noside,
enum exp_opcode opcode,
struct value *arg1);
+
+/* Implement expression evaluation for Fortran's FLOOR intrinsic function
+ called with two arguments. For EXPECT_TYPE, EXP, and NOSIDE see
+ expression::evaluate (in expression.h). OPCODE will always be
+ FORTRAN_FLOOR, ARG1 is the first argument passed to FLOOR, and KIND_ARG is
+ the type corresponding to the KIND parameter passed to FLOOR. */
+
+extern value *eval_op_f_floor (type *expect_type, expression *exp,
+ noside noside, exp_opcode opcode, value *arg1,
+ type *kind_arg);
+
extern struct value *eval_op_f_modulo (struct type *expect_type,
struct expression *exp,
enum noside noside,
enum exp_opcode opcode,
struct value *arg1, struct value *arg2);
+
+/* Implement expression evaluation for Fortran's CMPLX intrinsic function
+ called with one argument. For EXPECT_TYPE, EXP, and NOSIDE see
+ expression::evaluate (in expression.h). OPCODE will always be
+ FORTRAN_CMPLX and ARG1 is the argument passed to CMPLX if. */
+
+extern value *eval_op_f_cmplx (type *expect_type, expression *exp,
+ noside noside, exp_opcode opcode, value *arg1);
+
+/* Implement expression evaluation for Fortran's CMPLX intrinsic function
+ called with two arguments. For EXPECT_TYPE, EXP, and NOSIDE see
+ expression::evaluate (in expression.h). OPCODE will always be
+ FORTRAN_CMPLX, ARG1 and ARG2 are the arguments passed to CMPLX. */
+
extern struct value *eval_op_f_cmplx (struct type *expect_type,
struct expression *exp,
enum noside noside,
enum exp_opcode opcode,
struct value *arg1, struct value *arg2);
+
+/* Implement expression evaluation for Fortran's CMPLX intrinsic function
+ called with three arguments. For EXPECT_TYPE, EXP, and NOSIDE see
+ expression::evaluate (in expression.h). OPCODE will always be
+ FORTRAN_CMPLX, ARG1 and ARG2 are real and imaginary part passed to CMPLX,
+ and KIND_ARG is the type corresponding to the KIND parameter passed to
+ CMPLX. */
+
+extern value *eval_op_f_cmplx (type *expect_type, expression *exp,
+ noside noside, exp_opcode opcode, value *arg1,
+ value *arg2, type *kind_arg);
+
extern struct value *eval_op_f_kind (struct type *expect_type,
struct expression *exp,
enum noside noside,
/* Implement expression evaluation for Fortran's SIZE keyword. For
EXPECT_TYPE, EXP, and NOSIDE see expression::evaluate (in
- expression.h). OP will always for FORTRAN_ARRAY_SIZE. ARG1 is the
+ expression.h). OPCODE will always for FORTRAN_ARRAY_SIZE. ARG1 is the
value passed to SIZE if it is only passed a single argument. For the
two argument form see the overload of this function below. */
struct value *arg1,
struct value *arg2);
+/* Implement expression evaluation for Fortran's SIZE intrinsic function called
+ with three arguments. For EXPECT_TYPE, EXP, and NOSIDE see
+ expression::evaluate (in expression.h). OPCODE will always be
+ FORTRAN_ARRAY_SIZE, ARG1 and ARG2 the first two values passed to SIZE, and
+ KIND_ARG is the type corresponding to the KIND parameter passed to SIZE. */
+
+extern value *eval_op_f_array_size (type *expect_type, expression *exp,
+ noside noside, exp_opcode opcode,
+ value *arg1, value *arg2, type *kind_arg);
+
/* Implement the evaluation of Fortran's SHAPE keyword. EXPECTED_TYPE,
EXP, and NOSIDE are as for expression::evaluate (see expression.h). OP
will always be UNOP_FORTRAN_SHAPE, and ARG1 is the argument being passed
namespace expr
{
+/* Function prototype for Fortran intrinsic functions taking one argument and
+ one kind argument. */
+typedef value *binary_kind_ftype (type *expect_type, expression *exp,
+ noside noside, exp_opcode op, value *arg1,
+ type *kind_arg);
+
+/* Two-argument operation with the second argument being a kind argument. */
+template<exp_opcode OP, binary_kind_ftype FUNC>
+class fortran_kind_2arg
+ : public tuple_holding_operation<operation_up, type*>
+{
+public:
+
+ using tuple_holding_operation::tuple_holding_operation;
+
+ value *evaluate (type *expect_type, expression *exp, noside noside) override
+ {
+ value *arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
+ type *kind_arg = std::get<1> (m_storage);
+ return FUNC (expect_type, exp, noside, OP, arg1, kind_arg);
+ }
+
+ exp_opcode opcode () const override
+ { return OP; }
+};
+
+/* Function prototype for Fortran intrinsic functions taking two arguments and
+ one kind argument. */
+typedef value *ternary_kind_ftype (type *expect_type, expression *exp,
+ noside noside, exp_opcode op, value *arg1,
+ value *arg2, type *kind_arg);
+
+/* Three-argument operation with the third argument being a kind argument. */
+template<exp_opcode OP, ternary_kind_ftype FUNC>
+class fortran_kind_3arg
+ : public tuple_holding_operation<operation_up, operation_up, type *>
+{
+public:
+
+ using tuple_holding_operation::tuple_holding_operation;
+
+ value *evaluate (type *expect_type, expression *exp, noside noside) override
+ {
+ value *arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
+ value *arg2 = std::get<1> (m_storage)->evaluate (nullptr, exp, noside);
+ type *kind_arg = std::get<2> (m_storage);
+ return FUNC (expect_type, exp, noside, OP, arg1, arg2, kind_arg);
+ }
+
+ exp_opcode opcode () const override
+ { return OP; }
+};
+
using fortran_abs_operation = unop_operation<UNOP_ABS, eval_op_f_abs>;
-using fortran_ceil_operation = unop_operation<UNOP_FORTRAN_CEILING,
- eval_op_f_ceil>;
-using fortran_floor_operation = unop_operation<UNOP_FORTRAN_FLOOR,
- eval_op_f_floor>;
+using fortran_ceil_operation_1arg = unop_operation<FORTRAN_CEILING,
+ eval_op_f_ceil>;
+using fortran_ceil_operation_2arg = fortran_kind_2arg<FORTRAN_CEILING,
+ eval_op_f_ceil>;
+using fortran_floor_operation_1arg = unop_operation<FORTRAN_FLOOR,
+ eval_op_f_floor>;
+using fortran_floor_operation_2arg = fortran_kind_2arg<FORTRAN_FLOOR,
+ eval_op_f_floor>;
using fortran_kind_operation = unop_operation<UNOP_FORTRAN_KIND,
eval_op_f_kind>;
using fortran_allocated_operation = unop_operation<UNOP_FORTRAN_ALLOCATED,
eval_op_f_array_size>;
using fortran_array_size_2arg = binop_operation<FORTRAN_ARRAY_SIZE,
eval_op_f_array_size>;
+using fortran_array_size_3arg = fortran_kind_3arg<FORTRAN_ARRAY_SIZE,
+ eval_op_f_array_size>;
using fortran_array_shape_operation = unop_operation<UNOP_FORTRAN_SHAPE,
eval_op_f_array_shape>;
-
-/* The Fortran "complex" operation. */
-class fortran_cmplx_operation
- : public tuple_holding_operation<operation_up, operation_up>
-{
-public:
-
- using tuple_holding_operation::tuple_holding_operation;
-
- value *evaluate (struct type *expect_type,
- struct expression *exp,
- enum noside noside) override
- {
- value *arg1 = std::get<0> (m_storage)->evaluate (nullptr, exp, noside);
- value *arg2 = std::get<1> (m_storage)->evaluate (value_type (arg1),
- exp, noside);
- return eval_op_f_cmplx (expect_type, exp, noside, BINOP_FORTRAN_CMPLX,
- arg1, arg2);
- }
-
- enum exp_opcode opcode () const override
- { return BINOP_FORTRAN_CMPLX; }
-};
+using fortran_cmplx_operation_1arg = unop_operation<FORTRAN_CMPLX,
+ eval_op_f_cmplx>;
+using fortran_cmplx_operation_2arg = binop_operation<FORTRAN_CMPLX,
+ eval_op_f_cmplx>;
+using fortran_cmplx_operation_3arg = fortran_kind_3arg<FORTRAN_CMPLX,
+ eval_op_f_cmplx>;
/* OP_RANGE for Fortran. */
class fortran_range_operation
{ return std::get<0> (m_storage); }
};
+/* Three-argument form of Fortran ubound/lbound intrinsics. */
+class fortran_bound_3arg
+ : public tuple_holding_operation<exp_opcode, operation_up, operation_up,
+ type *>
+{
+public:
+
+ using tuple_holding_operation::tuple_holding_operation;
+
+ value *evaluate (type *expect_type, expression *exp, noside noside) override;
+
+ exp_opcode opcode () const override
+ { return std::get<0> (m_storage); }
+};
+
/* Implement STRUCTOP_STRUCT for Fortran. */
class fortran_structop_operation
: public structop_base_operation
static struct type *convert_to_kind_type (struct type *basetype, int kind);
+static void wrap_unop_intrinsic (exp_opcode opcode);
+
+static void wrap_binop_intrinsic (exp_opcode opcode);
+
+static void wrap_ternop_intrinsic (exp_opcode opcode);
+
+template<typename T>
+static void fortran_wrap2_kind (type *base_type);
+
+template<typename T>
+static void fortran_wrap3_kind (type *base_type);
+
using namespace expr;
%}
%token <opcode> ASSIGN_MODIFY
%token <opcode> UNOP_INTRINSIC BINOP_INTRINSIC
-%token <opcode> UNOP_OR_BINOP_INTRINSIC
+%token <opcode> UNOP_OR_BINOP_INTRINSIC UNOP_OR_BINOP_OR_TERNOP_INTRINSIC
%left ','
%left ABOVE_COMMA
{ pstate->wrap<fortran_kind_operation> (); }
;
-exp : UNOP_OR_BINOP_INTRINSIC '('
- { pstate->start_arglist (); }
- one_or_two_args ')'
- {
- int n = pstate->end_arglist ();
- gdb_assert (n == 1 || n == 2);
- if ($1 == FORTRAN_ASSOCIATED)
- {
- if (n == 1)
- pstate->wrap<fortran_associated_1arg> ();
- else
- pstate->wrap2<fortran_associated_2arg> ();
- }
- else if ($1 == FORTRAN_ARRAY_SIZE)
- {
- if (n == 1)
- pstate->wrap<fortran_array_size_1arg> ();
- else
- pstate->wrap2<fortran_array_size_2arg> ();
- }
- else
- {
- std::vector<operation_up> args
- = pstate->pop_vector (n);
- gdb_assert ($1 == FORTRAN_LBOUND
- || $1 == FORTRAN_UBOUND);
- operation_up op;
- if (n == 1)
- op.reset
- (new fortran_bound_1arg ($1,
- std::move (args[0])));
- else
- op.reset
- (new fortran_bound_2arg ($1,
- std::move (args[0]),
- std::move (args[1])));
- pstate->push (std::move (op));
- }
- }
- ;
-
-one_or_two_args
- : exp
- { pstate->arglist_len = 1; }
- | exp ',' exp
- { pstate->arglist_len = 2; }
- ;
-
/* No more explicit array operators, we treat everything in F77 as
a function call. The disambiguation as to whether we are
doing a subscript operation or a function call is done
exp : UNOP_INTRINSIC '(' exp ')'
{
- switch ($1)
+ wrap_unop_intrinsic ($1);
+ }
+ ;
+
+exp : BINOP_INTRINSIC '(' exp ',' exp ')'
+ {
+ wrap_binop_intrinsic ($1);
+ }
+ ;
+
+exp : UNOP_OR_BINOP_INTRINSIC '('
+ { pstate->start_arglist (); }
+ arglist ')'
+ {
+ const int n = pstate->end_arglist ();
+
+ switch (n)
{
- case UNOP_ABS:
- pstate->wrap<fortran_abs_operation> ();
- break;
- case UNOP_FORTRAN_FLOOR:
- pstate->wrap<fortran_floor_operation> ();
- break;
- case UNOP_FORTRAN_CEILING:
- pstate->wrap<fortran_ceil_operation> ();
+ case 1:
+ wrap_unop_intrinsic ($1);
break;
- case UNOP_FORTRAN_ALLOCATED:
- pstate->wrap<fortran_allocated_operation> ();
- break;
- case UNOP_FORTRAN_RANK:
- pstate->wrap<fortran_rank_operation> ();
- break;
- case UNOP_FORTRAN_SHAPE:
- pstate->wrap<fortran_array_shape_operation> ();
- break;
- case UNOP_FORTRAN_LOC:
- pstate->wrap<fortran_loc_operation> ();
+ case 2:
+ wrap_binop_intrinsic ($1);
break;
default:
- gdb_assert_not_reached ("unhandled intrinsic");
+ gdb_assert_not_reached
+ ("wrong number of arguments for intrinsics");
}
}
- ;
-exp : BINOP_INTRINSIC '(' exp ',' exp ')'
+exp : UNOP_OR_BINOP_OR_TERNOP_INTRINSIC '('
+ { pstate->start_arglist (); }
+ arglist ')'
{
- switch ($1)
+ const int n = pstate->end_arglist ();
+
+ switch (n)
{
- case BINOP_MOD:
- pstate->wrap2<fortran_mod_operation> ();
+ case 1:
+ wrap_unop_intrinsic ($1);
break;
- case BINOP_FORTRAN_MODULO:
- pstate->wrap2<fortran_modulo_operation> ();
+ case 2:
+ wrap_binop_intrinsic ($1);
break;
- case BINOP_FORTRAN_CMPLX:
- pstate->wrap2<fortran_cmplx_operation> ();
+ case 3:
+ wrap_ternop_intrinsic ($1);
break;
default:
- gdb_assert_not_reached ("unhandled intrinsic");
+ gdb_assert_not_reached
+ ("wrong number of arguments for intrinsics");
}
}
;
%%
+/* Called to match intrinsic function calls with one argument to their
+ respective implementation and push the operation. */
+
+static void
+wrap_unop_intrinsic (exp_opcode code)
+{
+ switch (code)
+ {
+ case UNOP_ABS:
+ pstate->wrap<fortran_abs_operation> ();
+ break;
+ case FORTRAN_FLOOR:
+ pstate->wrap<fortran_floor_operation_1arg> ();
+ break;
+ case FORTRAN_CEILING:
+ pstate->wrap<fortran_ceil_operation_1arg> ();
+ break;
+ case UNOP_FORTRAN_ALLOCATED:
+ pstate->wrap<fortran_allocated_operation> ();
+ break;
+ case UNOP_FORTRAN_RANK:
+ pstate->wrap<fortran_rank_operation> ();
+ break;
+ case UNOP_FORTRAN_SHAPE:
+ pstate->wrap<fortran_array_shape_operation> ();
+ break;
+ case UNOP_FORTRAN_LOC:
+ pstate->wrap<fortran_loc_operation> ();
+ break;
+ case FORTRAN_ASSOCIATED:
+ pstate->wrap<fortran_associated_1arg> ();
+ break;
+ case FORTRAN_ARRAY_SIZE:
+ pstate->wrap<fortran_array_size_1arg> ();
+ break;
+ case FORTRAN_CMPLX:
+ pstate->wrap<fortran_cmplx_operation_1arg> ();
+ break;
+ case FORTRAN_LBOUND:
+ case FORTRAN_UBOUND:
+ pstate->push_new<fortran_bound_1arg> (code, pstate->pop ());
+ break;
+ default:
+ gdb_assert_not_reached ("unhandled intrinsic");
+ }
+}
+
+/* Called to match intrinsic function calls with two arguments to their
+ respective implementation and push the operation. */
+
+static void
+wrap_binop_intrinsic (exp_opcode code)
+{
+ switch (code)
+ {
+ case FORTRAN_FLOOR:
+ fortran_wrap2_kind<fortran_floor_operation_2arg>
+ (parse_f_type (pstate)->builtin_integer);
+ break;
+ case FORTRAN_CEILING:
+ fortran_wrap2_kind<fortran_ceil_operation_2arg>
+ (parse_f_type (pstate)->builtin_integer);
+ break;
+ case BINOP_MOD:
+ pstate->wrap2<fortran_mod_operation> ();
+ break;
+ case BINOP_FORTRAN_MODULO:
+ pstate->wrap2<fortran_modulo_operation> ();
+ break;
+ case FORTRAN_CMPLX:
+ pstate->wrap2<fortran_cmplx_operation_2arg> ();
+ break;
+ case FORTRAN_ASSOCIATED:
+ pstate->wrap2<fortran_associated_2arg> ();
+ break;
+ case FORTRAN_ARRAY_SIZE:
+ pstate->wrap2<fortran_array_size_2arg> ();
+ break;
+ case FORTRAN_LBOUND:
+ case FORTRAN_UBOUND:
+ {
+ operation_up arg2 = pstate->pop ();
+ operation_up arg1 = pstate->pop ();
+ pstate->push_new<fortran_bound_2arg> (code, std::move (arg1),
+ std::move (arg2));
+ }
+ break;
+ default:
+ gdb_assert_not_reached ("unhandled intrinsic");
+ }
+}
+
+/* Called to match intrinsic function calls with three arguments to their
+ respective implementation and push the operation. */
+
+static void
+wrap_ternop_intrinsic (exp_opcode code)
+{
+ switch (code)
+ {
+ case FORTRAN_LBOUND:
+ case FORTRAN_UBOUND:
+ {
+ operation_up kind_arg = pstate->pop ();
+ operation_up arg2 = pstate->pop ();
+ operation_up arg1 = pstate->pop ();
+
+ value *val = kind_arg->evaluate (nullptr, pstate->expout.get (),
+ EVAL_AVOID_SIDE_EFFECTS);
+ gdb_assert (val != nullptr);
+
+ type *follow_type
+ = convert_to_kind_type (parse_f_type (pstate)->builtin_integer,
+ value_as_long (val));
+
+ pstate->push_new<fortran_bound_3arg> (code, std::move (arg1),
+ std::move (arg2), follow_type);
+ }
+ break;
+ case FORTRAN_ARRAY_SIZE:
+ fortran_wrap3_kind<fortran_array_size_3arg>
+ (parse_f_type (pstate)->builtin_integer);
+ break;
+ case FORTRAN_CMPLX:
+ fortran_wrap3_kind<fortran_cmplx_operation_3arg>
+ (parse_f_type (pstate)->builtin_complex);
+ break;
+ default:
+ gdb_assert_not_reached ("unhandled intrinsic");
+ }
+}
+
+/* A helper that pops two operations (similar to wrap2), evaluates the last one
+ assuming it is a kind parameter, and wraps them in some other operation
+ pushing it to the stack. */
+
+template<typename T>
+static void
+fortran_wrap2_kind (type *base_type)
+{
+ operation_up kind_arg = pstate->pop ();
+ operation_up arg = pstate->pop ();
+
+ value *val = kind_arg->evaluate (nullptr, pstate->expout.get (),
+ EVAL_AVOID_SIDE_EFFECTS);
+ gdb_assert (val != nullptr);
+
+ type *follow_type = convert_to_kind_type (base_type, value_as_long (val));
+
+ pstate->push_new<T> (std::move (arg), follow_type);
+}
+
+/* A helper that pops three operations, evaluates the last one assuming it is a
+ kind parameter, and wraps them in some other operation pushing it to the
+ stack. */
+
+template<typename T>
+static void
+fortran_wrap3_kind (type *base_type)
+{
+ operation_up kind_arg = pstate->pop ();
+ operation_up arg2 = pstate->pop ();
+ operation_up arg1 = pstate->pop ();
+
+ value *val = kind_arg->evaluate (nullptr, pstate->expout.get (),
+ EVAL_AVOID_SIDE_EFFECTS);
+ gdb_assert (val != nullptr);
+
+ type *follow_type = convert_to_kind_type (base_type, value_as_long (val));
+
+ pstate->push_new<T> (std::move (arg1), std::move (arg2), follow_type);
+}
+
/* Take care of parsing a number (anything that starts with a digit).
Set yylval and return the token type; update lexptr.
LEN is the number of characters in it. */
{ "kind", KIND, OP_NULL, false },
{ "abs", UNOP_INTRINSIC, UNOP_ABS, false },
{ "mod", BINOP_INTRINSIC, BINOP_MOD, false },
- { "floor", UNOP_INTRINSIC, UNOP_FORTRAN_FLOOR, false },
- { "ceiling", UNOP_INTRINSIC, UNOP_FORTRAN_CEILING, false },
+ { "floor", UNOP_OR_BINOP_INTRINSIC, FORTRAN_FLOOR, false },
+ { "ceiling", UNOP_OR_BINOP_INTRINSIC, FORTRAN_CEILING, false },
{ "modulo", BINOP_INTRINSIC, BINOP_FORTRAN_MODULO, false },
- { "cmplx", BINOP_INTRINSIC, BINOP_FORTRAN_CMPLX, false },
- { "lbound", UNOP_OR_BINOP_INTRINSIC, FORTRAN_LBOUND, false },
- { "ubound", UNOP_OR_BINOP_INTRINSIC, FORTRAN_UBOUND, false },
+ { "cmplx", UNOP_OR_BINOP_OR_TERNOP_INTRINSIC, FORTRAN_CMPLX, false },
+ { "lbound", UNOP_OR_BINOP_OR_TERNOP_INTRINSIC, FORTRAN_LBOUND, false },
+ { "ubound", UNOP_OR_BINOP_OR_TERNOP_INTRINSIC, FORTRAN_UBOUND, false },
{ "allocated", UNOP_INTRINSIC, UNOP_FORTRAN_ALLOCATED, false },
{ "associated", UNOP_OR_BINOP_INTRINSIC, FORTRAN_ASSOCIATED, false },
{ "rank", UNOP_INTRINSIC, UNOP_FORTRAN_RANK, false },
- { "size", UNOP_OR_BINOP_INTRINSIC, FORTRAN_ARRAY_SIZE, false },
+ { "size", UNOP_OR_BINOP_OR_TERNOP_INTRINSIC, FORTRAN_ARRAY_SIZE, false },
{ "shape", UNOP_INTRINSIC, UNOP_FORTRAN_SHAPE, false },
{ "loc", UNOP_INTRINSIC, UNOP_FORTRAN_LOC, false },
};
/* Allocate a result value of the correct type. */
struct type *range
= create_static_range_type (nullptr,
- builtin_type (gdbarch)->builtin_int,
+ builtin_f_type (gdbarch)->builtin_integer,
1, ndimensions);
- struct type *elm_type = builtin_type (gdbarch)->builtin_long_long;
+ struct type *elm_type = builtin_f_type (gdbarch)->builtin_integer;
struct type *result_type = create_array_type (nullptr, elm_type, range);
struct value *result = allocate_value (result_type);
/* Return the lower bound (when LBOUND_P is true) or the upper bound (when
LBOUND_P is false) for dimension DIM_VAL (which must be an integer) of
- ARRAY (which must be an array). GDBARCH is the current architecture. */
+ ARRAY (which must be an array). RESULT_TYPE corresponds to the type kind
+ the function should be evaluated in. */
-static struct value *
-fortran_bounds_for_dimension (bool lbound_p,
- struct gdbarch *gdbarch,
- struct value *array,
- struct value *dim_val)
+static value *
+fortran_bounds_for_dimension (bool lbound_p, value *array, value *dim_val,
+ type* result_type)
{
/* Check the requested dimension is valid for this array. */
type *array_type = check_typedef (value_type (array));
error (_("UBOUND dimension must be from 1 to %d"), ndimensions);
}
- /* The type for the result. */
- struct type *bound_type = builtin_type (gdbarch)->builtin_long_long;
-
/* Walk the dimensions backwards, due to the ordering in which arrays are
laid out the first dimension is the most inner. */
for (int i = ndimensions - 1; i >= 0; --i)
else
b = f77_get_upperbound (array_type);
- return value_from_longest (bound_type, b);
+ return value_from_longest (result_type, b);
}
/* Peel off another dimension of the array. */
}
/* Implement FORTRAN_ARRAY_SIZE expression, this corresponds to the 'SIZE'
- keyword. Both GDBARCH and LANG are extracted from the expression being
- evaluated. ARRAY is the value that should be an array, though this will
+ keyword. RESULT_TYPE corresponds to the type kind the function should be
+ evaluated in, ARRAY is the value that should be an array, though this will
not have been checked before calling this function. DIM is optional, if
present then it should be an integer identifying a dimension of the
array to ask about. As with ARRAY the validity of DIM is not checked
Return either the total number of elements in ARRAY (when DIM is
nullptr), or the number of elements in dimension DIM. */
-static struct value *
-fortran_array_size (struct gdbarch *gdbarch, const language_defn *lang,
- struct value *array, struct value *dim_val = nullptr)
+static value *
+fortran_array_size (value *array, value *dim_val, type *result_type)
{
/* Check that ARRAY is the correct type. */
struct type *array_type = check_typedef (value_type (array));
array_type = TYPE_TARGET_TYPE (array_type);
}
- struct type *result_type
- = builtin_f_type (gdbarch)->builtin_integer;
return value_from_longest (result_type, result);
}
struct value *arg1)
{
gdb_assert (opcode == FORTRAN_ARRAY_SIZE);
- return fortran_array_size (exp->gdbarch, exp->language_defn, arg1);
+
+ type *result_type = builtin_f_type (exp->gdbarch)->builtin_integer;
+ return fortran_array_size (arg1, nullptr, result_type);
}
/* See f-exp.h. */
struct value *arg2)
{
gdb_assert (opcode == FORTRAN_ARRAY_SIZE);
- return fortran_array_size (exp->gdbarch, exp->language_defn, arg1, arg2);
+
+ type *result_type = builtin_f_type (exp->gdbarch)->builtin_integer;
+ return fortran_array_size (arg1, arg2, result_type);
+}
+
+/* See f-exp.h. */
+
+value *eval_op_f_array_size (type *expect_type, expression *exp, noside noside,
+ exp_opcode opcode, value *arg1, value *arg2,
+ type *kind_arg)
+{
+ gdb_assert (opcode == FORTRAN_ARRAY_SIZE);
+ gdb_assert (kind_arg->code () == TYPE_CODE_INT);
+
+ return fortran_array_size (arg1, arg2, kind_arg);
}
/* Implement UNOP_FORTRAN_SHAPE expression. Both GDBARCH and LANG are
error (_("MOD of type %s not supported"), TYPE_SAFE_NAME (type));
}
-/* A helper function for UNOP_FORTRAN_CEILING. */
+/* A helper function for the different FORTRAN_CEILING overloads. Calculates
+ CEILING for ARG1 (a float type) and returns it in the requested kind type
+ RESULT_TYPE. */
+
+static value *
+fortran_ceil_operation (value *arg1, type *result_type)
+{
+ if (value_type (arg1)->code () != TYPE_CODE_FLT)
+ error (_("argument to CEILING must be of type float"));
+ double val = target_float_to_host_double (value_contents (arg1).data (),
+ value_type (arg1));
+ val = ceil (val);
+ return value_from_longest (result_type, val);
+}
+
+/* A helper function for FORTRAN_CEILING. */
struct value *
eval_op_f_ceil (struct type *expect_type, struct expression *exp,
enum exp_opcode opcode,
struct value *arg1)
{
- struct type *type = value_type (arg1);
- if (type->code () != TYPE_CODE_FLT)
- error (_("argument to CEILING must be of type float"));
- double val
- = target_float_to_host_double (value_contents (arg1).data (),
- value_type (arg1));
- val = ceil (val);
- return value_from_host_double (type, val);
+ gdb_assert (opcode == FORTRAN_CEILING);
+ type *result_type = builtin_f_type (exp->gdbarch)->builtin_integer;
+ return fortran_ceil_operation (arg1, result_type);
}
-/* A helper function for UNOP_FORTRAN_FLOOR. */
+/* A helper function for FORTRAN_CEILING. */
-struct value *
-eval_op_f_floor (struct type *expect_type, struct expression *exp,
- enum noside noside,
- enum exp_opcode opcode,
- struct value *arg1)
+value *
+eval_op_f_ceil (type *expect_type, expression *exp, noside noside,
+ exp_opcode opcode, value *arg1, type *kind_arg)
{
- struct type *type = value_type (arg1);
- if (type->code () != TYPE_CODE_FLT)
+ gdb_assert (opcode == FORTRAN_CEILING);
+ gdb_assert (kind_arg->code () == TYPE_CODE_INT);
+ return fortran_ceil_operation (arg1, kind_arg);
+}
+
+/* A helper function for the different FORTRAN_FLOOR overloads. Calculates
+ FLOOR for ARG1 (a float type) and returns it in the requested kind type
+ RESULT_TYPE. */
+
+static value *
+fortran_floor_operation (value *arg1, type *result_type)
+{
+ if (value_type (arg1)->code () != TYPE_CODE_FLT)
error (_("argument to FLOOR must be of type float"));
- double val
- = target_float_to_host_double (value_contents (arg1).data (),
- value_type (arg1));
+ double val = target_float_to_host_double (value_contents (arg1).data (),
+ value_type (arg1));
val = floor (val);
- return value_from_host_double (type, val);
+ return value_from_longest (result_type, val);
+}
+
+/* A helper function for FORTRAN_FLOOR. */
+
+struct value *
+eval_op_f_floor (struct type *expect_type, struct expression *exp,
+ enum noside noside,
+ enum exp_opcode opcode,
+ struct value *arg1)
+{
+ gdb_assert (opcode == FORTRAN_FLOOR);
+ type *result_type = builtin_f_type (exp->gdbarch)->builtin_integer;
+ return fortran_floor_operation (arg1, result_type);
+}
+
+/* A helper function for FORTRAN_FLOOR. */
+
+struct value *
+eval_op_f_floor (type *expect_type, expression *exp, noside noside,
+ exp_opcode opcode, value *arg1, type *kind_arg)
+{
+ gdb_assert (opcode == FORTRAN_FLOOR);
+ gdb_assert (kind_arg->code () == TYPE_CODE_INT);
+ return fortran_floor_operation (arg1, kind_arg);
}
/* A helper function for BINOP_FORTRAN_MODULO. */
error (_("MODULO of type %s not supported"), TYPE_SAFE_NAME (type));
}
-/* A helper function for BINOP_FORTRAN_CMPLX. */
+/* A helper function for FORTRAN_CMPLX. */
+
+value *
+eval_op_f_cmplx (type *expect_type, expression *exp, noside noside,
+ exp_opcode opcode, value *arg1)
+{
+ gdb_assert (opcode == FORTRAN_CMPLX);
+
+ type *result_type = builtin_f_type (exp->gdbarch)->builtin_complex;
+
+ if (value_type (arg1)->code () == TYPE_CODE_COMPLEX)
+ return value_cast (result_type, arg1);
+ else
+ return value_literal_complex (arg1,
+ value_zero (value_type (arg1), not_lval),
+ result_type);
+}
+
+/* A helper function for FORTRAN_CMPLX. */
struct value *
eval_op_f_cmplx (struct type *expect_type, struct expression *exp,
enum exp_opcode opcode,
struct value *arg1, struct value *arg2)
{
- struct type *type = builtin_f_type(exp->gdbarch)->builtin_complex_s16;
- return value_literal_complex (arg1, arg2, type);
+ if (value_type (arg1)->code () == TYPE_CODE_COMPLEX
+ || value_type (arg2)->code () == TYPE_CODE_COMPLEX)
+ error (_("Types of arguments for CMPLX called with more then one argument "
+ "must be REAL or INTEGER"));
+
+ type *result_type = builtin_f_type (exp->gdbarch)->builtin_complex;
+ return value_literal_complex (arg1, arg2, result_type);
+}
+
+/* A helper function for FORTRAN_CMPLX. */
+
+value *
+eval_op_f_cmplx (type *expect_type, expression *exp, noside noside,
+ exp_opcode opcode, value *arg1, value *arg2, type *kind_arg)
+{
+ gdb_assert (kind_arg->code () == TYPE_CODE_COMPLEX);
+ if (value_type (arg1)->code () == TYPE_CODE_COMPLEX
+ || value_type (arg2)->code () == TYPE_CODE_COMPLEX)
+ error (_("Types of arguments for CMPLX called with more then one argument "
+ "must be REAL or INTEGER"));
+
+ return value_literal_complex (arg1, arg2, kind_arg);
}
/* A helper function for UNOP_FORTRAN_KIND. */
/* User asked for the bounds of a specific dimension of the array. */
value *arg2 = std::get<2> (m_storage)->evaluate (nullptr, exp, noside);
- struct type *type = check_typedef (value_type (arg2));
- if (type->code () != TYPE_CODE_INT)
+ type *type_arg2 = check_typedef (value_type (arg2));
+ if (type_arg2->code () != TYPE_CODE_INT)
{
if (lbound_p)
error (_("LBOUND second argument should be an integer"));
error (_("UBOUND second argument should be an integer"));
}
- return fortran_bounds_for_dimension (lbound_p, exp->gdbarch, arg1, arg2);
+ type *result_type = builtin_f_type (exp->gdbarch)->builtin_integer;
+ return fortran_bounds_for_dimension (lbound_p, arg1, arg2, result_type);
+}
+
+value *
+fortran_bound_3arg::evaluate (type *expect_type,
+ expression *exp,
+ noside noside)
+{
+ const bool lbound_p = std::get<0> (m_storage) == FORTRAN_LBOUND;
+ value *arg1 = std::get<1> (m_storage)->evaluate (nullptr, exp, noside);
+ fortran_require_array (value_type (arg1), lbound_p);
+
+ /* User asked for the bounds of a specific dimension of the array. */
+ value *arg2 = std::get<2> (m_storage)->evaluate (nullptr, exp, noside);
+ type *type_arg2 = check_typedef (value_type (arg2));
+ if (type_arg2->code () != TYPE_CODE_INT)
+ {
+ if (lbound_p)
+ error (_("LBOUND second argument should be an integer"));
+ else
+ error (_("UBOUND second argument should be an integer"));
+ }
+
+ type *kind_arg = std::get<3> (m_storage);
+ gdb_assert (kind_arg->code () == TYPE_CODE_INT);
+
+ return fortran_bounds_for_dimension (lbound_p, arg1, arg2, kind_arg);
}
/* Implement STRUCTOP_STRUCT for Fortran. See operation::evaluate in
/* Single operand builtins. */
OP (UNOP_FORTRAN_KIND)
-OP (UNOP_FORTRAN_FLOOR)
-OP (UNOP_FORTRAN_CEILING)
OP (UNOP_FORTRAN_ALLOCATED)
OP (UNOP_FORTRAN_RANK)
OP (UNOP_FORTRAN_SHAPE)
OP (UNOP_FORTRAN_LOC)
/* Two operand builtins. */
-OP (BINOP_FORTRAN_CMPLX)
OP (BINOP_FORTRAN_MODULO)
/* Builtins that take one or two operands. */
+OP (FORTRAN_CEILING)
+OP (FORTRAN_FLOOR)
+OP (FORTRAN_ASSOCIATED)
+
+/* Builtins that take one, two or three operands. */
OP (FORTRAN_LBOUND)
OP (FORTRAN_UBOUND)
-OP (FORTRAN_ASSOCIATED)
+OP (FORTRAN_CMPLX)
OP (FORTRAN_ARRAY_SIZE)
gdb_test "p mod (8, -5)" " = 3"
gdb_test "p mod (-8, -5)" " = -3"
-# Test CEILING
+# Test CEILING and FLOOR.
+gdb_test "p floor (3.7)" " = 3"
gdb_test "p ceiling (3.7)" " = 4"
-gdb_test "p ceiling (-3.7)" " = -3"
-# Test FLOOR
-
-gdb_test "p floor (3.7)" " = 3"
gdb_test "p floor (-3.7)" " = -4"
+gdb_test "p ceiling (-3.7)" " = -3"
+
+gdb_test "p ceiling (3)" "argument to CEILING must be of type float"
+gdb_test "p floor (1)" "argument to FLOOR must be of type float"
+
+foreach op {floor ceiling} {
+ gdb_test "ptype ${op} (3.7)" "integer\\*4"
+ gdb_test "ptype ${op} (-1.1, 1)" "type = integer\\*1"
+ gdb_test "ptype ${op} (-1.1, 2)" "type = integer\\*2"
+ gdb_test "ptype ${op} (-1.1, 3)" "unsupported kind 3 for type integer\\*4"
+ gdb_test "ptype ${op} (-1.1, 4)" "type = integer\\*4"
+ gdb_test "ptype ${op} (-1.1, 8)" "type = integer\\*8"
+
+ # The actual overflow behavior differs in ifort/ifx/gfortran - this tests
+ # the GDB internal overflow behavior - not a compiler dependent one.
+ gdb_test "p ${op} (129.0,1)" " = -127"
+ gdb_test "p ${op} (129.0,2)" " = 129"
+ gdb_test "p ${op} (-32770.0,1)" " = -2"
+ gdb_test "p ${op} (-32770.0,2)" " = 32766"
+ gdb_test "p ${op} (-32770.0,4)" " = -32770"
+ gdb_test "p ${op} (2147483652.0,1)" " = 4"
+ gdb_test "p ${op} (2147483652.0,2)" " = 4"
+ gdb_test "p ${op} (2147483652.0,4)" " = -2147483644"
+ gdb_test "p ${op} (2147483652.0,8)" " = 2147483652"
+}
# Test MODULO
gdb_test "p CMPLX (4.1, 2.0)" " = \\(4.$decimal,2\\)"
+gdb_test "p cmplx (4,4)" "= \\(4,4\\)"
+gdb_test "ptype cmplx (4,4)" "= complex\\*4"
+gdb_test "p cmplx (-14,-4)" "= \\(-14,-4\\)"
+gdb_test "p cmplx (4,4,4)" "\\(4,4\\)"
+gdb_test "p cmplx (4,4,8)" "\\(4,4\\)"
+gdb_test "p cmplx (4,4,16)" "\\(4,4\\)"
+gdb_test "ptype cmplx (4,4,4)" "= complex\\*4"
+gdb_test "ptype cmplx (4,4,8)" "= complex\\*8"
+gdb_test "ptype cmplx (4,4,16)" "= complex\\*16"
+
+gdb_test "p cmplx (4,4,1)" "unsupported kind 1 for type complex\\*4"
+gdb_test "p cmplx (4,4,-1)" "unsupported kind -1 for type complex\\*4"
+gdb_test "p cmplx (4,4,2)" "unsupported kind 2 for type complex\\*4"
+
# Test LOC
gdb_test "p/x LOC(l)" "= $hex"
call do_test (lbound (ARRAY), ubound (ARRAY))
subroutine do_test (lb, ub)
- integer, dimension (:) :: lb
- integer, dimension (:) :: ub
+ integer*4, dimension (:) :: lb
+ integer*4, dimension (:) :: ub
print *, ""
print *, "Expected GDB Output:"
program test
interface
subroutine do_test (lb, ub)
- integer, dimension (:) :: lb
- integer, dimension (:) :: ub
+ integer*4, dimension (:) :: lb
+ integer*4, dimension (:) :: ub
end subroutine do_test
end interface
integer, dimension (:), pointer :: pointer1d => null()
+ integer, parameter :: b1 = 127 - 10
+ integer, parameter :: b1_o = 127 + 2
+ integer, parameter :: b2 = 32767 - 10
+ integer, parameter :: b2_o = 32767 + 3
+ integer*8, parameter :: b4 = 2147483647 - 10
+ integer*8, parameter :: b4_o = 2147483647 + 5
+
+ integer, allocatable :: array_1d_1bytes_overflow (:)
+ integer, allocatable :: array_1d_2bytes_overflow (:)
+ integer, allocatable :: array_1d_4bytes_overflow (:)
+ integer, allocatable :: array_2d_1byte_overflow (:,:)
+ integer, allocatable :: array_2d_2bytes_overflow (:,:)
+ integer, allocatable :: array_3d_1byte_overflow (:,:,:)
+
! Allocate or associate any variables as needed.
allocate (other (-5:4, -2:7))
pointer2d => tarray
pointer1d => array (3, 2:5)
+ allocate (array_1d_1bytes_overflow (-b1_o:-b1))
+ allocate (array_1d_2bytes_overflow (b2:b2_o))
+ allocate (array_1d_4bytes_overflow (-b4_o:-b4))
+
+ allocate (array_2d_1byte_overflow (-b1_o:-b1,b1:b1_o))
+ allocate (array_2d_2bytes_overflow (b2:b2_o,-b2_o:b2))
+
+ allocate (array_3d_1byte_overflow (-b1_o:-b1,b1:b1_o,-b1_o:-b1))
+
DO_TEST (neg_array)
DO_TEST (neg_array (-7:-3,-5:-4))
DO_TEST (array)
DO_TEST (pointer2d)
DO_TEST (tarray)
+ DO_TEST (array_1d_1bytes_overflow)
+ DO_TEST (array_1d_2bytes_overflow)
+
+ DO_TEST (array_1d_4bytes_overflow)
+ DO_TEST (array_2d_1byte_overflow)
+ DO_TEST (array_2d_2bytes_overflow)
+ DO_TEST (array_3d_1byte_overflow)
+
! All done. Deallocate.
+ print *, "" ! Breakpoint before deallocate.
deallocate (other)
+ deallocate (array_3d_1byte_overflow)
+
+ deallocate (array_2d_2bytes_overflow)
+ deallocate (array_2d_1byte_overflow)
+
+ deallocate (array_1d_4bytes_overflow)
+ deallocate (array_1d_2bytes_overflow)
+ deallocate (array_1d_1bytes_overflow)
+
! GDB catches this final breakpoint to indicate the end of the test.
print *, "" ! Final Breakpoint.
gdb_test_no_output "nosharedlibrary"
gdb_breakpoint [gdb_get_line_number "Test Breakpoint"]
+gdb_breakpoint [gdb_get_line_number "Breakpoint before deallocate\."]
gdb_breakpoint [gdb_get_line_number "Final Breakpoint"]
-set found_final_breakpoint false
+set found_dealloc_breakpoint false
# We place a limit on the number of tests that can be run, just in
# case something goes wrong, and GDB gets stuck in an loop here.
set func_name "show_elem"
exp_continue
}
- -re "! Final Breakpoint" {
- set found_final_breakpoint true
+ -re "! Breakpoint before deallocate" {
+ set found_dealloc_breakpoint true
exp_continue
}
-re "$gdb_prompt $" {
set found_prompt true
- if {$found_final_breakpoint
+ if {$found_dealloc_breakpoint
|| ($expected_lbound != "" && $expected_ubound != "")} {
# We're done.
} else {
}
}
- if ($found_final_breakpoint) {
+ if ($found_dealloc_breakpoint) {
break
}
}
}
+gdb_assert {$found_dealloc_breakpoint} "ran all compiled in tests"
+
+# Test the kind parameter of ubound and lbound a few times.
+gdb_test "p lbound(array_1d_1bytes_overflow, 1, 1)" "= 127"
+gdb_test "p lbound(array_1d_1bytes_overflow, 1, 2)" "= -129"
+gdb_test "p ubound(array_1d_1bytes_overflow, 1, 1)" "= -117"
+
+gdb_test "p lbound(array_1d_2bytes_overflow, 1, 2)" "= 32757"
+gdb_test "p ubound(array_1d_2bytes_overflow, 1, 2)" "= -32766"
+gdb_test "p ubound(array_1d_2bytes_overflow, 1, 4)" "= 32770"
+
+gdb_test "p lbound(array_1d_4bytes_overflow, 1, 4)" "= 2147483644"
+gdb_test "p lbound(array_1d_4bytes_overflow, 1, 8)" "= -2147483652"
+gdb_test "p ubound(array_1d_4bytes_overflow, 1, 4)" "= -2147483637"
+gdb_test "p lbound(array_1d_4bytes_overflow)" "= \\(2147483644\\)"
+
# Ensure we reached the final breakpoint. If more tests have been added
# to the test script, and this starts failing, then the safety 'while'
# loop above might need to be increased.
-gdb_assert {$found_final_breakpoint} "reached final breakpoint"
+gdb_continue_to_breakpoint "Final Breakpoint"
# Now for some final tests. This is mostly testing that GDB gives the
# correct errors in certain cases.
return -1
}
-gdb_breakpoint [gdb_get_line_number "Test Breakpoint"]
+gdb_breakpoint [gdb_get_line_number "Test Breakpoint 1"]
+gdb_breakpoint [gdb_get_line_number "Test Breakpoint 2"]
+gdb_breakpoint [gdb_get_line_number "Test Breakpoint 3"]
+gdb_breakpoint [gdb_get_line_number "Test Breakpoint 4"]
+
+gdb_breakpoint [gdb_get_line_number "Breakpoint before deallocate\."]
gdb_breakpoint [gdb_get_line_number "Final Breakpoint"]
# We place a limit on the number of tests that can be run, just in
# case something goes wrong, and GDB gets stuck in an loop here.
-set found_final_breakpoint false
+set found_dealloc_breakpoint false
set test_count 0
-while { $test_count < 500 } {
+while { $test_count < 600 } {
with_test_prefix "test $test_count" {
incr test_count
gdb_test_multiple "continue" "continue" {
- -re -wrap "! Test Breakpoint" {
+ -re -wrap "! Test Breakpoint \[0-9\]" {
# We can run a test from here.
}
- -re -wrap "! Final Breakpoint" {
+ -re -wrap "! Breakpoint before deallocate\." {
# We're done with the tests.
- set found_final_breakpoint true
+ set found_dealloc_breakpoint true
}
}
- if ($found_final_breakpoint) {
+ if ($found_dealloc_breakpoint) {
break
}
# as a test.
set command ""
gdb_test_multiple "up" "up" {
- -re -wrap "\r\n\[0-9\]+\[ \t\]+call test_size \\((\[^\r\n\]+)\\)" {
+ -re -wrap "\r\n\[0-9\]+\[ \t\]+call test_size_\[0-9\]* \\((\[^\r\n\]+)\\)" {
set command $expect_out(1,string)
}
}
gdb_assert { ![string equal $command ""] } "found a command to run"
- gdb_test "p $command" " = $answer"
+ gdb_test_multiple "p $command" "p $command" {
+ -re -wrap " = $answer" {
+ pass $gdb_test_name
+ }
+ -re -wrap "SIZE can only be applied to arrays" {
+ # Because of ifort's DWARF pointer representation we need to
+ # aditionally de-reference Fortran pointers.
+ regsub -all "\\(" $command "\(\*" command_deref
+ gdb_test "p $command_deref" " = $answer"
+ pass $gdb_test_name
+ }
+ }
+ }
+}
+
+# Since the behavior of size (array_1d, 2) differs for different compilers and
+# neither of them seem to behave as expected (gfortran prints apparently random
+# things, ifort would print 0), we test for GDB's error message instead.
+gdb_assert {$found_dealloc_breakpoint} "ran all compiled in tests"
+
+foreach var {array_1d_p array_2d_p allocatable_array_1d \
+ allocatable_array_2d} {
+ gdb_test_multiple "p size ($var, 3)" "p size ($var, 3)" {
+ -re -wrap "DIM argument to SIZE must be between 1 and \[1-2\]" {
+ pass $gdb_test_name
+ }
+ -re -wrap "SIZE can only be applied to arrays" {
+ # Because of ifort's DWARF pointer representation we need to
+ # aditionally de-reference Fortran pointers.
+ gdb_test "p size (*$var, 3)" \
+ "DIM argument to SIZE must be between 1 and \[1-2\]"
+ pass $gdb_test_name
+ }
}
}
+# For wrong kind parameters GBD and compiler behavior differs. Here,
+# gfortran/ifort/ifx would already throw a compiler error - a user might still
+# try and call size with something like -3 as kind parameter, so we test GDB's
+# error handling here.
+
+foreach var {array_1d_p array_2d_p allocatable_array_1d \
+ allocatable_array_2d} {
+ gdb_test "p size ($var, 1, -10)" \
+ "unsupported kind -10 for type integer\\*4"
+ gdb_test "p size ($var, 1, 123)" \
+ "unsupported kind 123 for type integer\\*4"
+}
+
# Ensure we reached the final breakpoint. If more tests have been added
# to the test script, and this starts failing, then the safety 'while'
# loop above might need to be increased.
-gdb_assert {$found_final_breakpoint} "ran all compiled in tests"
+gdb_continue_to_breakpoint "Final Breakpoint"
foreach var {array_1d_p array_2d_p allocatable_array_1d \
allocatable_array_2d} {
- gdb_test "p size ($var)" \
- "SIZE can only be used on allocated/associated arrays"
+ gdb_test_multiple "p size ($var)" "p size ($var)" {
+ -re -wrap "SIZE can only be used on allocated/associated arrays" {
+ pass $gdb_test_name
+ }
+ -re -wrap "SIZE can only be applied to arrays" {
+ # Because of ifort's DWARF pointer representation we need to
+ # aditionally de-reference Fortran pointers.
+ gdb_test "p size (*$var)" \
+ "Attempt to take contents of a not associated pointer\."
+ pass $gdb_test_name
+ }
+ }
}
foreach var {an_integer a_real} {
integer, allocatable :: allocatable_array_1d (:)
integer, allocatable :: allocatable_array_2d (:,:)
+ integer, parameter :: b1_o = 127 + 1
+ integer, parameter :: b2_o = 32767 + 3
+ integer*8, parameter :: b4_o = 2147483647 + 5
+
+ integer, allocatable :: array_1d_1byte_overflow (:)
+ integer, allocatable :: array_1d_2bytes_overflow (:)
+ integer, allocatable :: array_1d_4bytes_overflow (:)
+ integer, allocatable :: array_2d_1byte_overflow (:,:)
+ integer, allocatable :: array_2d_2bytes_overflow (:,:)
+ integer, allocatable :: array_3d_1byte_overflow (:,:,:)
+
! Loop counters.
integer :: s1, s2
+ allocate (array_1d_1byte_overflow (1:b1_o))
+ allocate (array_1d_2bytes_overflow (1:b2_o))
+ allocate (array_1d_4bytes_overflow (1:b4_o))
+
+ allocate (array_2d_1byte_overflow (1:b1_o, 1:b1_o))
+ allocate (array_2d_2bytes_overflow (1:b2_o, 1:b2_o))
+
+ allocate (array_3d_1byte_overflow (1:b1_o, 1:b1_o, 1:b1_o))
+
+
! The start of the tests.
- call test_size (size (array_1d))
- call test_size (size (array_1d, 1))
+ call test_size_4 (size (array_1d))
+ call test_size_4 (size (array_1d, 1))
do s1=1, SIZE (array_1d, 1), 1
- call test_size (size (array_1d (1:10:s1)))
- call test_size (size (array_1d (1:10:s1), 1))
- call test_size (size (array_1d (10:1:-s1)))
- call test_size (size (array_1d (10:1:-s1), 1))
+ call test_size_4 (size (array_1d (1:10:s1)))
+ call test_size_4 (size (array_1d (1:10:s1), 1))
+ call test_size_4 (size (array_1d (10:1:-s1)))
+ call test_size_4 (size (array_1d (10:1:-s1), 1))
end do
do s2=1, SIZE (array_2d, 2), 1
do s1=1, SIZE (array_2d, 1), 1
- call test_size (size (array_2d (1:4:s1, 1:3:s2)))
- call test_size (size (array_2d (4:1:-s1, 1:3:s2)))
- call test_size (size (array_2d (1:4:s1, 3:1:-s2)))
- call test_size (size (array_2d (4:1:-s1, 3:1:-s2)))
-
- call test_size (size (array_2d (1:4:s1, 1:3:s2), 1))
- call test_size (size (array_2d (4:1:-s1, 1:3:s2), 1))
- call test_size (size (array_2d (1:4:s1, 3:1:-s2), 1))
- call test_size (size (array_2d (4:1:-s1, 3:1:-s2), 1))
-
- call test_size (size (array_2d (1:4:s1, 1:3:s2), 2))
- call test_size (size (array_2d (4:1:-s1, 1:3:s2), 2))
- call test_size (size (array_2d (1:4:s1, 3:1:-s2), 2))
- call test_size (size (array_2d (4:1:-s1, 3:1:-s2), 2))
+ call test_size_4 (size (array_2d (1:4:s1, 1:3:s2)))
+ call test_size_4 (size (array_2d (4:1:-s1, 1:3:s2)))
+ call test_size_4 (size (array_2d (1:4:s1, 3:1:-s2)))
+ call test_size_4 (size (array_2d (4:1:-s1, 3:1:-s2)))
+
+ call test_size_4 (size (array_2d (1:4:s1, 1:3:s2), 1))
+ call test_size_4 (size (array_2d (4:1:-s1, 1:3:s2), 1))
+ call test_size_4 (size (array_2d (1:4:s1, 3:1:-s2), 1))
+ call test_size_4 (size (array_2d (4:1:-s1, 3:1:-s2), 1))
+
+ call test_size_4 (size (array_2d (1:4:s1, 1:3:s2), 2))
+ call test_size_4 (size (array_2d (4:1:-s1, 1:3:s2), 2))
+ call test_size_4 (size (array_2d (1:4:s1, 3:1:-s2), 2))
+ call test_size_4 (size (array_2d (4:1:-s1, 3:1:-s2), 2))
end do
end do
allocate (allocatable_array_1d (-10:-5))
- call test_size (size (allocatable_array_1d))
+ call test_size_4 (size (allocatable_array_1d))
do s1=1, SIZE (allocatable_array_1d, 1), 1
- call test_size (size (allocatable_array_1d (-10:-5:s1)))
- call test_size (size (allocatable_array_1d (-5:-10:-s1)))
+ call test_size_4 (size (allocatable_array_1d (-10:-5:s1)))
+ call test_size_4 (size (allocatable_array_1d (-5:-10:-s1)))
- call test_size (size (allocatable_array_1d (-10:-5:s1), 1))
- call test_size (size (allocatable_array_1d (-5:-10:-s1), 1))
+ call test_size_4 (size (allocatable_array_1d (-10:-5:s1), 1))
+ call test_size_4 (size (allocatable_array_1d (-5:-10:-s1), 1))
end do
allocate (allocatable_array_2d (-3:3, 8:12))
do s2=1, SIZE (allocatable_array_2d, 2), 1
do s1=1, SIZE (allocatable_array_2d, 1), 1
- call test_size (size (allocatable_array_2d (-3:3:s1, 8:12:s2)))
- call test_size (size (allocatable_array_2d (3:-3:-s1, 8:12:s2)))
- call test_size (size (allocatable_array_2d (-3:3:s1, 12:8:-s2)))
- call test_size (size (allocatable_array_2d (3:-3:-s1, 12:8:-s2)))
-
- call test_size (size (allocatable_array_2d (-3:3:s1, 8:12:s2), 1))
- call test_size (size (allocatable_array_2d (3:-3:-s1, 8:12:s2), 2))
- call test_size (size (allocatable_array_2d (-3:3:s1, 12:8:-s2), 1))
- call test_size (size (allocatable_array_2d (3:-3:-s1, 12:8:-s2), 2))
+ call test_size_4 (size (allocatable_array_2d (-3:3:s1, 8:12:s2)))
+ call test_size_4 (size (allocatable_array_2d (3:-3:-s1, 8:12:s2)))
+ call test_size_4 (size (allocatable_array_2d (-3:3:s1, 12:8:-s2)))
+ call test_size_4 (size (allocatable_array_2d (3:-3:-s1, 12:8:-s2)))
+
+ call test_size_4 (size (allocatable_array_2d (-3:3:s1, 8:12:s2), 1))
+ call test_size_4 (size (allocatable_array_2d (3:-3:-s1, 8:12:s2), 2))
+ call test_size_4 (size (allocatable_array_2d (-3:3:s1, 12:8:-s2), 1))
+ call test_size_4 (size (allocatable_array_2d (3:-3:-s1, 12:8:-s2), 2))
end do
end do
array_1d_p => array_1d
- call test_size (size (array_1d_p))
- call test_size (size (array_1d_p, 1))
+ call test_size_4 (size (array_1d_p))
+ call test_size_4 (size (array_1d_p, 1))
array_2d_p => array_2d
- call test_size (size (array_2d_p))
- call test_size (size (array_2d_p, 1))
- call test_size (size (array_2d_p, 2))
+ call test_size_4 (size (array_2d_p))
+ call test_size_4 (size (array_2d_p, 1))
+ call test_size_4 (size (array_2d_p, 2))
+
+ ! Test kind parameters - compiler requires these to be compile time constant
+ ! so sadly there cannot be a loop over the kinds 1, 2, 4, 8.
+ call test_size_4 (size (array_1d_1byte_overflow))
+ call test_size_4 (size (array_1d_2bytes_overflow))
+
+ call test_size_4 (size (array_1d_1byte_overflow, 1))
+ call test_size_4 (size (array_1d_2bytes_overflow, 1))
+
+ call test_size_4 (size (array_1d_4bytes_overflow))
+ call test_size_4 (size (array_1d_4bytes_overflow, 1))
+
+ call test_size_4 (size (array_2d_1byte_overflow, 1))
+ call test_size_4 (size (array_2d_1byte_overflow, 2))
+ call test_size_4 (size (array_2d_2bytes_overflow, 1))
+ call test_size_4 (size (array_2d_2bytes_overflow, 2))
+
+ call test_size_4 (size (array_3d_1byte_overflow, 1))
+ call test_size_4 (size (array_3d_1byte_overflow, 2))
+ call test_size_4 (size (array_3d_1byte_overflow, 3))
+
+ ! Kind 1.
+
+ call test_size_1 (size (array_1d_1byte_overflow, 1, 1))
+ call test_size_1 (size (array_1d_2bytes_overflow, 1, 1))
+ call test_size_1 (size (array_1d_4bytes_overflow, 1, 1))
+
+ call test_size_1 (size (array_2d_1byte_overflow, 1, 1))
+ call test_size_1 (size (array_2d_1byte_overflow, 2, 1))
+ call test_size_1 (size (array_2d_2bytes_overflow, 1, 1))
+ call test_size_1 (size (array_2d_2bytes_overflow, 2, 1))
+
+ call test_size_1 (size (array_3d_1byte_overflow, 1, 1))
+ call test_size_1 (size (array_3d_1byte_overflow, 2, 1))
+ call test_size_1 (size (array_3d_1byte_overflow, 3, 1))
+
+ ! Kind 2.
+ call test_size_2 (size (array_1d_1byte_overflow, 1, 2))
+ call test_size_2 (size (array_1d_2bytes_overflow, 1, 2))
+ call test_size_2 (size (array_1d_4bytes_overflow, 1, 2))
+
+ call test_size_2 (size (array_2d_1byte_overflow, 1, 2))
+ call test_size_2 (size (array_2d_1byte_overflow, 2, 2))
+ call test_size_2 (size (array_2d_2bytes_overflow, 1, 2))
+ call test_size_2 (size (array_2d_2bytes_overflow, 2, 2))
+
+ call test_size_2 (size (array_3d_1byte_overflow, 1, 2))
+ call test_size_2 (size (array_3d_1byte_overflow, 2, 2))
+ call test_size_2 (size (array_3d_1byte_overflow, 3, 2))
+
+ ! Kind 4.
+ call test_size_4 (size (array_1d_1byte_overflow, 1, 4))
+ call test_size_4 (size (array_1d_2bytes_overflow, 1, 4))
+ call test_size_4 (size (array_1d_4bytes_overflow, 1, 4))
+
+ call test_size_4 (size (array_2d_1byte_overflow, 1, 4))
+ call test_size_4 (size (array_2d_1byte_overflow, 2, 4))
+ call test_size_4 (size (array_2d_2bytes_overflow, 1, 4))
+ call test_size_4 (size (array_2d_2bytes_overflow, 2, 4))
+
+ call test_size_4 (size (array_3d_1byte_overflow, 1, 4))
+ call test_size_4 (size (array_3d_1byte_overflow, 2, 4))
+ call test_size_4 (size (array_3d_1byte_overflow, 3, 4))
+
+ ! Kind 8.
+ call test_size_8 (size (array_1d_1byte_overflow, 1, 8))
+ call test_size_8 (size (array_1d_2bytes_overflow, 1, 8))
+ call test_size_8 (size (array_1d_4bytes_overflow, 1, 8))
+
+ call test_size_8 (size (array_2d_1byte_overflow, 1, 8))
+ call test_size_8 (size (array_2d_1byte_overflow, 2, 8))
+ call test_size_8 (size (array_2d_2bytes_overflow, 1, 8))
+ call test_size_8 (size (array_2d_2bytes_overflow, 2, 8))
+
+ call test_size_8 (size (array_3d_1byte_overflow, 1, 8))
+ call test_size_8 (size (array_3d_1byte_overflow, 2, 8))
+ call test_size_8 (size (array_3d_1byte_overflow, 3, 8))
+
+ print *, "" ! Breakpoint before deallocate.
deallocate (allocatable_array_1d)
deallocate (allocatable_array_2d)
+
+ deallocate (array_3d_1byte_overflow)
+
+ deallocate (array_2d_2bytes_overflow)
+ deallocate (array_2d_1byte_overflow)
+
+ deallocate (array_1d_4bytes_overflow)
+ deallocate (array_1d_2bytes_overflow)
+ deallocate (array_1d_1byte_overflow)
+
array_1d_p => null ()
array_2d_p => null ()
print *, allocated (allocatable_array_2d)
contains
+ subroutine test_size_1 (answer)
+ integer*1 :: answer
+
+ print *, answer ! Test Breakpoint 1
+ end subroutine test_size_1
+
+ subroutine test_size_2 (answer)
+ integer*2 :: answer
+
+ print *, answer ! Test Breakpoint 2
+ end subroutine test_size_2
+
+ subroutine test_size_4 (answer)
+ integer*4 :: answer
+
+ print *, answer ! Test Breakpoint 3
+ end subroutine test_size_4
- subroutine test_size (answer)
- integer :: answer
+ subroutine test_size_8 (answer)
+ integer*8 :: answer
- print *,answer ! Test Breakpoint
- end subroutine test_size
+ print *, answer ! Test Breakpoint 4
+ end subroutine test_size_8
end program test
projects / binutils-gdb.git / commitdiff