diff options
Diffstat (limited to 'gdb')
| -rw-r--r-- | gdb/ChangeLog | 13 | ||||
| -rw-r--r-- | gdb/f-exp.h | 28 | ||||
| -rw-r--r-- | gdb/f-exp.y | 8 | ||||
| -rw-r--r-- | gdb/f-lang.c | 97 | ||||
| -rw-r--r-- | gdb/std-operator.def | 1 | ||||
| -rw-r--r-- | gdb/testsuite/ChangeLog | 5 | ||||
| -rw-r--r-- | gdb/testsuite/gdb.fortran/size.exp | 89 | ||||
| -rw-r--r-- | gdb/testsuite/gdb.fortran/size.f90 | 118 |
8 files changed, 359 insertions, 0 deletions
diff --git a/gdb/ChangeLog b/gdb/ChangeLog index 59638cc..0a16353 100644 --- a/gdb/ChangeLog +++ b/gdb/ChangeLog @@ -1,5 +1,18 @@ 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. + (expr::fortran_array_size_2arg): Likewise. + * f-exp.y (exp): Handle FORTRAN_ARRAY_SIZE after parsing + UNOP_OR_BINOP_INTRINSIC. + (f77_keywords): Add "size" keyword. + * f-lang.c (fortran_array_size): New function. + (eval_op_f_array_size): New function, has a 1 arg and 2 arg form. + * std-operator.def (FORTRAN_ARRAY_SIZE): New operator. + +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 diff --git a/gdb/f-exp.h b/gdb/f-exp.h index f23c426..fc46c12 100644 --- a/gdb/f-exp.h +++ b/gdb/f-exp.h @@ -85,6 +85,30 @@ extern struct value *eval_op_f_rank (struct type *expect_type, enum exp_opcode op, struct value *arg1); +/* 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 + value passed to SIZE if it is only passed a single argument. For the + two argument form see the overload of this function below. */ + +extern struct value *eval_op_f_array_size (struct type *expect_type, + struct expression *exp, + enum noside noside, + enum exp_opcode opcode, + struct value *arg1); + +/* An overload of EVAL_OP_F_ARRAY_SIZE above, this version takes two + arguments, representing the two values passed to Fortran's SIZE + keyword. */ + +extern struct value *eval_op_f_array_size (struct type *expect_type, + struct expression *exp, + enum noside noside, + enum exp_opcode opcode, + struct value *arg1, + struct value *arg2); + + namespace expr { @@ -107,6 +131,10 @@ 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>; +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>; /* The Fortran "complex" operation. */ class fortran_cmplx_operation diff --git a/gdb/f-exp.y b/gdb/f-exp.y index 02e35c8..e652bd9 100644 --- a/gdb/f-exp.y +++ b/gdb/f-exp.y @@ -260,6 +260,13 @@ exp : UNOP_OR_BINOP_INTRINSIC '(' 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 @@ -1143,6 +1150,7 @@ static const struct token f77_keywords[] = { "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 }, }; /* Implementation of a dynamically expandable buffer for processing input diff --git a/gdb/f-lang.c b/gdb/f-lang.c index d30b13d..a33aef3 100644 --- a/gdb/f-lang.c +++ b/gdb/f-lang.c @@ -578,6 +578,103 @@ eval_op_f_associated (struct type *expect_type, return fortran_associated (exp->gdbarch, exp->language_defn, arg1, arg2); } +/* 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 + 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 + before calling this function. + + 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) +{ + /* Check that ARRAY is the correct type. */ + struct type *array_type = check_typedef (value_type (array)); + if (array_type->code () != TYPE_CODE_ARRAY) + error (_("SIZE can only be applied to arrays")); + if (type_not_allocated (array_type) || type_not_associated (array_type)) + error (_("SIZE can only be used on allocated/associated arrays")); + + int ndimensions = calc_f77_array_dims (array_type); + int dim = -1; + LONGEST result = 0; + + if (dim_val != nullptr) + { + if (check_typedef (value_type (dim_val))->code () != TYPE_CODE_INT) + error (_("DIM argument to SIZE must be an integer")); + dim = (int) value_as_long (dim_val); + + if (dim < 1 || dim > ndimensions) + error (_("DIM argument to SIZE must be between 1 and %d"), + ndimensions); + } + + /* Now walk over all the dimensions of the array totalling up the + elements in each dimension. */ + for (int i = ndimensions - 1; i >= 0; --i) + { + /* If this is the requested dimension then we're done. Grab the + bounds and return. */ + if (i == dim - 1 || dim == -1) + { + LONGEST lbound, ubound; + struct type *range = array_type->index_type (); + + if (!get_discrete_bounds (range, &lbound, &ubound)) + error (_("failed to find array bounds")); + + LONGEST dim_size = (ubound - lbound + 1); + if (result == 0) + result = dim_size; + else + result *= dim_size; + + if (dim != -1) + break; + } + + /* Peel off another dimension of the array. */ + array_type = TYPE_TARGET_TYPE (array_type); + } + + struct type *result_type + = builtin_f_type (gdbarch)->builtin_integer; + return value_from_longest (result_type, result); +} + +/* See f-exp.h. */ + +struct value * +eval_op_f_array_size (struct type *expect_type, + struct expression *exp, + enum noside noside, + enum exp_opcode opcode, + struct value *arg1) +{ + gdb_assert (opcode == FORTRAN_ARRAY_SIZE); + return fortran_array_size (exp->gdbarch, exp->language_defn, arg1); +} + +/* See f-exp.h. */ + +struct value * +eval_op_f_array_size (struct type *expect_type, + struct expression *exp, + enum noside noside, + enum exp_opcode opcode, + struct value *arg1, + struct value *arg2) +{ + gdb_assert (opcode == FORTRAN_ARRAY_SIZE); + return fortran_array_size (exp->gdbarch, exp->language_defn, arg1, arg2); +} + /* A helper function for UNOP_ABS. */ struct value * diff --git a/gdb/std-operator.def b/gdb/std-operator.def index 158bd24..b67247f 100644 --- a/gdb/std-operator.def +++ b/gdb/std-operator.def @@ -388,3 +388,4 @@ OP (BINOP_FORTRAN_MODULO) OP (FORTRAN_LBOUND) OP (FORTRAN_UBOUND) OP (FORTRAN_ASSOCIATED) +OP (FORTRAN_ARRAY_SIZE)
\ No newline at end of file diff --git a/gdb/testsuite/ChangeLog b/gdb/testsuite/ChangeLog index f221157..00a7133 100644 --- a/gdb/testsuite/ChangeLog +++ b/gdb/testsuite/ChangeLog @@ -1,5 +1,10 @@ 2021-03-09 Andrew Burgess <andrew.burgess@embecosm.com> + * gdb.fortran/size.exp: New file. + * gdb.fortran/size.f90: New file. + +2021-03-09 Andrew Burgess <andrew.burgess@embecosm.com> + * gdb.fortran/rank.exp: New file. * gdb.fortran/rank.f90: New file. diff --git a/gdb/testsuite/gdb.fortran/size.exp b/gdb/testsuite/gdb.fortran/size.exp new file mode 100644 index 0000000..20a9b27 --- /dev/null +++ b/gdb/testsuite/gdb.fortran/size.exp @@ -0,0 +1,89 @@ +# 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 SIZE 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_size \\((\[^\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" + +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" +} + +foreach var {an_integer a_real} { + gdb_test "p size ($var)" "SIZE can only be applied to arrays" +} diff --git a/gdb/testsuite/gdb.fortran/size.f90 b/gdb/testsuite/gdb.fortran/size.f90 new file mode 100644 index 0000000..4b556a7 --- /dev/null +++ b/gdb/testsuite/gdb.fortran/size.f90 @@ -0,0 +1,118 @@ +! 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 (:,:) + + ! Loop counters. + integer :: s1, s2 + + ! The start of the tests. + call test_size (size (array_1d)) + call test_size (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)) + 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)) + end do + end do + + allocate (allocatable_array_1d (-10:-5)) + call test_size (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 (size (allocatable_array_1d (-10:-5:s1), 1)) + call test_size (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)) + end do + end do + + array_1d_p => array_1d + call test_size (size (array_1d_p)) + call test_size (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)) + + 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_size (answer) + integer :: answer + + print *,answer ! Test Breakpoint + end subroutine test_size + +end program test |