[PATCH] gdb/fortran: add support for ASSOCIATED builtin

[PATCH] gdb/fortran: add support for ASSOCIATED builtin

[Andrew Burgess]

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.
---
 gdb/ChangeLog                            |  13 ++
 gdb/f-exp.y                              |   1 +
 gdb/f-lang.c                             | 246 +++++++++++++++++++++--
 gdb/std-operator.def                     |   1 +
 gdb/testsuite/ChangeLog                  |   5 +
 gdb/testsuite/gdb.fortran/associated.exp |  87 ++++++++
 gdb/testsuite/gdb.fortran/associated.f90 |  97 +++++++++
 7 files changed, 436 insertions(+), 14 deletions(-)
 create mode 100644 gdb/testsuite/gdb.fortran/associated.exp
 create mode 100644 gdb/testsuite/gdb.fortran/associated.f90

diff --git a/gdb/f-exp.y b/gdb/f-exp.y
index e95a2c974ca..b825b6f1df4 100644
--- a/gdb/f-exp.y
+++ b/gdb/f-exp.y
@@ -1047,6 +1047,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 08ed56a7469..31fff34ae76 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 f3533aa3908..99b5d90381a 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/gdb.fortran/associated.exp b/gdb/testsuite/gdb.fortran/associated.exp
new file mode 100644
index 00000000000..d9976f7e8bc
--- /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 00000000000..093af53f830
--- /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
-- 
2.25.4

Re: [PATCH] gdb/fortran: add support for ASSOCIATED builtin

[Tom Tromey]

>>>>> "Andrew" == Andrew Burgess <andrew.burgess@embecosm.com> writes:

Andrew> gdb/ChangeLog:

Andrew> 	* f-exp.y (f77_keywords): Add 'associated'.
Andrew> 	* f-lang.c (fortran_associated): New function.
Andrew> 	(evaluate_subexp_f): Handle FORTRAN_ASSOCIATED.
Andrew> 	(operator_length_f): Likewise.
Andrew> 	(print_unop_or_binop_subexp_f): New function.
Andrew> 	(print_subexp_f): Make use of print_unop_or_binop_subexp_f for
Andrew> 	FORTRAN_ASSOCIATED, FORTRAN_LBOUND, and FORTRAN_UBOUND.
Andrew> 	(dump_subexp_body_f): Handle FORTRAN_ASSOCIATED.
Andrew> 	(operator_check_f): Likewise.
Andrew> 	* std-operator.def: Add FORTRAN_ASSOCIATED.

Looks reasonable to me.

Tom

Re: [PATCH] gdb/fortran: add support for ASSOCIATED builtin

[Tom Tromey]

>>>>> "Tom" == Tom Tromey <tom@tromey.com> writes:

>>>>> "Andrew" == Andrew Burgess <andrew.burgess@embecosm.com> writes:
Andrew> gdb/ChangeLog:

Andrew> * f-exp.y (f77_keywords): Add 'associated'.
Andrew> * f-lang.c (fortran_associated): New function.
Andrew> (evaluate_subexp_f): Handle FORTRAN_ASSOCIATED.
Andrew> (operator_length_f): Likewise.
Andrew> (print_unop_or_binop_subexp_f): New function.
Andrew> (print_subexp_f): Make use of print_unop_or_binop_subexp_f for
Andrew> FORTRAN_ASSOCIATED, FORTRAN_LBOUND, and FORTRAN_UBOUND.
Andrew> (dump_subexp_body_f): Handle FORTRAN_ASSOCIATED.
Andrew> (operator_check_f): Likewise.
Andrew> * std-operator.def: Add FORTRAN_ASSOCIATED.

Tom> Looks reasonable to me.

FWIW I've updated my expression rewrite series to handle this, plus some
other changes you've checked in recently.

Tom