Fortran: Fix ICE with use of c_associated.

	PR fortran/120049

gcc/fortran/ChangeLog:

	* check.cc (gfc_check_c_associated): Modify checks to avoid
	ICE and allow use, intrinsic :: iso_c_binding from a separate
	module file.

gcc/testsuite/ChangeLog:

	* gfortran.dg/pr120049_a.f90: New test.
	* gfortran.dg/pr120049_b.f90: New test.

diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index 299c216cf36c070badeb05b4dd3abcc02b5245bc..f02a2a33897417f073807456529cc615b7903c49 100644 (file)
--- a/gcc/fortran/check.cc
+++ b/gcc/fortran/check.cc
@@ -5955,30 +5955,40 @@ gfc_check_c_sizeof (gfc_expr *arg)
 bool
 gfc_check_c_associated (gfc_expr *c_ptr_1, gfc_expr *c_ptr_2)
 {
-  if (c_ptr_1->ts.type != BT_DERIVED
-      || c_ptr_1->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
-      || (c_ptr_1->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR
-         && c_ptr_1->ts.u.derived->intmod_sym_id != ISOCBINDING_FUNPTR))
+  if (c_ptr_1)
     {
-      gfc_error ("Argument C_PTR_1 at %L to C_ASSOCIATED shall have the "
-                "type TYPE(C_PTR) or TYPE(C_FUNPTR)", &c_ptr_1->where);
-      return false;
+      if (c_ptr_1->expr_type == EXPR_FUNCTION && c_ptr_1->ts.type == BT_VOID)
+       return true;
+
+      if (c_ptr_1->ts.type != BT_DERIVED
+         || c_ptr_1->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
+         || (c_ptr_1->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR
+             && c_ptr_1->ts.u.derived->intmod_sym_id != ISOCBINDING_FUNPTR))
+       {
+         gfc_error ("Argument C_PTR_1 at %L to C_ASSOCIATED shall have the "
+                    "type TYPE(C_PTR) or TYPE(C_FUNPTR)", &c_ptr_1->where);
+         return false;
+       }
     }
 
   if (!scalar_check (c_ptr_1, 0))
     return false;
 
-  if (c_ptr_2
-      && (c_ptr_2->ts.type != BT_DERIVED
+  if (c_ptr_2)
+    {
+      if (c_ptr_2->expr_type == EXPR_FUNCTION && c_ptr_2->ts.type == BT_VOID)
+       return true;
+
+      if (c_ptr_2->ts.type != BT_DERIVED
          || c_ptr_2->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
          || (c_ptr_1->ts.u.derived->intmod_sym_id
-             != c_ptr_2->ts.u.derived->intmod_sym_id)))
-    {
-      gfc_error ("Argument C_PTR_2 at %L to C_ASSOCIATED shall have the "
-                "same type as C_PTR_1: %s instead of %s", &c_ptr_1->where,
-                gfc_typename (&c_ptr_1->ts),
-                gfc_typename (&c_ptr_2->ts));
-      return false;
+             != c_ptr_2->ts.u.derived->intmod_sym_id))
+       {
+         gfc_error ("Argument C_PTR_2 at %L to C_ASSOCIATED shall have the "
+                  "same type as C_PTR_1: %s instead of %s", &c_ptr_1->where,
+                  gfc_typename (&c_ptr_1->ts), gfc_typename (&c_ptr_2->ts));
+         return false;
+       }
     }
 
   if (c_ptr_2 && !scalar_check (c_ptr_2, 1))

diff --git a/gcc/testsuite/gfortran.dg/pr120049_a.f90 b/gcc/testsuite/gfortran.dg/pr120049_a.f90
new file mode 100644 (file)
index 0000000..c404a4d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr120049_a.f90
@@ -0,0 +1,15 @@
+! { dg-do preprocess }
+! { dg-additional-options "-cpp" }
+!
+! Test the fix for PR86248
+program tests_gtk_sup
+  use gtk_sup
+  implicit none
+  type(c_ptr), target :: val
+  if (c_associated(val, c_loc(val))) then
+    stop 1
+  endif
+  if (c_associated(c_loc(val), val)) then
+    stop 2
+  endif
+end program tests_gtk_sup

diff --git a/gcc/testsuite/gfortran.dg/pr120049_b.f90 b/gcc/testsuite/gfortran.dg/pr120049_b.f90
new file mode 100644 (file)
index 0000000..127db98
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr120049_b.f90
@@ -0,0 +1,8 @@
+! { dg-do  run }
+! { dg-additional-sources pr120049_a.f90 }
+!
+! Module for pr120049.f90
+!
+module gtk_sup
+  use, intrinsic :: iso_c_binding
+end module gtk_sup