gdb/fortran: add support for RANK keyword

gfortran supports the RANK keyword, see:

  https://gcc.gnu.org/onlinedocs/gfortran/RANK.html#RANK

this commit adds support for this keyword to GDB's Fortran expression
parser.

gdb/ChangeLog:

	* f-exp.h (eval_op_f_rank): Declare.
	(expr::fortran_rank_operation): New typedef.
	* f-exp.y (exp): Handle UNOP_FORTRAN_RANK after parsing an
	UNOP_INTRINSIC.
	(f77_keywords): Add "rank" keyword.
	* f-lang.c (eval_op_f_rank): New function.
	* std-operator.def (UNOP_FORTRAN_RANK): New operator.

gdb/testsuite/ChangeLog:

	* gdb.fortran/rank.exp: New file.
	* gdb.fortran/rank.f90: New file.

diff --git a/gdb/ChangeLog b/gdb/ChangeLog
index 2024f942ad498b59f019300167c5acb5c9be5c15..59638cc479e3aa85f8b4042349f0388cec2b87ef 100644 (file)
--- a/gdb/ChangeLog
+++ b/gdb/ChangeLog
@@ -1,3 +1,13 @@
+2021-03-09  Andrew Burgess  <andrew.burgess@embecosm.com>
+
+       * f-exp.h (eval_op_f_rank): Declare.
+       (expr::fortran_rank_operation): New typedef.
+       * f-exp.y (exp): Handle UNOP_FORTRAN_RANK after parsing an
+       UNOP_INTRINSIC.
+       (f77_keywords): Add "rank" keyword.
+       * f-lang.c (eval_op_f_rank): New function.
+       * std-operator.def (UNOP_FORTRAN_RANK): New operator.
+
 2021-03-08  Tom Tromey  <tom@tromey.com>
 
        * printcmd.c (set_command): Remove null check.

diff --git a/gdb/f-exp.h b/gdb/f-exp.h
index 81cf3412ee2bce48506fcd161ff0f2e074620448..f23c426b34bbaf8858590a2567bfd3bcff923d5c 100644 (file)
--- a/gdb/f-exp.h
+++ b/gdb/f-exp.h
@@ -74,6 +74,17 @@ extern struct value * eval_op_f_allocated (struct type *expect_type,
                                           enum exp_opcode op,
                                           struct value *arg1);
 
+/* Implement the evaluation of UNOP_FORTRAN_RANK.  EXPECTED_TYPE, EXP, and
+   NOSIDE are as for expression::evaluate (see expression.h).  OP will
+   always be UNOP_FORTRAN_RANK, and ARG1 is the argument being passed to
+   the expression.   */
+
+extern struct value *eval_op_f_rank (struct type *expect_type,
+                                    struct expression *exp,
+                                    enum noside noside,
+                                    enum exp_opcode op,
+                                    struct value *arg1);
+
 namespace expr
 {
 
@@ -94,6 +105,8 @@ using fortran_associated_1arg = unop_operation<FORTRAN_ASSOCIATED,
                                               eval_op_f_associated>;
 using fortran_associated_2arg = binop_operation<FORTRAN_ASSOCIATED,
                                                eval_op_f_associated>;
+using fortran_rank_operation = unop_operation<UNOP_FORTRAN_RANK,
+                                             eval_op_f_rank>;
 
 /* The Fortran "complex" operation.  */
 class fortran_cmplx_operation

diff --git a/gdb/f-exp.y b/gdb/f-exp.y
index c33b507915835b75582f67b2341fb9d86c43ba92..02e35c83b051288963b50b3150dd5959b743938b 100644 (file)
--- a/gdb/f-exp.y
+++ b/gdb/f-exp.y
@@ -320,6 +320,9 @@ exp :       UNOP_INTRINSIC '(' exp ')'
                            case UNOP_FORTRAN_ALLOCATED:
                              pstate->wrap<fortran_allocated_operation> ();
                              break;
+                           case UNOP_FORTRAN_RANK:
+                             pstate->wrap<fortran_rank_operation> ();
+                             break;
                            default:
                              gdb_assert_not_reached ("unhandled intrinsic");
                            }
