* [PATCH 06/11] gdb/fortran: clean-up Fortran intrinsic types
2022-03-09 10:39 [PATCH 00/11] Improve Fortran intrinsic types and procedures Nils-Christian Kempke
` (4 preceding siblings ...)
2022-03-09 10:39 ` [PATCH 05/11] gdb/fortran: change default logical type to builtin_logical Nils-Christian Kempke
@ 2022-03-09 10:39 ` Nils-Christian Kempke
2022-04-07 14:33 ` Tom Tromey
2022-03-09 10:39 ` [PATCH 07/11] gdb/fortran: Change GDB print for fortran default types Nils-Christian Kempke
` (4 subsequent siblings)
10 siblings, 1 reply; 28+ messages in thread
From: Nils-Christian Kempke @ 2022-03-09 10:39 UTC (permalink / raw)
To: gdb-patches
The currently implemented intrinsic type handling for Fortran missed some
tokens and their parsing. While still not all Fortran type kinds are
implemented this patch at least makes the currently handled types
consistent. As an example for what this patch does, consider the
intrinsic type INTEGER. GDB implemented the handling of the
keywords "integer" and "integer_2" but missed "integer_4" and "integer_8"
even though their corresponding internal types were already available as
the Fortran builtin types builtin_integer and builtin_integer_s8.
Similar problems applied to LOGICAL, REAL, and COMPLEX. This patch adds
all missing tokens and their parsing. Whenever a section containing the
type handling was touched, it also was reordered to be in a more easy to
grasp order. All INTEGER/REAL/LOGICAL/COMPLEX types were grouped
together and ordered ascending in their size making a missing one more
easy to spot.
Before this change GDB would print the following when tyring to use the
INTEGER keywords:
(gdb) set language fortran
(gdb) ptype integer*1
unsupported kind 1 for type integer
(gdb) ptype integer_1
No symbol table is loaded. Use the "file" command.
(gdb) ptype integer*2
type = integer*2
(gdb) ptype integer_2
type = integer*2
(gdb) ptype integer*4
type = integer
(gdb) ptype integer_4
No symbol table is loaded. Use the "file" command.
(gdb) ptype integer*8
type = integer*8
(gdb) ptype integer_8
No symbol table is loaded. Use the "file" command.
(gdb) ptype integer
type = integer
With this patch all keywords are available and the GDB prints:
(gdb) set language fortran
(gdb) ptype integer*1
type = integer*1
(gdb) ptype integer_1
type = integer*1
(gdb) ptype integer*2
type = integer*2
(gdb) ptype integer_2
type = integer*2
(gdb) ptype integer*4
type = integer*4
(gdb) ptype integer_4
type = integer*4
(gdb) ptype integer*8
type = integer*8
(gdb) ptype integer_8
type = integer*8
(gdb) ptype integer
type = integer
The described changes have been applied to INTEGER, REAL, COMPLEX,
and LOGICAL. Existing testcases have been adapted to reflect the
new behavior. Tests for formerly missing types have been added.
gdb/ChangeLog:
2022-02-22 Nils-Christian Kempke <nils-christian.kempke@intel.com>
* f-exp.y (tokens): Add missing INTEGER, REAL, COMPLEX, and
LOGICAL tokens and reorder them.
(typebase): Add parsing rules for new tokens and reorder the
rules.
(f77_keywords): Add missing keywords and reorder them.
* f-lang.c (build_fortran_types): Reorder types.
* f-lang.h (builtin_f_type): Reorder types.
gdb/testsuite/ChangeLog:
2022-02-22 Nils-Christian Kempke <nils-christian.kempke@intel.com>
* types.exp: Add tests for default types. Add tests for all
Fortran type keywords.
Signed-off-by: Nils-Christian Kempke <nils-christian.kempke@intel.com>
---
gdb/f-exp.y | 50 +++++++++++++++++++----------
gdb/f-lang.c | 24 +++++++-------
gdb/f-lang.h | 4 +--
gdb/testsuite/gdb.fortran/types.exp | 31 +++++++++++++++---
4 files changed, 74 insertions(+), 35 deletions(-)
diff --git a/gdb/f-exp.y b/gdb/f-exp.y
index f939efb5c4..e07af7322a 100644
--- a/gdb/f-exp.y
+++ b/gdb/f-exp.y
@@ -167,11 +167,12 @@ static int parse_number (struct parser_state *, const char *, int,
/* Special type cases, put in to allow the parser to distinguish different
legal basetypes. */
-%token INT_KEYWORD INT_S2_KEYWORD LOGICAL_S1_KEYWORD LOGICAL_S2_KEYWORD
+%token INT_S1_KEYWORD INT_S2_KEYWORD INT_KEYWORD INT_S4_KEYWORD INT_S8_KEYWORD
+%token LOGICAL_S1_KEYWORD LOGICAL_S2_KEYWORD LOGICAL_KEYWORD LOGICAL_S4_KEYWORD
%token LOGICAL_S8_KEYWORD
-%token LOGICAL_KEYWORD REAL_KEYWORD REAL_S8_KEYWORD REAL_S16_KEYWORD
-%token COMPLEX_KEYWORD
-%token COMPLEX_S4_KEYWORD COMPLEX_S8_KEYWORD COMPLEX_S16_KEYWORD
+%token REAL_KEYWORD REAL_S4_KEYWORD REAL_S8_KEYWORD REAL_S16_KEYWORD
+%token COMPLEX_KEYWORD COMPLEX_S4_KEYWORD COMPLEX_S8_KEYWORD
+%token COMPLEX_S16_KEYWORD
%token BOOL_AND BOOL_OR BOOL_NOT
%token SINGLE DOUBLE PRECISION
%token <lval> CHARACTER
@@ -757,22 +758,32 @@ func_mod: '(' ')'
typebase /* Implements (approximately): (type-qualifier)* type-specifier */
: TYPENAME
{ $$ = $1.type; }
+ | INT_S1_KEYWORD
+ { $$ = parse_f_type (pstate)->builtin_integer_s1; }
+ | INT_S2_KEYWORD
+ { $$ = parse_f_type (pstate)->builtin_integer_s2; }
| INT_KEYWORD
{ $$ = parse_f_type (pstate)->builtin_integer; }
- | INT_S2_KEYWORD
- { $$ = parse_f_type (pstate)->builtin_integer_s2; }
+ | INT_S4_KEYWORD
+ { $$ = parse_f_type (pstate)->builtin_integer; }
+ | INT_S8_KEYWORD
+ { $$ = parse_f_type (pstate)->builtin_integer_s8; }
| CHARACTER
{ $$ = parse_f_type (pstate)->builtin_character; }
- | LOGICAL_S8_KEYWORD
- { $$ = parse_f_type (pstate)->builtin_logical_s8; }
- | LOGICAL_KEYWORD
- { $$ = parse_f_type (pstate)->builtin_logical; }
- | LOGICAL_S2_KEYWORD
- { $$ = parse_f_type (pstate)->builtin_logical_s2; }
| LOGICAL_S1_KEYWORD
{ $$ = parse_f_type (pstate)->builtin_logical_s1; }
+ | LOGICAL_S2_KEYWORD
+ { $$ = parse_f_type (pstate)->builtin_logical_s2; }
+ | LOGICAL_KEYWORD
+ { $$ = parse_f_type (pstate)->builtin_logical; }
+ | LOGICAL_S4_KEYWORD
+ { $$ = parse_f_type (pstate)->builtin_logical; }
+ | LOGICAL_S8_KEYWORD
+ { $$ = parse_f_type (pstate)->builtin_logical_s8; }
| REAL_KEYWORD
{ $$ = parse_f_type (pstate)->builtin_real; }
+ | REAL_S4_KEYWORD
+ { $$ = parse_f_type (pstate)->builtin_real; }
| REAL_S8_KEYWORD
{ $$ = parse_f_type (pstate)->builtin_real_s8; }
| REAL_S16_KEYWORD
@@ -1127,21 +1138,26 @@ static const struct f77_boolean_val boolean_values[] =
static const struct token f77_keywords[] =
{
/* Historically these have always been lowercase only in GDB. */
+ { "character", CHARACTER, OP_NULL, true },
{ "complex", COMPLEX_KEYWORD, OP_NULL, true },
{ "complex_4", COMPLEX_S4_KEYWORD, OP_NULL, true },
{ "complex_8", COMPLEX_S8_KEYWORD, OP_NULL, true },
{ "complex_16", COMPLEX_S16_KEYWORD, OP_NULL, true },
- { "character", CHARACTER, OP_NULL, true },
+ { "integer_1", INT_S1_KEYWORD, OP_NULL, true },
{ "integer_2", INT_S2_KEYWORD, OP_NULL, true },
+ { "integer_4", INT_S4_KEYWORD, OP_NULL, true },
+ { "integer", INT_KEYWORD, OP_NULL, true },
+ { "integer_8", INT_S8_KEYWORD, OP_NULL, true },
{ "logical_1", LOGICAL_S1_KEYWORD, OP_NULL, true },
{ "logical_2", LOGICAL_S2_KEYWORD, OP_NULL, true },
- { "logical_8", LOGICAL_S8_KEYWORD, OP_NULL, true },
- { "integer", INT_KEYWORD, OP_NULL, true },
{ "logical", LOGICAL_KEYWORD, OP_NULL, true },
+ { "logical_4", LOGICAL_S4_KEYWORD, OP_NULL, true },
+ { "logical_8", LOGICAL_S8_KEYWORD, OP_NULL, true },
+ { "real", REAL_KEYWORD, OP_NULL, true },
+ { "real_4", REAL_S4_KEYWORD, OP_NULL, true },
+ { "real_8", REAL_S8_KEYWORD, OP_NULL, true },
{ "real_16", REAL_S16_KEYWORD, OP_NULL, true },
{ "sizeof", SIZEOF, OP_NULL, true },
- { "real_8", REAL_S8_KEYWORD, OP_NULL, true },
- { "real", REAL_KEYWORD, OP_NULL, true },
{ "single", SINGLE, OP_NULL, true },
{ "double", DOUBLE, OP_NULL, true },
{ "precision", PRECISION, OP_NULL, true },
diff --git a/gdb/f-lang.c b/gdb/f-lang.c
index 8e9af7661c..5a97beada2 100644
--- a/gdb/f-lang.c
+++ b/gdb/f-lang.c
@@ -1619,28 +1619,28 @@ build_fortran_types (struct gdbarch *gdbarch)
builtin_f_type->builtin_logical_s1
= arch_boolean_type (gdbarch, TARGET_CHAR_BIT, 1, "logical*1");
- builtin_f_type->builtin_integer_s1
- = arch_integer_type (gdbarch, TARGET_CHAR_BIT, 0, "integer*1");
-
- builtin_f_type->builtin_integer_s2
- = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch), 0, "integer*2");
-
- builtin_f_type->builtin_integer_s8
- = arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch), 0,
- "integer*8");
-
builtin_f_type->builtin_logical_s2
= arch_boolean_type (gdbarch, gdbarch_short_bit (gdbarch), 1, "logical*2");
+ builtin_f_type->builtin_logical
+ = arch_boolean_type (gdbarch, gdbarch_int_bit (gdbarch), 1, "logical*4");
+
builtin_f_type->builtin_logical_s8
= arch_boolean_type (gdbarch, gdbarch_long_long_bit (gdbarch), 1,
"logical*8");
+ builtin_f_type->builtin_integer_s1
+ = arch_integer_type (gdbarch, TARGET_CHAR_BIT, 0, "integer*1");
+
+ builtin_f_type->builtin_integer_s2
+ = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch), 0, "integer*2");
+
builtin_f_type->builtin_integer
= arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 0, "integer");
- builtin_f_type->builtin_logical
- = arch_boolean_type (gdbarch, gdbarch_int_bit (gdbarch), 1, "logical*4");
+ builtin_f_type->builtin_integer_s8
+ = arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch), 0,
+ "integer*8");
builtin_f_type->builtin_real
= arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
diff --git a/gdb/f-lang.h b/gdb/f-lang.h
index e22b167c38..d8fad03e87 100644
--- a/gdb/f-lang.h
+++ b/gdb/f-lang.h
@@ -307,13 +307,13 @@ extern int calc_f77_array_dims (struct type *);
struct builtin_f_type
{
struct type *builtin_character;
- struct type *builtin_integer;
struct type *builtin_integer_s1;
struct type *builtin_integer_s2;
+ struct type *builtin_integer;
struct type *builtin_integer_s8;
- struct type *builtin_logical;
struct type *builtin_logical_s1;
struct type *builtin_logical_s2;
+ struct type *builtin_logical;
struct type *builtin_logical_s8;
struct type *builtin_real;
struct type *builtin_real_s8;
diff --git a/gdb/testsuite/gdb.fortran/types.exp b/gdb/testsuite/gdb.fortran/types.exp
index 8122cbcca3..5ab44b10a3 100644
--- a/gdb/testsuite/gdb.fortran/types.exp
+++ b/gdb/testsuite/gdb.fortran/types.exp
@@ -71,13 +71,35 @@ proc test_float_literal_types_accepted {} {
gdb_test "pt 10e20" "type = real\\*\[0-9\]+"
}
+# Test the default primitive Fortran types.
+proc test_default_types {} {
+ gdb_test "ptype integer*4" "type = integer"
+ gdb_test "ptype integer_4" "type = integer"
+
+ gdb_test "ptype logical" "type = logical*4"
+
+ gdb_test "ptype real*4" "type = real"
+ gdb_test "ptype real_4" "type = real"
+
+ gdb_test "ptype complex" "type = complex*4"
+}
+
# Test the the primitive Fortran types, those that GDB should always
# know, even if the program does not define them, are in fact, known.
proc test_primitive_types_known {} {
- foreach type {void character logical*1 integer*1 integer*2 integer*8 \
- logical*2 logical*8 integer logical*4 real \
- real*8 real*16 complex*4 complex*8 complex*16} {
- gdb_test "ptype $type" [string_to_regexp "type = $type"]
+ foreach type {void character \
+ integer*1 integer*2 integer integer*8 \
+ integer_1 integer_2 integer_8 \
+ logical*1 logical*2 logical*4 logical*8 \
+ logical_1 logical_2 logical_4 logical_8 \
+ real real*8 real*16 real_8 real_16 \
+ complex*4 complex*8 complex*16 \
+ complex_4 complex_8 complex_16} {
+
+ # While TYPE_KIND is allowed as input, GDB will always return the
+ # Fortran notation TYPE*KIND
+ regsub -all "_" $type "\*" type_res
+ gdb_test "ptype $type" [string_to_regexp "type = $type_res"]
}
}
@@ -91,6 +113,7 @@ gdb_test "set print sevenbit-strings" ""
if [set_lang_fortran] then {
test_primitive_types_known
+ test_default_types
test_integer_literal_types_accepted
test_integer_literal_types_rejected
test_logical_literal_types_accepted
--
2.25.1
Intel Deutschland GmbH
Registered Address: Am Campeon 10, 85579 Neubiberg, Germany
Tel: +49 89 99 8853-0, www.intel.de <http://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
^ permalink raw reply [flat|nested] 28+ messages in thread* [PATCH 09/11] gdb/fortran: rewrite intrinsic handling and add some missing overloads
2022-03-09 10:39 [PATCH 00/11] Improve Fortran intrinsic types and procedures Nils-Christian Kempke
` (7 preceding siblings ...)
2022-03-09 10:39 ` [PATCH 08/11] gdb/fortran: rename f77_keywords to f_keywords Nils-Christian Kempke
@ 2022-03-09 10:39 ` Nils-Christian Kempke
2022-04-07 14:49 ` Tom Tromey
2022-04-13 5:14 ` Tom de Vries
2022-03-09 10:39 ` [PATCH 10/11] gdb/fortran/testsuite: add complex from integers test Nils-Christian Kempke
2022-03-09 10:39 ` [PATCH 11/11] gdb/doc: add section about fortran intrinsic functions and types Nils-Christian Kempke
10 siblings, 2 replies; 28+ messages in thread
From: Nils-Christian Kempke @ 2022-03-09 10:39 UTC (permalink / raw)
To: gdb-patches
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 <nils-christian.kempke@intel.com>
* 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 <nils-christian.kempke@intel.com>
* 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 <nils-christian.kempke@intel.com>
---
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<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,
@@ -152,31 +278,16 @@ using fortran_array_size_1arg = unop_operation<FORTRAN_ARRAY_SIZE,
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
@@ -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<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
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<typename T>
+static void fortran_wrap2_kind (type *base_type);
+
+template<typename T>
+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 <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
@@ -248,54 +260,6 @@ exp : KIND '(' exp ')' %prec UNARY
{ 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
@@ -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<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");
}
}
;
@@ -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<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:
+ pstate->push_new<fortran_bound_2arg>
+ (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<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. */
@@ -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 <http://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
^ permalink raw reply [flat|nested] 28+ messages in thread