+2021-02-10 Andrew Burgess <andrew.burgess@embecosm.com>
+
+ * 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 <andrew.burgess@embecosm.com>
* coff-pe-read.c (add_pe_forwarded_sym): Make use of section_index
%token <opcode> ASSIGN_MODIFY
%token <opcode> UNOP_INTRINSIC BINOP_INTRINSIC
+%token <opcode> UNOP_OR_BINOP_INTRINSIC
%left ','
%left ABOVE_COMMA
{ 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
{ "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
};
\f
+/* 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");
+}
+\f
+
/* Return the number of dimensions for a Fortran array or string. */
int
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);
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);
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);
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);
}
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
/* Two operand builtins. */
OP (BINOP_FORTRAN_CMPLX)
OP (BINOP_FORTRAN_MODULO)
+
+/* Builtins that take one or two operands. */
+OP (FORTRAN_LBOUND)
+OP (FORTRAN_UBOUND)
+2021-02-10 Andrew Burgess <andrew.burgess@embecosm.com>
+
+ * gdb.fortran/lbound-ubound.F90: New file.
+ * gdb.fortran/lbound-ubound.exp: New file.
+
2021-02-10 Tom de Vries <tdevries@suse.de>
* lib/gdb.exp (gdb_load_no_complaints): Remove unnecessary
--- /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/>.
+
+#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
--- /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/> .
+
+# 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"
+ }
+}
projects / binutils-gdb.git / commitdiff