aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--gdb/ChangeLog11
-rw-r--r--gdb/f-exp.h12
-rw-r--r--gdb/f-exp.y4
-rw-r--r--gdb/f-lang.c81
-rw-r--r--gdb/std-operator.def1
-rw-r--r--gdb/testsuite/ChangeLog5
-rw-r--r--gdb/testsuite/gdb.fortran/shape.exp86
-rw-r--r--gdb/testsuite/gdb.fortran/shape.f9077
8 files changed, 277 insertions, 0 deletions
diff --git a/gdb/ChangeLog b/gdb/ChangeLog
index 0a16353..6ed71c2 100644
--- a/gdb/ChangeLog
+++ b/gdb/ChangeLog
@@ -1,5 +1,16 @@
2021-03-09 Andrew Burgess <andrew.burgess@embecosm.com>
+ * f-exp.h (eval_op_f_array_shape): Declare.
+ (fortran_array_shape_operation): New type.
+ * f-exp.y (exp): Handle UNOP_FORTRAN_SHAPE after parsing
+ UNOP_INTRINSIC.
+ (f77_keywords): Add "shape" keyword.
+ * f-lang.c (fortran_array_shape): New function.
+ (eval_op_f_array_shape): New function.
+ * std-operator.def (UNOP_FORTRAN_SHAPE): New operator.
+
+2021-03-09 Andrew Burgess <andrew.burgess@embecosm.com>
+
* f-exp.y (eval_op_f_array_size): Declare 1 and 2 argument forms
of this function.
(expr::fortran_array_size_1arg): New type.
diff --git a/gdb/f-exp.h b/gdb/f-exp.h
index fc46c12..11f19af 100644
--- a/gdb/f-exp.h
+++ b/gdb/f-exp.h
@@ -108,6 +108,16 @@ extern struct value *eval_op_f_array_size (struct type *expect_type,
struct value *arg1,
struct value *arg2);
+/* 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
+ to the expression. */
+
+extern struct value *eval_op_f_array_shape (struct type *expect_type,
+ struct expression *exp,
+ enum noside noside,
+ enum exp_opcode op,
+ struct value *arg1);
namespace expr
{
@@ -135,6 +145,8 @@ 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_shape_operation = unop_operation<UNOP_FORTRAN_SHAPE,
+ eval_op_f_array_shape>;
/* The Fortran "complex" operation. */
class fortran_cmplx_operation
diff --git a/gdb/f-exp.y b/gdb/f-exp.y
index e652bd9..dcc28b8 100644
--- a/gdb/f-exp.y
+++ b/gdb/f-exp.y
@@ -330,6 +330,9 @@ exp : UNOP_INTRINSIC '(' exp ')'
case UNOP_FORTRAN_RANK:
pstate->wrap<fortran_rank_operation> ();
break;
+ case UNOP_FORTRAN_SHAPE:
+ pstate->wrap<fortran_array_shape_operation> ();
+ break;
default:
gdb_assert_not_reached ("unhandled intrinsic");
}
@@ -1151,6 +1154,7 @@ static const struct token f77_keywords[] =
{ "associated", UNOP_OR_BINOP_INTRINSIC, FORTRAN_ASSOCIATED, false },
{ "rank", UNOP_INTRINSIC, UNOP_FORTRAN_RANK, false },
{ "size", UNOP_OR_BINOP_INTRINSIC, FORTRAN_ARRAY_SIZE, false },
+ { "shape", UNOP_INTRINSIC, UNOP_FORTRAN_SHAPE, false },
};
/* Implementation of a dynamically expandable buffer for processing input
diff --git a/gdb/f-lang.c b/gdb/f-lang.c
index a33aef3..d79c458c 100644
--- a/gdb/f-lang.c
+++ b/gdb/f-lang.c
@@ -675,6 +675,87 @@ eval_op_f_array_size (struct type *expect_type,
return fortran_array_size (exp->gdbarch, exp->language_defn, arg1, arg2);
}
+/* Implement UNOP_FORTRAN_SHAPE expression. Both GDBARCH and LANG are
+ extracted from the expression being evaluated. VAL is the value on
+ which 'shape' was used, this can be any type.
+
+ Return an array of integers. If VAL is not an array then the returned
+ array should have zero elements. If VAL is an array then the returned
+ array should have one element per dimension, with the element
+ containing the extent of that dimension from VAL. */
+
+static struct value *
+fortran_array_shape (struct gdbarch *gdbarch, const language_defn *lang,
+ struct value *val)
+{
+ struct type *val_type = check_typedef (value_type (val));
+
+ /* If we are passed an array that is either not allocated, or not
+ associated, then this is explicitly not allowed according to the
+ Fortran specification. */
+ if (val_type->code () == TYPE_CODE_ARRAY
+ && (type_not_associated (val_type) || type_not_allocated (val_type)))
+ error (_("The array passed to SHAPE must be allocated or associated"));
+
+ /* The Fortran specification allows non-array types to be passed to this
+ function, in which case we get back an empty array.
+
+ Calculate the number of dimensions for the resulting array. */
+ int ndimensions = 0;
+ if (val_type->code () == TYPE_CODE_ARRAY)
+ ndimensions = calc_f77_array_dims (val_type);
+
+ /* Allocate a result value of the correct type. */
+ struct type *range
+ = create_static_range_type (nullptr,
+ builtin_type (gdbarch)->builtin_int,
+ 1, ndimensions);
+ 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);
+ LONGEST elm_len = TYPE_LENGTH (elm_type);
+
+ /* Walk the array dimensions backwards due to the way the array will be
+ laid out in memory, the first dimension will be the most inner.
+
+ If VAL was not an array then ndimensions will be 0, in which case we
+ will never go around this loop. */
+ for (LONGEST dst_offset = elm_len * (ndimensions - 1);
+ dst_offset >= 0;
+ dst_offset -= elm_len)
+ {
+ LONGEST lbound, ubound;
+
+ if (!get_discrete_bounds (val_type->index_type (), &lbound, &ubound))
+ error (_("failed to find array bounds"));
+
+ LONGEST dim_size = (ubound - lbound + 1);
+
+ /* And copy the value into the result value. */
+ struct value *v = value_from_longest (elm_type, dim_size);
+ gdb_assert (dst_offset + TYPE_LENGTH (value_type (v))
+ <= TYPE_LENGTH (value_type (result)));
+ gdb_assert (TYPE_LENGTH (value_type (v)) == elm_len);
+ value_contents_copy (result, dst_offset, v, 0, elm_len);
+
+ /* Peel another dimension of the array. */
+ val_type = TYPE_TARGET_TYPE (val_type);
+ }
+
+ return result;
+}
+
+/* See f-exp.h. */
+
+struct value *
+eval_op_f_array_shape (struct type *expect_type, struct expression *exp,
+ enum noside noside, enum exp_opcode opcode,
+ struct value *arg1)
+{
+ gdb_assert (opcode == UNOP_FORTRAN_SHAPE);
+ return fortran_array_shape (exp->gdbarch, exp->language_defn, arg1);
+}
+
/* A helper function for UNOP_ABS. */
struct value *
diff --git a/gdb/std-operator.def b/gdb/std-operator.def
index b67247f..1b8581f 100644
--- a/gdb/std-operator.def
+++ b/gdb/std-operator.def
@@ -379,6 +379,7 @@ OP (UNOP_FORTRAN_FLOOR)
OP (UNOP_FORTRAN_CEILING)
OP (UNOP_FORTRAN_ALLOCATED)
OP (UNOP_FORTRAN_RANK)
+OP (UNOP_FORTRAN_SHAPE)
/* Two operand builtins. */
OP (BINOP_FORTRAN_CMPLX)
diff --git a/gdb/testsuite/ChangeLog b/gdb/testsuite/ChangeLog
index 00a7133..ea1401c 100644
--- a/gdb/testsuite/ChangeLog
+++ b/gdb/testsuite/ChangeLog
@@ -1,5 +1,10 @@
2021-03-09 Andrew Burgess <andrew.burgess@embecosm.com>
+ * gdb.fortran/shape.exp: New file.
+ * gdb.fortran/shape.f90: New file.
+
+2021-03-09 Andrew Burgess <andrew.burgess@embecosm.com>
+
* gdb.fortran/size.exp: New file.
* gdb.fortran/size.f90: New file.
diff --git a/gdb/testsuite/gdb.fortran/shape.exp b/gdb/testsuite/gdb.fortran/shape.exp
new file mode 100644
index 0000000..0c41b7b
--- /dev/null
+++ b/gdb/testsuite/gdb.fortran/shape.exp
@@ -0,0 +1,86 @@
+# Copyright 2021 Free Software Foundation, Inc.
+
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, see <http://www.gnu.org/licenses/> .
+
+# Testing GDB's implementation of SHAPE keyword.
+
+if {[skip_fortran_tests]} { return -1 }
+
+standard_testfile ".f90"
+load_lib fortran.exp
+
+if {[prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} \
+ {debug f90}]} {
+ return -1
+}
+
+if ![fortran_runto_main] {
+ untested "could not run to main"
+ return -1
+}
+
+gdb_breakpoint [gdb_get_line_number "Test Breakpoint"]
+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 test_count 0
+while { $test_count < 500 } {
+ with_test_prefix "test $test_count" {
+ incr test_count
+
+ gdb_test_multiple "continue" "continue" {
+ -re -wrap "! Test Breakpoint" {
+ # We can run a test from here.
+ }
+ -re -wrap "! Final Breakpoint" {
+ # We're done with the tests.
+ set found_final_breakpoint true
+ }
+ }
+
+ if ($found_final_breakpoint) {
+ break
+ }
+
+ # First grab the expected answer.
+ set answer [get_valueof "" "answer" "**unknown**"]
+
+ # Now move up a frame and figure out a command for us to run
+ # as a test.
+ set command ""
+ gdb_test_multiple "up" "up" {
+ -re -wrap "\r\n\[0-9\]+\[ \t\]+call test_shape \\((\[^\r\n\]+)\\)" {
+ set command $expect_out(1,string)
+ }
+ }
+
+ gdb_assert { ![string equal $command ""] } "found a command to run"
+
+ set answer [string_to_regexp $answer]
+ gdb_test "p $command" " = $answer"
+ }
+}
+
+# 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"
+
+foreach var {array_1d_p array_2d_p allocatable_array_1d \
+ allocatable_array_2d} {
+ gdb_test "p shape ($var)" \
+ "The array passed to SHAPE must be allocated or associated"
+}
diff --git a/gdb/testsuite/gdb.fortran/shape.f90 b/gdb/testsuite/gdb.fortran/shape.f90
new file mode 100644
index 0000000..1a1b3f0
--- /dev/null
+++ b/gdb/testsuite/gdb.fortran/shape.f90
@@ -0,0 +1,77 @@
+! Copyright 2021 Free Software Foundation, Inc.
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 3 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License
+! along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+!
+! Start of test program.
+!
+program test
+
+ ! Things to perform tests on.
+ integer, target :: array_1d (1:10) = 0
+ integer, target :: array_2d (1:4, 1:3) = 0
+ integer :: an_integer = 0
+ real :: a_real = 0.0
+ integer, pointer :: array_1d_p (:) => null ()
+ integer, pointer :: array_2d_p (:,:) => null ()
+ integer, allocatable :: allocatable_array_1d (:)
+ integer, allocatable :: allocatable_array_2d (:,:)
+
+ call test_shape (shape (array_1d))
+ call test_shape (shape (array_2d))
+ call test_shape (shape (an_integer))
+ call test_shape (shape (a_real))
+
+ call test_shape (shape (array_1d (1:10:2)))
+ call test_shape (shape (array_1d (1:10:3)))
+
+ call test_shape (shape (array_2d (4:1:-1, 3:1:-1)))
+ call test_shape (shape (array_2d (4:1:-1, 1:3:2)))
+
+ allocate (allocatable_array_1d (-10:-5))
+ allocate (allocatable_array_2d (-3:3, 8:12))
+
+ call test_shape (shape (allocatable_array_1d))
+ call test_shape (shape (allocatable_array_2d))
+
+ call test_shape (shape (allocatable_array_2d (-2, 10:12)))
+
+ array_1d_p => array_1d
+ array_2d_p => array_2d
+
+ call test_shape (shape (array_1d_p))
+ call test_shape (shape (array_2d_p))
+
+ deallocate (allocatable_array_1d)
+ deallocate (allocatable_array_2d)
+ array_1d_p => null ()
+ array_2d_p => null ()
+
+ print *, "" ! Final Breakpoint
+ print *, an_integer
+ print *, a_real
+ print *, associated (array_1d_p)
+ print *, associated (array_2d_p)
+ print *, allocated (allocatable_array_1d)
+ print *, allocated (allocatable_array_2d)
+
+contains
+
+ subroutine test_shape (answer)
+ integer, dimension (:) :: answer
+
+ print *,answer ! Test Breakpoint
+ end subroutine test_shape
+
+end program test
generated by cgit v1.1 at 2024-11-23 03:21:08 +0000