diff options
Diffstat (limited to 'gdb')
| -rw-r--r-- | gdb/ChangeLog | 13 | ||||
| -rw-r--r-- | gdb/f-exp.y | 1 | ||||
| -rw-r--r-- | gdb/f-lang.c | 246 | ||||
| -rw-r--r-- | gdb/std-operator.def | 1 | ||||
| -rw-r--r-- | gdb/testsuite/ChangeLog | 5 | ||||
| -rw-r--r-- | gdb/testsuite/gdb.fortran/associated.exp | 87 | ||||
| -rw-r--r-- | gdb/testsuite/gdb.fortran/associated.f90 | 97 |
7 files changed, 436 insertions, 14 deletions
diff --git a/gdb/ChangeLog b/gdb/ChangeLog index 8219a1f..7781479 100644 --- a/gdb/ChangeLog +++ b/gdb/ChangeLog @@ -1,5 +1,18 @@ 2021-02-25 Andrew Burgess <andrew.burgess@embecosm.com> + * f-exp.y (f77_keywords): Add 'associated'. + * f-lang.c (fortran_associated): New function. + (evaluate_subexp_f): Handle FORTRAN_ASSOCIATED. + (operator_length_f): Likewise. + (print_unop_or_binop_subexp_f): New function. + (print_subexp_f): Make use of print_unop_or_binop_subexp_f for + FORTRAN_ASSOCIATED, FORTRAN_LBOUND, and FORTRAN_UBOUND. + (dump_subexp_body_f): Handle FORTRAN_ASSOCIATED. + (operator_check_f): Likewise. + * std-operator.def: Add FORTRAN_ASSOCIATED. + +2021-02-25 Andrew Burgess <andrew.burgess@embecosm.com> + * f-exp.y (fortran_operators): Add ".xor.". 2021-02-24 Tom de Vries <tdevries@suse.de> diff --git a/gdb/f-exp.y b/gdb/f-exp.y index 64f5fd5..f5360c1 100644 --- a/gdb/f-exp.y +++ b/gdb/f-exp.y @@ -1048,6 +1048,7 @@ static const struct token f77_keywords[] = { "lbound", UNOP_OR_BINOP_INTRINSIC, FORTRAN_LBOUND, false }, { "ubound", UNOP_OR_BINOP_INTRINSIC, FORTRAN_UBOUND, false }, { "allocated", UNOP_INTRINSIC, UNOP_FORTRAN_ALLOCATED, false }, + { "associated", UNOP_OR_BINOP_INTRINSIC, FORTRAN_ASSOCIATED, false }, }; /* Implementation of a dynamically expandable buffer for processing input diff --git a/gdb/f-lang.c b/gdb/f-lang.c index 08ed56a..31fff34 100644 --- a/gdb/f-lang.c +++ b/gdb/f-lang.c @@ -799,6 +799,179 @@ fortran_value_subarray (struct value *array, struct expression *exp, return array; } +/* Evaluate FORTRAN_ASSOCIATED expressions. Both GDBARCH and LANG are + extracted from the expression being evaluated. POINTER is the required + first argument to the 'associated' keyword, and TARGET is the optional + second argument, this will be nullptr if the user only passed one + argument to their use of 'associated'. */ + +static struct value * +fortran_associated (struct gdbarch *gdbarch, const language_defn *lang, + struct value *pointer, struct value *target = nullptr) +{ + struct type *result_type = language_bool_type (lang, gdbarch); + + /* All Fortran pointers should have the associated property, this is + how we know the pointer is pointing at something or not. */ + struct type *pointer_type = check_typedef (value_type (pointer)); + if (TYPE_ASSOCIATED_PROP (pointer_type) == nullptr + && pointer_type->code () != TYPE_CODE_PTR) + error (_("ASSOCIATED can only be applied to pointers")); + + /* Get an address from POINTER. Fortran (or at least gfortran) models + array pointers as arrays with a dynamic data address, so we need to + use two approaches here, for real pointers we take the contents of the + pointer as an address. For non-pointers we take the address of the + content. */ + CORE_ADDR pointer_addr; + if (pointer_type->code () == TYPE_CODE_PTR) + pointer_addr = value_as_address (pointer); + else + pointer_addr = value_address (pointer); + + /* The single argument case, is POINTER associated with anything? */ + if (target == nullptr) + { + bool is_associated = false; + + /* If POINTER is an actual pointer and doesn't have an associated + property then we need to figure out whether this pointer is + associated by looking at the value of the pointer itself. We make + the assumption that a non-associated pointer will be set to 0. + This is probably true for most targets, but might not be true for + everyone. */ + if (pointer_type->code () == TYPE_CODE_PTR + && TYPE_ASSOCIATED_PROP (pointer_type) == nullptr) + is_associated = (pointer_addr != 0); + else + is_associated = !type_not_associated (pointer_type); + return value_from_longest (result_type, is_associated ? 1 : 0); + } + + /* The two argument case, is POINTER associated with TARGET? */ + + struct type *target_type = check_typedef (value_type (target)); + + struct type *pointer_target_type; + if (pointer_type->code () == TYPE_CODE_PTR) + pointer_target_type = TYPE_TARGET_TYPE (pointer_type); + else + pointer_target_type = pointer_type; + + struct type *target_target_type; + if (target_type->code () == TYPE_CODE_PTR) + target_target_type = TYPE_TARGET_TYPE (target_type); + else + target_target_type = target_type; + + if (pointer_target_type->code () != target_target_type->code () + || (pointer_target_type->code () != TYPE_CODE_ARRAY + && (TYPE_LENGTH (pointer_target_type) + != TYPE_LENGTH (target_target_type)))) + error (_("arguments to associated must be of same type and kind")); + + /* If TARGET is not in memory, or the original pointer is specifically + known to be not associated with anything, then the answer is obviously + false. Alternatively, if POINTER is an actual pointer and has no + associated property, then we have to check if its associated by + looking the value of the pointer itself. We make the assumption that + a non-associated pointer will be set to 0. This is probably true for + most targets, but might not be true for everyone. */ + if (value_lval_const (target) != lval_memory + || type_not_associated (pointer_type) + || (TYPE_ASSOCIATED_PROP (pointer_type) == nullptr + && pointer_type->code () == TYPE_CODE_PTR + && pointer_addr == 0)) + return value_from_longest (result_type, 0); + + /* See the comment for POINTER_ADDR above. */ + CORE_ADDR target_addr; + if (target_type->code () == TYPE_CODE_PTR) + target_addr = value_as_address (target); + else + target_addr = value_address (target); + + /* Wrap the following checks inside a do { ... } while (false) loop so + that we can use `break' to jump out of the loop. */ + bool is_associated = false; + do + { + /* If the addresses are different then POINTER is definitely not + pointing at TARGET. */ + if (pointer_addr != target_addr) + break; + + /* If POINTER is a real pointer (i.e. not an array pointer, which are + implemented as arrays with a dynamic content address), then this + is all the checking that is needed. */ + if (pointer_type->code () == TYPE_CODE_PTR) + { + is_associated = true; + break; + } + + /* We have an array pointer. Check the number of dimensions. */ + int pointer_dims = calc_f77_array_dims (pointer_type); + int target_dims = calc_f77_array_dims (target_type); + if (pointer_dims != target_dims) + break; + + /* Now check that every dimension has the same upper bound, lower + bound, and stride value. */ + int dim = 0; + while (dim < pointer_dims) + { + LONGEST pointer_lowerbound, pointer_upperbound, pointer_stride; + LONGEST target_lowerbound, target_upperbound, target_stride; + + pointer_type = check_typedef (pointer_type); + target_type = check_typedef (target_type); + + struct type *pointer_range = pointer_type->index_type (); + struct type *target_range = target_type->index_type (); + + if (!get_discrete_bounds (pointer_range, &pointer_lowerbound, + &pointer_upperbound)) + break; + + if (!get_discrete_bounds (target_range, &target_lowerbound, + &target_upperbound)) + break; + + if (pointer_lowerbound != target_lowerbound + || pointer_upperbound != target_upperbound) + break; + + /* Figure out the stride (in bits) for both pointer and target. + If either doesn't have a stride then we take the element size, + but we need to convert to bits (hence the * 8). */ + pointer_stride = pointer_range->bounds ()->bit_stride (); + if (pointer_stride == 0) + pointer_stride + = type_length_units (check_typedef + (TYPE_TARGET_TYPE (pointer_type))) * 8; + target_stride = target_range->bounds ()->bit_stride (); + if (target_stride == 0) + target_stride + = type_length_units (check_typedef + (TYPE_TARGET_TYPE (target_type))) * 8; + if (pointer_stride != target_stride) + break; + + ++dim; + } + + if (dim < pointer_dims) + break; + + is_associated = true; + } + while (false); + + return value_from_longest (result_type, is_associated ? 1 : 0); +} + + /* Special expression evaluation cases for Fortran. */ static struct value * @@ -999,6 +1172,32 @@ evaluate_subexp_f (struct type *expect_type, struct expression *exp, } break; + case FORTRAN_ASSOCIATED: + { + 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); + + arg1 = evaluate_subexp (nullptr, exp, pos, noside); + + if (nargs == 1) + { + if (noside == EVAL_SKIP) + return eval_skip_value (exp); + return fortran_associated (exp->gdbarch, exp->language_defn, + arg1); + } + + arg2 = evaluate_subexp (nullptr, exp, pos, noside); + if (noside == EVAL_SKIP) + return eval_skip_value (exp); + return fortran_associated (exp->gdbarch, exp->language_defn, + arg1, arg2); + } + break; + case BINOP_FORTRAN_CMPLX: arg1 = evaluate_subexp (nullptr, exp, pos, noside); arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside); @@ -1143,6 +1342,7 @@ operator_length_f (const struct expression *exp, int pc, int *oplenp, args = 2; break; + case FORTRAN_ASSOCIATED: case FORTRAN_LBOUND: case FORTRAN_UBOUND: oplen = 3; @@ -1191,6 +1391,27 @@ print_binop_subexp_f (struct expression *exp, int *pos, fputs_filtered (")", stream); } +/* Helper for PRINT_SUBEXP_F. Arguments are as for PRINT_SUBEXP_F, except + the extra argument NAME which is the text that should be printed as the + name of this operation. */ + +static void +print_unop_or_binop_subexp_f (struct expression *exp, int *pos, + struct ui_file *stream, enum precedence prec, + const char *name) +{ + unsigned nargs = longest_to_int (exp->elts[*pos + 1].longconst); + (*pos) += 3; + fprintf_filtered (stream, "%s (", name); + for (unsigned tem = 0; tem < nargs; tem++) + { + if (tem != 0) + fputs_filtered (", ", stream); + print_subexp (exp, pos, stream, PREC_ABOVE_COMMA); + } + fputs_filtered (")", stream); +} + /* Special expression printing for Fortran. */ static void @@ -1230,22 +1451,17 @@ print_subexp_f (struct expression *exp, int *pos, print_binop_subexp_f (exp, pos, stream, prec, "MODULO"); return; + case FORTRAN_ASSOCIATED: + print_unop_or_binop_subexp_f (exp, pos, stream, prec, "ASSOCIATED"); + return; + case FORTRAN_LBOUND: + print_unop_or_binop_subexp_f (exp, pos, stream, prec, "LBOUND"); + return; + 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; - } + print_unop_or_binop_subexp_f (exp, pos, stream, prec, "UBOUND"); + return; case OP_F77_UNDETERMINED_ARGLIST: (*pos)++; @@ -1277,6 +1493,7 @@ dump_subexp_body_f (struct expression *exp, operator_length_f (exp, (elt + 1), &oplen, &nargs); break; + case FORTRAN_ASSOCIATED: case FORTRAN_LBOUND: case FORTRAN_UBOUND: operator_length_f (exp, (elt + 3), &oplen, &nargs); @@ -1311,6 +1528,7 @@ operator_check_f (struct expression *exp, int pos, case UNOP_FORTRAN_ALLOCATED: case BINOP_FORTRAN_CMPLX: case BINOP_FORTRAN_MODULO: + case FORTRAN_ASSOCIATED: case FORTRAN_LBOUND: case FORTRAN_UBOUND: /* Any references to objfiles are held in the arguments to this diff --git a/gdb/std-operator.def b/gdb/std-operator.def index f3533aa..99b5d90 100644 --- a/gdb/std-operator.def +++ b/gdb/std-operator.def @@ -447,3 +447,4 @@ OP (BINOP_FORTRAN_MODULO) /* Builtins that take one or two operands. */ OP (FORTRAN_LBOUND) OP (FORTRAN_UBOUND) +OP (FORTRAN_ASSOCIATED) diff --git a/gdb/testsuite/ChangeLog b/gdb/testsuite/ChangeLog index 2bf9e41..21c98fa 100644 --- a/gdb/testsuite/ChangeLog +++ b/gdb/testsuite/ChangeLog @@ -1,5 +1,10 @@ 2021-02-25 Andrew Burgess <andrew.burgess@embecosm.com> + * gdb.fortran/associated.exp: New file. + * gdb.fortran/associated.f90: New file. + +2021-02-25 Andrew Burgess <andrew.burgess@embecosm.com> + * gdb.fortran/dot-ops.exp (dot_operations): Test ".xor.". 2021-02-24 Andrew Burgess <andrew.burgess@embecosm.com> diff --git a/gdb/testsuite/gdb.fortran/associated.exp b/gdb/testsuite/gdb.fortran/associated.exp new file mode 100644 index 0000000..d9976f7 --- /dev/null +++ b/gdb/testsuite/gdb.fortran/associated.exp @@ -0,0 +1,87 @@ +# 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 ASSOCIATED 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_associated \\((\[^\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" + +# Now perform the final tests. These should all be error condition +# checks, for things that can't be compiled into the test source file. +gdb_test "p associated (array_1d_p, an_integer)" \ + "arguments to associated must be of same type and kind" + +gdb_test "p associated (an_integer_p, a_real)" \ + "arguments to associated must be of same type and kind" diff --git a/gdb/testsuite/gdb.fortran/associated.f90 b/gdb/testsuite/gdb.fortran/associated.f90 new file mode 100644 index 0000000..093af53 --- /dev/null +++ b/gdb/testsuite/gdb.fortran/associated.f90 @@ -0,0 +1,97 @@ +! 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 point at. + integer, target :: array_1d (1:10) = 0 + integer, target :: array_2d (1:10, 1:10) = 0 + integer, target :: an_integer = 0 + integer, target :: other_integer = 0 + real, target :: a_real = 0.0 + + ! Things to point with. + integer, pointer :: array_1d_p (:) => null () + integer, pointer :: other_1d_p (:) => null () + integer, pointer :: array_2d_p (:,:) => null () + integer, pointer :: an_integer_p => null () + integer, pointer :: other_integer_p => null () + real, pointer :: a_real_p => null () + + ! The start of the tests. + call test_associated (associated (array_1d_p)) + call test_associated (associated (array_1d_p, array_1d)) + + array_1d_p => array_1d + call test_associated (associated (array_1d_p, array_1d)) + + array_1d_p => array_1d (2:10) + call test_associated (associated (array_1d_p, array_1d)) + + array_1d_p => array_1d (1:9) + call test_associated (associated (array_1d_p, array_1d)) + + array_1d_p => array_2d (3, :) + call test_associated (associated (array_1d_p, array_1d)) + call test_associated (associated (array_1d_p, array_2d (2, :))) + call test_associated (associated (array_1d_p, array_2d (3, :))) + + array_1d_p => null () + call test_associated (associated (array_1d_p)) + call test_associated (associated (array_1d_p, array_2d (3, :))) + + call test_associated (associated (an_integer_p)) + call test_associated (associated (an_integer_p, an_integer)) + an_integer_p => an_integer + call test_associated (associated (an_integer_p)) + call test_associated (associated (an_integer_p, an_integer)) + + call test_associated (associated (an_integer_p, other_integer_p)) + other_integer_p => other_integer + call test_associated (associated (other_integer_p)) + call test_associated (associated (an_integer_p, other_integer_p)) + call test_associated (associated (other_integer_p, an_integer_p)) + call test_associated (associated (other_integer_p, an_integer)) + + other_integer_p = an_integer_p + call test_associated (associated (an_integer_p, other_integer_p)) + call test_associated (associated (other_integer_p, an_integer_p)) + + call test_associated (associated (a_real_p)) + call test_associated (associated (a_real_p, a_real)) + a_real_p => a_real + call test_associated (associated (a_real_p, a_real)) + + ! Setup for final tests, these are performed at the print line + ! below. These final tests are all error conditon checks, + ! i.e. things that can't be compiled into Fortran. + array_1d_p => array_1d + + print *, "" ! Final Breakpoint + print *, an_integer + print *, a_real + +contains + + subroutine test_associated (answer) + logical :: answer + + print *,answer ! Test Breakpoint + end subroutine test_associated + +end program test |