From: Andrew Burgess Date: Fri, 26 Feb 2021 11:14:24 +0000 (+0000) Subject: gdb/fotran: add support for the 'shape' keyword X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=eef32f59988bb0e4514d5395093c9e6d8d073ebb;p=binutils-gdb.git gdb/fotran: add support for the 'shape' keyword Add support for the SHAPE keyword to GDB's Fortran expression parser. gdb/ChangeLog: * 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. gdb/testsuite/ChangeLog: * gdb.fortran/shape.exp: New file. * gdb.fortran/shape.f90: New file. --- diff --git a/gdb/ChangeLog b/gdb/ChangeLog index 0a163539a74..6ed71c2724b 100644 --- a/gdb/ChangeLog +++ b/gdb/ChangeLog @@ -1,3 +1,14 @@ +2021-03-09 Andrew Burgess + + * 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 * f-exp.y (eval_op_f_array_size): Declare 1 and 2 argument forms diff --git a/gdb/f-exp.h b/gdb/f-exp.h index fc46c123c6a..11f19af979f 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; using fortran_array_size_2arg = binop_operation; +using fortran_array_shape_operation = unop_operation; /* The Fortran "complex" operation. */ class fortran_cmplx_operation diff --git a/gdb/f-exp.y b/gdb/f-exp.y index e652bd96d74..dcc28b8e600 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 (); break; + case UNOP_FORTRAN_SHAPE: + pstate->wrap (); + 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 a33aef31d4f..d79c458c5e0 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 b67247f7e18..1b8581f319e 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 00a7133d2b0..ea1401c52c3 100644 --- a/gdb/testsuite/ChangeLog +++ b/gdb/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2021-03-09 Andrew Burgess + + * gdb.fortran/shape.exp: New file. + * gdb.fortran/shape.f90: New file. + 2021-03-09 Andrew Burgess * gdb.fortran/size.exp: New file. diff --git a/gdb/testsuite/gdb.fortran/shape.exp b/gdb/testsuite/gdb.fortran/shape.exp new file mode 100644 index 00000000000..0c41b7b2326 --- /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 . + +# 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 00000000000..1a1b3f06505 --- /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 . + +! +! 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