+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.
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
{
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
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");
}
{ "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
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
{
OP (UNOP_FORTRAN_FLOOR)
OP (UNOP_FORTRAN_CEILING)
OP (UNOP_FORTRAN_ALLOCATED)
+OP (UNOP_FORTRAN_RANK)
/* Two operand builtins. */
OP (BINOP_FORTRAN_CMPLX)
+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.
--- /dev/null
+# 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"
--- /dev/null
+! 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
projects / deliverable / binutils-gdb.git / commitdiff
