diff mbox series

[Fortran] PR 92994 – add more ASSOCIATE checks

Message ID 5a9add50-ab21-707b-7ea0-611d83017e91@codesourcery.com
State New
Headers show
Series [Fortran] PR 92994 – add more ASSOCIATE checks | expand

Commit Message

Tobias Burnus Jan. 2, 2020, 5:47 p.m. UTC
Add some more checks for invalid use for the RHS in proc-pointer 
assignments and for ASSOCIATE targets (which uses the latter if the 
previous match failed).

Build on x86-64-gnu-linux. OK for the trunk?

Tobias

Comments

Thomas Koenig Jan. 2, 2020, 10:37 p.m. UTC | #1
Hi Tobias,

> Build on x86-64-gnu-linux. OK for the trunk?

Looks good.

Thanks for the patch!

Regards

	Thomas
diff mbox series

Patch

	PR fortran/92994
	* primary.c (gfc_match_rvalue): Add some flavor checks
	gfc_matching_procptr_assignment.
	* resolve.c (resolve_assoc_var): Add more checks for invalid targets.

	PR fortran/92994
	* gfortran.dg/associate_50.f90: Update dg-error.
	* gfortran.dg/associate_51.f90: New.

 gcc/fortran/primary.c                      | 14 +++++++-
 gcc/fortran/resolve.c                      | 21 ++++++++++--
 gcc/testsuite/gfortran.dg/associate_50.f90 |  4 +--
 gcc/testsuite/gfortran.dg/associate_51.f90 | 54 ++++++++++++++++++++++++++++++
 4 files changed, 88 insertions(+), 5 deletions(-)

diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index 189b904527e..e2b6fcb2106 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -3447,7 +3447,19 @@  gfc_match_rvalue (gfc_expr **result)
     }
 
   if (gfc_matching_procptr_assignment)
-    goto procptr0;
+    {
+      /* It can be a procedure or a derived-type procedure or a not-yet-known
+	 type.  */
+      if (sym->attr.flavor != FL_UNKNOWN
+	  && sym->attr.flavor != FL_PROCEDURE
+	  && sym->attr.flavor != FL_PARAMETER
+	  && sym->attr.flavor != FL_VARIABLE)
+	{
+	  gfc_error ("Symbol at %C is not appropriate for an expression");
+	  return MATCH_ERROR;
+	}
+      goto procptr0;
+    }
 
   if (sym->attr.function || sym->attr.external || sym->attr.intrinsic)
     goto function0;
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 4aa5f1b568a..6f2a4c4d65a 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -8836,9 +8836,20 @@  resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
 
       gcc_assert (target->symtree);
       tsym = target->symtree->n.sym;
-      if (tsym->attr.flavor == FL_PROGRAM)
+
+      if (tsym->attr.subroutine
+	  || tsym->attr.external
+	  || (tsym->attr.function
+	      && (tsym->result != tsym || tsym->attr.recursive)))
 	{
-	  gfc_error ("Associating entity %qs at %L is a PROGRAM",
+	  gfc_error ("Associating entity %qs at %L is a procedure name",
+		     tsym->name, &target->where);
+	  return;
+	}
+
+      if (gfc_expr_attr (target).proc_pointer)
+	{
+	  gfc_error ("Associating entity %qs at %L is a procedure pointer",
 		     tsym->name, &target->where);
 	  return;
 	}
@@ -8851,6 +8862,12 @@  resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
       if (is_subref_array (target))
 	sym->attr.subref_array_pointer = 1;
     }
+  else if (target->ts.type == BT_PROCEDURE)
+    {
+      gfc_error ("Associating selector-expression at %L yields a procedure",
+		 &target->where);
+      return;
+    }
 
   if (target->expr_type == EXPR_NULL)
     {
diff --git a/gcc/testsuite/gfortran.dg/associate_50.f90 b/gcc/testsuite/gfortran.dg/associate_50.f90
index d759db59b29..990ec58bffe 100644
--- a/gcc/testsuite/gfortran.dg/associate_50.f90
+++ b/gcc/testsuite/gfortran.dg/associate_50.f90
@@ -3,6 +3,6 @@ 
 ! Test case by Gerhard Steinmetz.
 
 program p
-  associate (y => p) ! { dg-error "is a PROGRAM" }
-  end associate
+  associate (y => p) ! { dg-error "Invalid association target" }
+  end associate  ! { dg-error "Expecting END PROGRAM statement" }
 end program p
diff --git a/gcc/testsuite/gfortran.dg/associate_51.f90 b/gcc/testsuite/gfortran.dg/associate_51.f90
new file mode 100644
index 00000000000..7b3edc44990
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/associate_51.f90
@@ -0,0 +1,54 @@ 
+! { dg-do compile }
+!
+! PR fortran/92994
+!
+! Contributed by G. Steinmetz
+!
+recursive function f() result(z)
+  associate (y1 => f())
+  end associate
+  associate (y2 => f)  ! { dg-error "is a procedure name" }
+  end associate
+end
+
+recursive function f2()
+  associate (y1 => f2()) ! { dg-error "Invalid association target" }
+  end associate          ! { dg-error "Expecting END FUNCTION statement" }
+  associate (y2 => f2)   ! { dg-error "is a procedure name" }
+  end associate
+end
+
+subroutine p2
+  type t
+  end type
+  type(t) :: z = t()
+  associate (y => t)
+  end associate
+end
+
+subroutine p3
+  procedure() :: g
+  associate (y => g)  ! { dg-error "is a procedure name" }
+  end associate
+end
+
+subroutine p4
+  external :: g
+  associate (y => g)  ! { dg-error "is a procedure name" }
+  end associate
+end
+
+recursive subroutine s
+  associate (y => s)  ! { dg-error "is a procedure name" }
+  end associate
+end
+
+recursive subroutine s2
+   associate (y => (s2)) ! { dg-error "Associating selector-expression at .1. yields a procedure" }
+   end associate
+end
+
+program p
+   associate (y => (p)) ! { dg-error "Invalid association target" }
+   end associate ! { dg-error "Expecting END PROGRAM statement" }
+end