@@ -1139,6 +1142,7 @@ static const struct token f77_keywords[] =
   { "ubound", UNOP_OR_BINOP_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 },
 };
 
 /* Implementation of a dynamically expandable buffer for processing input

diff --git a/gdb/f-lang.c b/gdb/f-lang.c
index 1b66ae341598605957de656f3b8b01297e81e802..d30b13d8b6d6c58af1304c142bdb3be6b9052686 100644 (file)
--- a/gdb/f-lang.c
+++ b/gdb/f-lang.c
@@ -773,6 +773,26 @@ eval_op_f_allocated (struct type *expect_type, struct expression *exp,
   return value_from_longest (result_type, result_value);
 }
 
+/* See f-exp.h.  */
+
+struct value *
+eval_op_f_rank (struct type *expect_type,
+               struct expression *exp,
+               enum noside noside,
+               enum exp_opcode op,
+               struct value *arg1)
+{
+  gdb_assert (op == UNOP_FORTRAN_RANK);
+
+  struct type *result_type
+    = builtin_f_type (exp->gdbarch)->builtin_integer;
+  struct type *type = check_typedef (value_type (arg1));
+  if (type->code () != TYPE_CODE_ARRAY)
+    return value_from_longest (result_type, 0);
+  LONGEST ndim = calc_f77_array_dims (type);
+  return value_from_longest (result_type, ndim);
+}
+
 namespace expr
 {
 

diff --git a/gdb/std-operator.def b/gdb/std-operator.def
index b0c6beb4628e7bbdfcf54e1371b7c16586471e6d..158bd24476554eb20e5ce45bede07b4868720d8c 100644 (file)
--- a/gdb/std-operator.def
+++ b/gdb/std-operator.def
@@ -378,6 +378,7 @@ OP (UNOP_FORTRAN_KIND)
 OP (UNOP_FORTRAN_FLOOR)
 OP (UNOP_FORTRAN_CEILING)
 OP (UNOP_FORTRAN_ALLOCATED)
+OP (UNOP_FORTRAN_RANK)
 
 /* Two operand builtins.  */
 OP (BINOP_FORTRAN_CMPLX)

diff --git a/gdb/testsuite/ChangeLog b/gdb/testsuite/ChangeLog
index 5767fa562c640b1281c3f95a749b0c0319a905a0..f221157e51ff4ddc8596772bb278971941c1f9a7 100644 (file)
--- a/gdb/testsuite/ChangeLog
+++ b/gdb/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2021-03-09  Andrew Burgess  <andrew.burgess@embecosm.com>
+
+       * gdb.fortran/rank.exp: New file.
+       * gdb.fortran/rank.f90: New file.
+
 2021-03-08  Tom Tromey  <tom@tromey.com>
 
        * gdb.fortran/debug-expr.exp: Update tests.

diff --git a/gdb/testsuite/gdb.fortran/rank.exp b/gdb/testsuite/gdb.fortran/rank.exp
new file mode 100644 (file)
index 0000000..86af711
--- /dev/null
+++ b/gdb/testsuite/gdb.fortran/rank.exp
@@ -0,0 +1,79 @@
+# 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 RANK 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 "! 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_rank \\((\[^\r\n\]+)\\)" {
+               set command $expect_out(1,string)
+           }
+       }
+
+       gdb_assert { ![string equal $command ""] } "found a command to run"
+
+       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"

diff --git a/gdb/testsuite/gdb.fortran/rank.f90 b/gdb/testsuite/gdb.fortran/rank.f90
new file mode 100644 (file)
index 0000000..66de2bb
--- /dev/null
+++ b/gdb/testsuite/gdb.fortran/rank.f90
@@ -0,0 +1,57 @@
+! 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 ask questions about.
+  integer, target :: array_1d (8:10) = 0
+  integer, target :: array_2d (1:3, 4:7) = 0
+  integer :: other_1d (4:5, -3:-1, 99:101) = 0
+  integer, pointer :: array_1d_p (:) => null ()
+  integer, pointer :: array_2d_p (:,:) => null ()
+
+  integer :: an_integer = 0
+  real :: a_real = 0.0
+
+  ! The start of the tests.
+  call test_rank (rank (array_1d))
+  call test_rank (rank (array_2d))
+  call test_rank (rank (other_1d))
+  call test_rank (rank (array_1d_p))
+  call test_rank (rank (array_2d_p))
+
+  array_1d_p => array_1d
+  array_2d_p => array_2d
+
+  call test_rank (rank (array_1d_p))
+  call test_rank (rank (array_2d_p))
+
+  call test_rank (rank (an_integer))
+  call test_rank (rank (a_real))
+
+  print *, "" ! Final Breakpoint
+
+contains
+
+  subroutine test_rank (answer)
+    integer :: answer
+
+    print *,answer     ! Test Breakpoint
+  end subroutine test_rank
+
+end program test