From e92c8eb86dcef673652644694c832c504cf9a9a9 Mon Sep 17 00:00:00 2001 From: Andrew Burgess Date: Tue, 9 Feb 2021 15:46:13 +0000 Subject: [PATCH] gdb/fortran: add parser support for lbound and ubound Add support for the LBOUND and UBOUND built in functions to the Fortran expression parser. Both support taking one or two arguments. A single argument, which must be an array, returns an array containing all of the lower or upper bound data. When passed two arguments, the second argument is the dimension being asked about. In this case the result is a scalar containing the lower or upper bound just for that dimension. Some examples of usage taken from the new test: # Given: # integer, dimension (-8:-1,-10:-2) :: neg_array # (gdb) p lbound (neg_array) $1 = (-8, -10) (gdb) p lbound (neg_array, 1) $3 = -8 (gdb) p lbound (neg_array, 2) $5 = -10 gdb/ChangeLog: * f-exp.y (UNOP_OR_BINOP_INTRINSIC): New token. (exp): New pattern using UNOP_OR_BINOP_INTRINSIC. (one_or_two_args): New pattern. (f77_keywords): Add lbound and ubound. * f-lang.c (fortran_bounds_all_dims): New function. (fortran_bounds_for_dimension): New function. (evaluate_subexp_f): Handle FORTRAN_LBOUND and FORTRAN_UBOUND. (operator_length_f): Likewise. (print_subexp_f): Likewise. (dump_subexp_body_f): Likewise. (operator_check_f): Likewise. * std-operator.def (FORTRAN_LBOUND): Define. (FORTRAN_UBOUND): Define. gdb/testsuite/ChangeLog: * gdb.fortran/lbound-ubound.F90: New file. * gdb.fortran/lbound-ubound.exp: New file. --- gdb/ChangeLog | 16 ++ gdb/f-exp.y | 18 ++ gdb/f-lang.c | 172 +++++++++++++++++ gdb/std-operator.def | 4 + gdb/testsuite/ChangeLog | 5 + gdb/testsuite/gdb.fortran/lbound-ubound.F90 | 105 ++++++++++ gdb/testsuite/gdb.fortran/lbound-ubound.exp | 204 ++++++++++++++++++++ 7 files changed, 524 insertions(+) create mode 100644 gdb/testsuite/gdb.fortran/lbound-ubound.F90 create mode 100644 gdb/testsuite/gdb.fortran/lbound-ubound.exp diff --git a/gdb/ChangeLog b/gdb/ChangeLog index 6de7954fe03..0f600fedc72 100644 --- a/gdb/ChangeLog +++ b/gdb/ChangeLog @@ -1,3 +1,19 @@ +2021-02-10 Andrew Burgess + + * f-exp.y (UNOP_OR_BINOP_INTRINSIC): New token. + (exp): New pattern using UNOP_OR_BINOP_INTRINSIC. + (one_or_two_args): New pattern. + (f77_keywords): Add lbound and ubound. + * f-lang.c (fortran_bounds_all_dims): New function. + (fortran_bounds_for_dimension): New function. + (evaluate_subexp_f): Handle FORTRAN_LBOUND and FORTRAN_UBOUND. + (operator_length_f): Likewise. + (print_subexp_f): Likewise. + (dump_subexp_body_f): Likewise. + (operator_check_f): Likewise. + * std-operator.def (FORTRAN_LBOUND): Define. + (FORTRAN_UBOUND): Define. + 2021-02-10 Andrew Burgess * coff-pe-read.c (add_pe_forwarded_sym): Make use of section_index diff --git a/gdb/f-exp.y b/gdb/f-exp.y index 92a70b4552d..00f0df34db4 100644 --- a/gdb/f-exp.y +++ b/gdb/f-exp.y @@ -178,6 +178,7 @@ static int parse_number (struct parser_state *, const char *, int, %token ASSIGN_MODIFY %token UNOP_INTRINSIC BINOP_INTRINSIC +%token UNOP_OR_BINOP_INTRINSIC %left ',' %left ABOVE_COMMA @@ -246,6 +247,21 @@ exp : KIND '(' exp ')' %prec UNARY { write_exp_elt_opcode (pstate, UNOP_FORTRAN_KIND); } ; +exp : UNOP_OR_BINOP_INTRINSIC '(' + { pstate->start_arglist (); } + one_or_two_args ')' + { write_exp_elt_opcode (pstate, $1); + write_exp_elt_longcst (pstate, pstate->end_arglist ()); + write_exp_elt_opcode (pstate, $1); } + ; + +one_or_two_args + : exp + { pstate->arglist_len = 1; } + | exp ',' exp + { pstate->arglist_len = 2; } + ; + /* No more explicit array operators, we treat everything in F77 as a function call. The disambiguation as to whether we are doing a subscript operation or a function call is done @@ -1028,6 +1044,8 @@ static const struct token f77_keywords[] = { "ceiling", UNOP_INTRINSIC, UNOP_FORTRAN_CEILING, false }, { "modulo", BINOP_INTRINSIC, BINOP_FORTRAN_MODULO, false }, { "cmplx", BINOP_INTRINSIC, BINOP_FORTRAN_CMPLX, false }, + { "lbound", UNOP_OR_BINOP_INTRINSIC, FORTRAN_LBOUND, false }, + { "ubound", UNOP_OR_BINOP_INTRINSIC, FORTRAN_UBOUND, false }, }; /* Implementation of a dynamically expandable buffer for processing input diff --git a/gdb/f-lang.c b/gdb/f-lang.c index bd6ef20f9b1..57dd2ed7e31 100644 --- a/gdb/f-lang.c +++ b/gdb/f-lang.c @@ -128,6 +128,107 @@ const struct op_print f_language::op_print_tab[] = }; +/* Create an array containing the lower bounds (when LBOUND_P is true) or + the upper bounds (when LBOUND_P is false) of ARRAY (which must be of + array type). GDBARCH is the current architecture. */ + +static struct value * +fortran_bounds_all_dims (bool lbound_p, + struct gdbarch *gdbarch, + struct value *array) +{ + type *array_type = check_typedef (value_type (array)); + int ndimensions = calc_f77_array_dims (array_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_type (gdbarch)->builtin_long_long; + struct type *result_type = create_array_type (nullptr, elm_type, range); + struct value *result = allocate_value (result_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. */ + LONGEST elm_len = TYPE_LENGTH (elm_type); + for (LONGEST dst_offset = elm_len * (ndimensions - 1); + dst_offset >= 0; + dst_offset -= elm_len) + { + LONGEST b; + + /* Grab the required bound. */ + if (lbound_p) + b = f77_get_lowerbound (array_type); + else + b = f77_get_upperbound (array_type); + + /* And copy the value into the result value. */ + struct value *v = value_from_longest (elm_type, b); + 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. */ + array_type = TYPE_TARGET_TYPE (array_type); + } + + return result; +} + +/* Return the lower bound (when LBOUND_P is true) or the upper bound (when + LBOUND_P is false) for dimension DIM_VAL (which must be an integer) of + ARRAY (which must be an array). GDBARCH is the current architecture. */ + +static struct value * +fortran_bounds_for_dimension (bool lbound_p, + struct gdbarch *gdbarch, + struct value *array, + struct value *dim_val) +{ + /* Check the requested dimension is valid for this array. */ + type *array_type = check_typedef (value_type (array)); + int ndimensions = calc_f77_array_dims (array_type); + long dim = value_as_long (dim_val); + if (dim < 1 || dim > ndimensions) + { + if (lbound_p) + error (_("LBOUND dimension must be from 1 to %d"), ndimensions); + else + error (_("UBOUND dimension must be from 1 to %d"), ndimensions); + } + + /* The type for the result. */ + struct type *bound_type = builtin_type (gdbarch)->builtin_long_long; + + /* Walk the dimensions backwards, due to the ordering in which arrays are + laid out the first dimension is the most inner. */ + 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) + { + LONGEST b; + + if (lbound_p) + b = f77_get_lowerbound (array_type); + else + b = f77_get_upperbound (array_type); + + return value_from_longest (bound_type, b); + } + + /* Peel off another dimension of the array. */ + array_type = TYPE_TARGET_TYPE (array_type); + } + + gdb_assert_not_reached ("failed to find matching dimension"); +} + + /* Return the number of dimensions for a Fortran array or string. */ int @@ -843,6 +944,47 @@ evaluate_subexp_f (struct type *expect_type, struct expression *exp, error (_("MODULO of type %s not supported"), TYPE_SAFE_NAME (type)); } + case FORTRAN_LBOUND: + case FORTRAN_UBOUND: + { + int nargs = longest_to_int (exp->elts[pc + 1].longconst); + (*pos) += 2; + + /* This assertion should be enforced by the expression parser. */ + gdb_assert (nargs == 1 || nargs == 2); + + bool lbound_p = op == FORTRAN_LBOUND; + + /* Check that the first argument is array like. */ + arg1 = evaluate_subexp (nullptr, exp, pos, noside); + type = check_typedef (value_type (arg1)); + if (type->code () != TYPE_CODE_ARRAY) + { + if (lbound_p) + error (_("LBOUND can only be applied to arrays")); + else + error (_("UBOUND can only be applied to arrays")); + } + + if (nargs == 1) + return fortran_bounds_all_dims (lbound_p, exp->gdbarch, arg1); + + /* User asked for the bounds of a specific dimension of the array. */ + arg2 = evaluate_subexp (nullptr, exp, pos, noside); + type = check_typedef (value_type (arg2)); + if (type->code () != TYPE_CODE_INT) + { + if (lbound_p) + error (_("LBOUND second argument should be an integer")); + else + error (_("UBOUND second argument should be an integer")); + } + + return fortran_bounds_for_dimension (lbound_p, exp->gdbarch, arg1, + arg2); + } + break; + case BINOP_FORTRAN_CMPLX: arg1 = evaluate_subexp (nullptr, exp, pos, noside); arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside); @@ -986,6 +1128,12 @@ operator_length_f (const struct expression *exp, int pc, int *oplenp, args = 2; break; + case FORTRAN_LBOUND: + case FORTRAN_UBOUND: + oplen = 3; + args = longest_to_int (exp->elts[pc - 2].longconst); + break; + case OP_F77_UNDETERMINED_ARGLIST: oplen = 3; args = 1 + longest_to_int (exp->elts[pc - 2].longconst); @@ -1063,6 +1211,23 @@ print_subexp_f (struct expression *exp, int *pos, print_binop_subexp_f (exp, pos, stream, prec, "MODULO"); return; + case FORTRAN_LBOUND: + case FORTRAN_UBOUND: + { + unsigned nargs = longest_to_int (exp->elts[*pos + 1].longconst); + (*pos) += 3; + fprintf_filtered (stream, "%s (", + ((op == FORTRAN_LBOUND) ? "LBOUND" : "UBOUND")); + for (unsigned tem = 0; tem < nargs; tem++) + { + if (tem != 0) + fputs_filtered (", ", stream); + print_subexp (exp, pos, stream, PREC_ABOVE_COMMA); + } + fputs_filtered (")", stream); + return; + } + case OP_F77_UNDETERMINED_ARGLIST: (*pos)++; print_subexp_funcall (exp, pos, stream); @@ -1092,6 +1257,11 @@ dump_subexp_body_f (struct expression *exp, operator_length_f (exp, (elt + 1), &oplen, &nargs); break; + case FORTRAN_LBOUND: + case FORTRAN_UBOUND: + operator_length_f (exp, (elt + 3), &oplen, &nargs); + break; + case OP_F77_UNDETERMINED_ARGLIST: return dump_subexp_body_funcall (exp, stream, elt + 1); } @@ -1120,6 +1290,8 @@ operator_check_f (struct expression *exp, int pos, case UNOP_FORTRAN_CEILING: case BINOP_FORTRAN_CMPLX: case BINOP_FORTRAN_MODULO: + case FORTRAN_LBOUND: + case FORTRAN_UBOUND: /* Any references to objfiles are held in the arguments to this expression, not within the expression itself, so no additional checking is required here, the outer expression iteration code diff --git a/gdb/std-operator.def b/gdb/std-operator.def index 925e2b6484e..aad89990c5b 100644 --- a/gdb/std-operator.def +++ b/gdb/std-operator.def @@ -442,3 +442,7 @@ OP (UNOP_FORTRAN_CEILING) /* Two operand builtins. */ OP (BINOP_FORTRAN_CMPLX) OP (BINOP_FORTRAN_MODULO) + +/* Builtins that take one or two operands. */ +OP (FORTRAN_LBOUND) +OP (FORTRAN_UBOUND) diff --git a/gdb/testsuite/ChangeLog b/gdb/testsuite/ChangeLog index 881f111b5d5..6d10953d705 100644 --- a/gdb/testsuite/ChangeLog +++ b/gdb/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2021-02-10 Andrew Burgess + + * gdb.fortran/lbound-ubound.F90: New file. + * gdb.fortran/lbound-ubound.exp: New file. + 2021-02-10 Tom de Vries * lib/gdb.exp (gdb_load_no_complaints): Remove unnecessary diff --git a/gdb/testsuite/gdb.fortran/lbound-ubound.F90 b/gdb/testsuite/gdb.fortran/lbound-ubound.F90 new file mode 100644 index 00000000000..1988760e670 --- /dev/null +++ b/gdb/testsuite/gdb.fortran/lbound-ubound.F90 @@ -0,0 +1,105 @@ +! 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 . + +#define DO_TEST(ARRAY) \ + call do_test (lbound (ARRAY), ubound (ARRAY)) + +subroutine do_test (lb, ub) + integer, dimension (:) :: lb + integer, dimension (:) :: ub + + print *, "" + print *, "Expected GDB Output:" + print *, "" + + write(*, fmt="(A)", advance="no") "LBOUND = (" + do i=LBOUND (lb, 1), UBOUND (lb, 1), 1 + if (i > LBOUND (lb, 1)) then + write(*, fmt="(A)", advance="no") ", " + end if + write(*, fmt="(I0)", advance="no") lb (i) + end do + write(*, fmt="(A)", advance="yes") ")" + + write(*, fmt="(A)", advance="no") "UBOUND = (" + do i=LBOUND (ub, 1), UBOUND (ub, 1), 1 + if (i > LBOUND (ub, 1)) then + write(*, fmt="(A)", advance="no") ", " + end if + write(*, fmt="(I0)", advance="no") ub (i) + end do + write(*, fmt="(A)", advance="yes") ")" + + print *, "" ! Test Breakpoint +end subroutine do_test + +! +! Start of test program. +! +program test + interface + subroutine do_test (lb, ub) + integer, dimension (:) :: lb + integer, dimension (:) :: ub + end subroutine do_test + end interface + + ! Declare variables used in this test. + integer, dimension (-8:-1,-10:-2) :: neg_array + integer, dimension (2:10,1:9), target :: array + integer, allocatable :: other (:, :) + character (len=26) :: str_1 = "abcdefghijklmnopqrstuvwxyz" + integer, dimension (-2:2,-3:3,-1:5) :: array3d + integer, dimension (-3:3,7:10,-4:2,-10:-7) :: array4d + integer, dimension (10:20) :: array1d + integer, dimension(:,:), pointer :: pointer2d => null() + integer, dimension(-2:6,-1:9), target :: tarray + integer :: an_int + + integer, dimension (:), pointer :: pointer1d => null() + + ! Allocate or associate any variables as needed. + allocate (other (-5:4, -2:7)) + pointer2d => tarray + pointer1d => array (3, 2:5) + + DO_TEST (neg_array) + DO_TEST (neg_array (-7:-3,-5:-4)) + DO_TEST (array) + ! The following is disabled due to a bug in gfortran: + ! https://gcc.gnu.org/bugzilla/show_bug.cgi?id=99027 + ! gfortran generates the incorrect expected results. + ! DO_TEST (array (3, 2:5)) + DO_TEST (pointer1d) + DO_TEST (other) + DO_TEST (array3d) + DO_TEST (array4d) + DO_TEST (array1d) + DO_TEST (pointer2d) + DO_TEST (tarray) + + ! All done. Deallocate. + deallocate (other) + + ! GDB catches this final breakpoint to indicate the end of the test. + print *, "" ! Final Breakpoint. + + ! Reference otherwise unused locals in order to keep them around. + ! GDB will make use of these for some tests. + print *, str_1 + an_int = 1 + print *, an_int + +end program test diff --git a/gdb/testsuite/gdb.fortran/lbound-ubound.exp b/gdb/testsuite/gdb.fortran/lbound-ubound.exp new file mode 100644 index 00000000000..597851ef454 --- /dev/null +++ b/gdb/testsuite/gdb.fortran/lbound-ubound.exp @@ -0,0 +1,204 @@ +# 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 . + +# Print a 2 dimensional assumed shape array. We pass different slices +# of the array to a subroutine and print the array as recieved within +# the subroutine. This should exercise GDB's ability to handle +# different strides for the different dimensions. + +# Testing GDB's implementation of LBOUND and UBOUND. + +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"] + +set found_final_breakpoint false + +# 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 test_count 0 +while { $test_count < 500 } { + with_test_prefix "test $test_count" { + incr test_count + + set expected_lbound "" + set expected_ubound "" + gdb_test_multiple "continue" "continue" { + -re ".*LBOUND = (\[^\r\n\]+)\r\n" { + set expected_lbound $expect_out(1,string) + exp_continue + } + -re ".*UBOUND = (\[^\r\n\]+)\r\n" { + set expected_ubound $expect_out(1,string) + exp_continue + } + -re "! Test Breakpoint" { + set func_name "show_elem" + exp_continue + } + -re "! Final Breakpoint" { + set found_final_breakpoint true + exp_continue + } + -re "$gdb_prompt $" { + # We're done. + } + } + + if ($found_final_breakpoint) { + break + } + + verbose -log "APB: Run a test here" + verbose -log "APB: Expected lbound '$expected_lbound'" + verbose -log "APB: Expected ubound '$expected_ubound'" + + # We want to take a look at the line in the previous frame that + # called the current function. I couldn't find a better way of + # doing this than 'up', which will print the line, then 'down' + # again. + # + # I don't want to fill the log with passes for these up/down + # commands, so we don't report any. If something goes wrong then we + # should get a fail from gdb_test_multiple. + set array_name "" + set xfail_data "" + gdb_test_multiple "up" "up" { + -re "\r\n\[0-9\]+\[ \t\]+DO_TEST \\((\[^\r\n\]+)\\)\r\n$gdb_prompt $" { + set array_name $expect_out(1,string) + } + } + + # Check we have all the information we need to successfully run one + # of these tests. + if { $expected_lbound == "" } { + perror "failed to extract expected results for lbound" + return 0 + } + if { $expected_ubound == "" } { + perror "failed to extract expected results for ubound" + return 0 + } + if { $array_name == "" } { + perror "failed to extract array name" + return 0 + } + + # Check GDB can correctly print complete set of upper and + # lower bounds for an array. + set pattern [string_to_regexp " = $expected_lbound"] + gdb_test "p lbound ($array_name)" "$pattern" \ + "check value of lbound ('$array_name') expression" + set pattern [string_to_regexp " = $expected_ubound"] + gdb_test "p ubound ($array_name)" "$pattern" \ + "check value of ubound ('$array_name') expression" + + # Now ask for each bound in turn and check it against the + # expected results. + # + # First ask for bound 0. This should fail, but will also tell + # us the actual bounds of the array. Thanks GDB. + set upper_dim "" + gdb_test_multiple "p lbound ($array_name, 0)" "" { + -re "\r\nLBOUND dimension must be from 1 to (\[0-9\]+)\r\n$gdb_prompt $" { + set upper_dim $expect_out(1,string) + } + } + + gdb_assert { ![string eq $upper_dim ""] } \ + "extracted the upper dimension value" + + # Check that asking for the ubound dimension 0 gives the same + # dimension range as in the lbound case. + gdb_test_multiple "p ubound ($array_name, 0)" "" { + -re "\r\nUBOUND dimension must be from 1 to (\[0-9\]+)\r\n$gdb_prompt $" { + gdb_assert {$upper_dim == $expect_out(1,string)} \ + "ubound limit matches lbound limit" + } + } + + # Now ask for the upper and lower bound for each dimension in + # turn. Add these results into a string which, when complete, + # will look like the expected results seen above. + set lbound_str "" + set ubound_str "" + set prefix "(" + for { set i 1 } { $i <= $upper_dim } { incr i } { + set v [get_valueof "/d" "lbound ($array_name, $i)" "???"] + set lbound_str "${lbound_str}${prefix}${v}" + + set v [get_valueof "/d" "ubound ($array_name, $i)" "???"] + set ubound_str "${ubound_str}${prefix}${v}" + + set prefix ", " + } + + # Add closing parenthesis. + set lbound_str "${lbound_str})" + set ubound_str "${ubound_str})" + + gdb_assert [string eq ${lbound_str} $expected_lbound] \ + "lbounds match" + gdb_assert [string eq ${ubound_str} $expected_ubound] \ + "ubounds match" + + # Finally, check that asking for a dimension above the valid + # range gives the expected error. + set bad_dim [expr $upper_dim + 1] + gdb_test "p lbound ($array_name, $bad_dim)" \ + "LBOUND dimension must be from 1 to $upper_dim" \ + "check error message for lbound of dim = $bad_dim" + + gdb_test "p ubound ($array_name, $bad_dim)" \ + "UBOUND dimension must be from 1 to $upper_dim" \ + "check error message for ubound of dim = $bad_dim" + + # Move back up a frame just so we finish the test in frame 0. + gdb_test_multiple "down" "down" { + -re "\r\n$gdb_prompt $" { + # Don't issue a pass here. + } + } + } +} + +# 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} "reached final breakpoint" + +# Now for some final tests. This is mostly testing that GDB gives the +# correct errors in certain cases. +foreach var {str_1 an_int} { + foreach func {lbound ubound} { + gdb_test "p ${func} ($var)" \ + "[string toupper $func] can only be applied to arrays" + } +} -- 2.30.2