From: Andrew Burgess Date: Thu, 25 Feb 2021 11:41:57 +0000 (+0000) Subject: gdb/fortran: add support for RANK keyword X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=e14816a8ba5ecf8d7c0125a08afe87fb7d1a6bba;p=binutils-gdb.git 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 2024f942ad4..59638cc479e 100644 --- a/gdb/ChangeLog +++ b/gdb/ChangeLog @@ -1,3 +1,13 @@ +2021-03-09 Andrew Burgess + + * 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 * printcmd.c (set_command): Remove null check. diff --git a/gdb/f-exp.h b/gdb/f-exp.h index 81cf3412ee2..f23c426b34b 100644 --- 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; using fortran_associated_2arg = binop_operation; +using fortran_rank_operation = unop_operation; /* The Fortran "complex" operation. */ class fortran_cmplx_operation diff --git a/gdb/f-exp.y b/gdb/f-exp.y index c33b5079158..02e35c83b05 100644 --- a/gdb/f-exp.y +++ b/gdb/f-exp.y @@ -320,6 +320,9 @@ exp : UNOP_INTRINSIC '(' exp ')' case UNOP_FORTRAN_ALLOCATED: pstate->wrap (); break; + case UNOP_FORTRAN_RANK: + pstate->wrap (); + 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 1b66ae34159..d30b13d8b6d 100644 --- 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 b0c6beb4628..158bd244765 100644 --- 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 5767fa562c6..f221157e51f 100644 --- a/gdb/testsuite/ChangeLog +++ b/gdb/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2021-03-09 Andrew Burgess + + * gdb.fortran/rank.exp: New file. + * gdb.fortran/rank.f90: New file. + 2021-03-08 Tom Tromey * 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 index 00000000000..86af7111f47 --- /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 . + +# 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 index 00000000000..66de2bb9ed7 --- /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 . + +! +! 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