FreeChainXenon/binutils-gdb
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

gdb/fortran: add support for ASSOCIATED builtin

Browse source 
This commit adds support for the ASSOCIATED builtin to the Fortran
expression evaluator.  The ASSOCIATED builtin takes one or two
arguments.

When passed a single pointer argument GDB returns a boolean indicating
if the pointer is associated with anything.

When passed two arguments the second argument should either be some a
pointer could point at or a second pointer.

If the second argument is a pointer target, then the result from
associated indicates if the pointer is pointing at this target.

If the second argument is another pointer, then the result from
associated indicates if the two pointers are pointing at the same
thing.

gdb/ChangeLog:

	* 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.

gdb/testsuite/ChangeLog:

	* gdb.fortran/associated.exp: New file.
	* gdb.fortran/associated.f90: New file.
This commit is contained in:
Andrew Burgess 2021-02-24 12:50:00 +00:00
parent 170f4b23b6
commit faeb9f13c1
7 changed files with 436 additions and 14 deletions
Download patch file Download diff file Expand all files Collapse all files

13
gdb/ChangeLog
View file

@ -1,3 +1,16 @@
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.".

1
gdb/f-exp.y
View file

@ -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

248
gdb/f-lang.c
View file

@ -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_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);
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:
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

1
gdb/std-operator.def
View file

@ -447,3 +447,4 @@ OP (BINOP_FORTRAN_MODULO)
/* Builtins that take one or two operands. */
OP (FORTRAN_LBOUND)
OP (FORTRAN_UBOUND)
OP (FORTRAN_ASSOCIATED)

5
gdb/testsuite/ChangeLog
View file

@ -1,3 +1,8 @@
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.".

87
gdb/testsuite/gdb.fortran/associated.exp Normal file
View file

@ -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"

97
gdb/testsuite/gdb.fortran/associated.f90 Normal file
View file

@ -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