From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mga11.intel.com (mga11.intel.com [192.55.52.93]) by sourceware.org (Postfix) with ESMTPS id 1C6F33857C78 for ; Wed, 9 Mar 2022 10:40:09 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org 1C6F33857C78 X-IronPort-AV: E=McAfee;i="6200,9189,10280"; a="252514593" X-IronPort-AV: E=Sophos;i="5.90,167,1643702400"; d="scan'208";a="252514593" Received: from orsmga006.jf.intel.com ([10.7.209.51]) by fmsmga102.fm.intel.com with ESMTP/TLS/ECDHE-RSA-AES256-GCM-SHA384; 09 Mar 2022 02:40:08 -0800 X-IronPort-AV: E=Sophos;i="5.90,167,1643702400"; d="scan'208";a="513481466" Received: from labpcdell3650-003.iul.intel.com (HELO localhost) ([172.28.49.87]) by orsmga006-auth.jf.intel.com with ESMTP/TLS/ECDHE-RSA-AES256-GCM-SHA384; 09 Mar 2022 02:40:00 -0800 From: Nils-Christian Kempke To: gdb-patches@sourceware.org Subject: [PATCH 09/11] gdb/fortran: rewrite intrinsic handling and add some missing overloads Date: Wed, 9 Mar 2022 11:39:20 +0100 Message-Id: <20220309103922.3257803-10-nils-christian.kempke@intel.com> X-Mailer: git-send-email 2.25.1 In-Reply-To: <20220309103922.3257803-1-nils-christian.kempke@intel.com> References: <20220309103922.3257803-1-nils-christian.kempke@intel.com> MIME-Version: 1.0 Content-Type: text/plain; charset="us-ascii" Content-Transfer-Encoding: 7bit X-Spam-Status: No, score=-10.8 required=5.0 tests=BAYES_00, DKIMWL_WL_HIGH, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, GIT_PATCH_0, RCVD_IN_MSPIKE_H2, SPF_HELO_NONE, SPF_NONE, TXREP, T_SCC_BODY_TEXT_LINE autolearn=ham autolearn_force=no version=3.4.4 X-Spam-Checker-Version: SpamAssassin 3.4.4 (2020-01-24) on server2.sourceware.org X-BeenThere: gdb-patches@sourceware.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gdb-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , X-List-Received-Date: Wed, 09 Mar 2022 10:40:15 -0000 The operators FLOOR, CEILING, CMPLX, LBOUND, UBOUND, and SIZE accept (some only with Fortran 2003) the optional parameter KIND. This parameter determines the kind of the associated return value. So far, implementation of this kind parameter has been missing in GDB. Additionally, the one argument overload for the CMPLX intrinsic function was not yet available. This patch adds overloads for all above mentioned functions to the Fortran intrinsics handling in GDB. It re-writes the intrinsic function handling section to use the helper methods wrap_unop_intrinsic/wrap_binop_intrinsic/wrap_triop_intrinsic. These methods define the action taken when a Fortran intrinsic function is called with a certain amount of arguments (1/2/3). The helper methods fortran_wrap2_kind and fortran_wrap3_kind have been added as equivalents to the existing wrap and wrap2 methods. After adding more overloads to the intrinsics handling, some of the operation names were no longer accurate. E.g. UNOP_FORTRAN_CEILING has been renamed to FORTRAN_CEILING as it is no longer a purely unary intrinsic function. This patch also introduces intrinsic functions with one, two, or three arguments to the Fortran parser and the UNOP_OR_BINOP_OR_TERNOP_INTRINSIC token has been added. gdb/ChangeLog: 2022-03-02 Nils-Christian Kempke * f-exp.h (eval_op_f_ceil): New declaration for additional overload. (eval_op_f_floor): New declaration for additional overload. (eval_op_f_cmplx): New declarations for additional overloads. (eval_op_f_array_size): New declaration for additional overload. (binary_kind_ftype): New typedef. (fortran_kind_2arg): New operation template. (ternary_kind_ftype): New typedef. (fortran_kind_3arg): New operation template. (namespace::expr): Add new overloads to Fortran operations. (fortran_cmplx_operation): Deleted. Replaced by dedicated CMPLX handling in f-lang.c. (fortran_bound_3arg): New class for bound operation overload with three arguments. * f-exp.y (wrap_unop_intrinsic): New method. (wrap_binop_intrinsic): New method. (wrap_ternop_intrinsic): New method. (fortran_wrap2_kind): New method. (fortran_wrap3_kind): New method. (UNOP_OR_BINOP_OR_TERNOP_INTRINSIC): New token. (UNOP_OR_BINOP_INTRINSIC): Use wrap_unop_intrinsic or wrap_binop_intrinsic depending on number of arguments. (UNOP_INTRINSIC): Rewrite expression handling to use wrap_unop_intrinsic. (BINOP_INTRINSIC): Rewrite expression handling to use wrap_binop_intrinsic. (UNOP_OR_BINOP_OR_TERNOP_INTRINSIC): New expression handling. (f_keywords): Change token of some intrinsics for optional kind argument. * f-lang.c (fortran_bounds_for_dimension): Change signature to accept a type to compute in. (fortran_array_size): Change signature to accept a type to compute in. (eval_op_f_array_size): New overload. (fortran_ceil_operation): New method. (eval_op_f_ceil): New overload. (fortran_bounds_all_dims): Adapt return type to builtin_integer. (fortran_floor_operation): New method. (eval_op_f_floor): New overload. (eval_op_f_cmplx): New overloads. (fortran_bound_2arg): Adapt for new fortran_bounds_for_dimension signature. (fortran_bound_3arg): New method. * std-operator.def: Adapt names of Fortran operators. gdb/testsuite/ChangeLog: 2022-03-02 Nils-Christian Kempke * gdb.fortran/intrinsics.exp: Add tests for CEILING, FLOOR and CMPLEX with kind parameter and test for overflows and return types. * gdb.fortran/lbound-ubound.F90: Add arrays with possibly overflowing dimensions and add some test. * gdb.fortran/lbound-ubound.exp: Add LBOUND/UBOUND test for overflow in array dimensions when supplying the KIND parameter. * gdb.fortran/size.exp: Add tests for overflow when using the KIND parameter. * gdb.fortran/size.f90: Add compiled KIND parameter tests. Signed-off-by: Nils-Christian Kempke --- gdb/f-exp.h | 182 ++++++++++-- gdb/f-exp.y | 312 ++++++++++++++------ gdb/f-lang.c | 212 ++++++++++--- gdb/std-operator.def | 10 +- gdb/testsuite/gdb.fortran/intrinsics.exp | 46 ++- gdb/testsuite/gdb.fortran/lbound-ubound.F90 | 49 ++- gdb/testsuite/gdb.fortran/lbound-ubound.exp | 27 +- gdb/testsuite/gdb.fortran/size.exp | 84 +++++- gdb/testsuite/gdb.fortran/size.f90 | 213 ++++++++++--- 9 files changed, 900 insertions(+), 235 deletions(-) diff --git a/gdb/f-exp.h b/gdb/f-exp.h index d5d267e778..6b6bf61722 100644 --- a/gdb/f-exp.h +++ b/gdb/f-exp.h @@ -32,26 +32,85 @@ extern struct value *eval_op_f_mod (struct type *expect_type, 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, @@ -92,7 +151,7 @@ extern struct value *eval_op_f_rank (struct type *expect_type, /* 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. */ @@ -113,6 +172,16 @@ extern struct value *eval_op_f_array_size (struct type *expect_type, 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 @@ -127,11 +196,68 @@ extern struct value *eval_op_f_array_shape (struct type *expect_type, 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 +class fortran_kind_2arg + : public tuple_holding_operation +{ +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 +class fortran_kind_3arg + : public tuple_holding_operation +{ +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; -using fortran_ceil_operation = unop_operation; -using fortran_floor_operation = unop_operation; +using fortran_ceil_operation_1arg = unop_operation; +using fortran_ceil_operation_2arg = fortran_kind_2arg; +using fortran_floor_operation_1arg = unop_operation; +using fortran_floor_operation_2arg = fortran_kind_2arg; using fortran_kind_operation = unop_operation; using fortran_allocated_operation = unop_operation; using fortran_array_size_2arg = binop_operation; +using fortran_array_size_3arg = fortran_kind_3arg; using fortran_array_shape_operation = unop_operation; - -/* The Fortran "complex" operation. */ -class fortran_cmplx_operation - : public tuple_holding_operation -{ -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; +using fortran_cmplx_operation_2arg = binop_operation; +using fortran_cmplx_operation_3arg = fortran_kind_3arg; /* OP_RANGE for Fortran. */ class fortran_range_operation @@ -273,6 +384,21 @@ class fortran_bound_2arg { return std::get<0> (m_storage); } }; +/* Three-argument form of Fortran ubound/lbound intrinsics. */ +class fortran_bound_3arg + : public tuple_holding_operation +{ +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 diff --git a/gdb/f-exp.y b/gdb/f-exp.y index c062754ae4..38b94d4340 100644 --- a/gdb/f-exp.y +++ b/gdb/f-exp.y @@ -90,6 +90,18 @@ static void push_kind_type (LONGEST val, struct type *type); 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 +static void fortran_wrap2_kind (type *base_type); + +template +static void fortran_wrap3_kind (type *base_type); + using namespace expr; %} @@ -181,7 +193,7 @@ static int parse_number (struct parser_state *, const char *, int, %token ASSIGN_MODIFY %token UNOP_INTRINSIC BINOP_INTRINSIC -%token UNOP_OR_BINOP_INTRINSIC +%token UNOP_OR_BINOP_INTRINSIC UNOP_OR_BINOP_OR_TERNOP_INTRINSIC %left ',' %left ABOVE_COMMA @@ -248,54 +260,6 @@ exp : KIND '(' exp ')' %prec UNARY { pstate->wrap (); } ; -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 (); - else - pstate->wrap2 (); - } - else if ($1 == FORTRAN_ARRAY_SIZE) - { - if (n == 1) - pstate->wrap (); - else - pstate->wrap2 (); - } - else - { - std::vector 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 @@ -314,50 +278,56 @@ exp : exp '(' 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 (); - break; - case UNOP_FORTRAN_FLOOR: - pstate->wrap (); - break; - case UNOP_FORTRAN_CEILING: - pstate->wrap (); + case 1: + wrap_unop_intrinsic ($1); break; - case UNOP_FORTRAN_ALLOCATED: - pstate->wrap (); - break; - case UNOP_FORTRAN_RANK: - pstate->wrap (); - break; - case UNOP_FORTRAN_SHAPE: - pstate->wrap (); - break; - case UNOP_FORTRAN_LOC: - pstate->wrap (); + 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 (); + case 1: + wrap_unop_intrinsic ($1); break; - case BINOP_FORTRAN_MODULO: - pstate->wrap2 (); + case 2: + wrap_binop_intrinsic ($1); break; - case BINOP_FORTRAN_CMPLX: - pstate->wrap2 (); + case 3: + wrap_ternop_intrinsic ($1); break; default: - gdb_assert_not_reached ("unhandled intrinsic"); + gdb_assert_not_reached + ("wrong number of arguments for intrinsics"); } } ; @@ -835,6 +805,176 @@ name_not_typename : NAME %% +/* 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 (); + break; + case FORTRAN_FLOOR: + pstate->wrap (); + break; + case FORTRAN_CEILING: + pstate->wrap (); + break; + case UNOP_FORTRAN_ALLOCATED: + pstate->wrap (); + break; + case UNOP_FORTRAN_RANK: + pstate->wrap (); + break; + case UNOP_FORTRAN_SHAPE: + pstate->wrap (); + break; + case UNOP_FORTRAN_LOC: + pstate->wrap (); + break; + case FORTRAN_ASSOCIATED: + pstate->wrap (); + break; + case FORTRAN_ARRAY_SIZE: + pstate->wrap (); + break; + case FORTRAN_CMPLX: + pstate->wrap (); + break; + case FORTRAN_LBOUND: + case FORTRAN_UBOUND: + pstate->push_new + (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 + (parse_f_type (pstate)->builtin_integer); + break; + case FORTRAN_CEILING: + fortran_wrap2_kind + (parse_f_type (pstate)->builtin_integer); + break; + case BINOP_MOD: + pstate->wrap2 (); + break; + case BINOP_FORTRAN_MODULO: + pstate->wrap2 (); + break; + case FORTRAN_CMPLX: + pstate->wrap2 (); + break; + case FORTRAN_ASSOCIATED: + pstate->wrap2 (); + break; + case FORTRAN_ARRAY_SIZE: + pstate->wrap2 (); + break; + case FORTRAN_LBOUND: + case FORTRAN_UBOUND: + pstate->push_new + (code, pstate->pop (), pstate->pop ()); + 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 (code, std::move (arg1), + std::move (arg2), follow_type); + } + break; + case FORTRAN_ARRAY_SIZE: + fortran_wrap3_kind + (parse_f_type (pstate)->builtin_integer); + break; + case FORTRAN_CMPLX: + fortran_wrap3_kind + (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 +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 (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 +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 (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. */ @@ -1166,16 +1306,16 @@ static const token f_keywords[] = { "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 }, }; diff --git a/gdb/f-lang.c b/gdb/f-lang.c index bea24ce0ca..20af3096b1 100644 --- a/gdb/f-lang.c +++ b/gdb/f-lang.c @@ -133,9 +133,9 @@ fortran_bounds_all_dims (bool lbound_p, /* 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); @@ -170,13 +170,12 @@ fortran_bounds_all_dims (bool lbound_p, /* 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)); @@ -190,9 +189,6 @@ fortran_bounds_for_dimension (bool lbound_p, 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) @@ -208,7 +204,7 @@ fortran_bounds_for_dimension (bool lbound_p, 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. */ @@ -578,8 +574,8 @@ eval_op_f_associated (struct type *expect_type, } /* 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 @@ -588,9 +584,8 @@ eval_op_f_associated (struct type *expect_type, 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)); @@ -642,8 +637,6 @@ fortran_array_size (struct gdbarch *gdbarch, const language_defn *lang, array_type = TYPE_TARGET_TYPE (array_type); } - struct type *result_type - = builtin_f_type (gdbarch)->builtin_integer; return value_from_longest (result_type, result); } @@ -657,7 +650,9 @@ eval_op_f_array_size (struct type *expect_type, 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. */ @@ -671,7 +666,21 @@ eval_op_f_array_size (struct type *expect_type, 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 @@ -820,7 +829,22 @@ eval_op_f_mod (struct type *expect_type, struct expression *exp, 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, @@ -828,32 +852,59 @@ 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. */ @@ -896,7 +947,25 @@ eval_op_f_modulo (struct type *expect_type, struct expression *exp, 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, @@ -904,8 +973,28 @@ 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. */ @@ -1478,8 +1567,8 @@ fortran_bound_2arg::evaluate (struct type *expect_type, /* 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")); @@ -1487,7 +1576,34 @@ fortran_bound_2arg::evaluate (struct type *expect_type, 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 diff --git a/gdb/std-operator.def b/gdb/std-operator.def index baaa5947e2..a5c990c704 100644 --- a/gdb/std-operator.def +++ b/gdb/std-operator.def @@ -375,19 +375,21 @@ OP (OP_F77_UNDETERMINED_ARGLIST) /* 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) diff --git a/gdb/testsuite/gdb.fortran/intrinsics.exp b/gdb/testsuite/gdb.fortran/intrinsics.exp index c4020737c1..29cff35c55 100644 --- a/gdb/testsuite/gdb.fortran/intrinsics.exp +++ b/gdb/testsuite/gdb.fortran/intrinsics.exp @@ -61,15 +61,37 @@ gdb_test "p mod (-8, 5)" " = -3" 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 @@ -85,6 +107,20 @@ gdb_test "ptype MODULO (3.0,2.0)" "type = real\\*8" 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" diff --git a/gdb/testsuite/gdb.fortran/lbound-ubound.F90 b/gdb/testsuite/gdb.fortran/lbound-ubound.F90 index 37145724a3..aa5be85bb5 100644 --- a/gdb/testsuite/gdb.fortran/lbound-ubound.F90 +++ b/gdb/testsuite/gdb.fortran/lbound-ubound.F90 @@ -17,8 +17,8 @@ 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:" @@ -51,8 +51,8 @@ end subroutine do_test 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 @@ -70,11 +70,34 @@ program test 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) @@ -90,9 +113,27 @@ program test 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. diff --git a/gdb/testsuite/gdb.fortran/lbound-ubound.exp b/gdb/testsuite/gdb.fortran/lbound-ubound.exp index 671b251c79..38b6d46e22 100644 --- a/gdb/testsuite/gdb.fortran/lbound-ubound.exp +++ b/gdb/testsuite/gdb.fortran/lbound-ubound.exp @@ -42,9 +42,10 @@ if {![gdb_is_target_native]} { 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. @@ -68,8 +69,8 @@ while { $test_count < 500 } { 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 $" { @@ -77,7 +78,7 @@ while { $test_count < 500 } { } } - if ($found_final_breakpoint) { + if ($found_dealloc_breakpoint) { break } @@ -194,10 +195,26 @@ while { $test_count < 500 } { } } +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. diff --git a/gdb/testsuite/gdb.fortran/size.exp b/gdb/testsuite/gdb.fortran/size.exp index 81b58405cf..fb49e286e5 100644 --- a/gdb/testsuite/gdb.fortran/size.exp +++ b/gdb/testsuite/gdb.fortran/size.exp @@ -29,28 +29,33 @@ if ![fortran_runto_main] { 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 } @@ -61,26 +66,81 @@ while { $test_count < 500 } { # 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} { diff --git a/gdb/testsuite/gdb.fortran/size.f90 b/gdb/testsuite/gdb.fortran/size.f90 index 76f71ab60f..c924d84673 100644 --- a/gdb/testsuite/gdb.fortran/size.f90 +++ b/gdb/testsuite/gdb.fortran/size.f90 @@ -28,74 +28,184 @@ program test 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 () @@ -108,11 +218,28 @@ program test 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 -- 2.25.1 Intel Deutschland GmbH Registered Address: Am Campeon 10, 85579 Neubiberg, Germany Tel: +49 89 99 8853-0, www.intel.de Managing Directors: Christin Eisenschmid, Sharon Heck, Tiffany Doon Silva Chairperson of the Supervisory Board: Nicole Lau Registered Office: Munich Commercial Register: Amtsgericht Muenchen HRB 186928