Fortran: Fix c_associated argument checks.

	PR fortran/120049

gcc/fortran/ChangeLog:

	* check.cc (gfc_check_c_associated): Use new helper functions.
	Only call check_c_ptr_1 if optional c_ptr_2 tests succeed.
	(check_c_ptr_1): Handle only c_ptr_1 checks.
	(check_c_ptr_2): Expand checks for c_ptr_2 and handle cases
	where there is no derived pointer in the gfc_expr and check
	the inmod_sym_id only if it exists.
	* misc.cc (gfc_typename): Handle the case for BT_VOID rather
	than throw an internal error.

gcc/testsuite/ChangeLog:

	* gfortran.dg/pr120049_a.f90: Update test directives.
	* gfortran.dg/pr120049_b.f90: Update test directives
	* gfortran.dg/pr120049_2.f90: New test.

	Co-Authored-By: Steve Kargl <kargl@gcc.gnu.org>

diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index f02a2a33897417f073807456529cc615b7903c49..c693e4214070957e7a64314f0696e1d21e6d278f 100644 (file)
--- a/gcc/fortran/check.cc
+++ b/gcc/fortran/check.cc
@@ -5952,49 +5952,110 @@ gfc_check_c_sizeof (gfc_expr *arg)
 }
 
 
-bool
-gfc_check_c_associated (gfc_expr *c_ptr_1, gfc_expr *c_ptr_2)
+/* Helper functions check_c_ptr_1 and check_c_ptr_2
+   used in gfc_check_c_associated.  */
+
+static inline
+bool check_c_ptr_1 (gfc_expr *c_ptr_1)
 {
-  if (c_ptr_1)
-    {
-      if (c_ptr_1->expr_type == EXPR_FUNCTION && c_ptr_1->ts.type == BT_VOID)
-       return true;
+  if ((c_ptr_1->ts.type == BT_VOID)
+      && (c_ptr_1->expr_type == EXPR_FUNCTION))
+    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 (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))
+       goto check_1_error;
 
-  if (!scalar_check (c_ptr_1, 0))
+  if ((c_ptr_1->ts.type == BT_DERIVED)
+       && (c_ptr_1->expr_type == EXPR_STRUCTURE)
+       && (c_ptr_1->ts.u.derived->intmod_sym_id
+          == ISOCBINDING_NULL_FUNPTR))
+    goto check_1_error;
+
+  if (scalar_check (c_ptr_1, 0))
+    return true;
+  else
+    /*  Return since the check_1_error message may not apply here. */
     return false;
 
-  if (c_ptr_2)
-    {
-      if (c_ptr_2->expr_type == EXPR_FUNCTION && c_ptr_2->ts.type == BT_VOID)
-       return true;
+check_1_error:
 
-      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_1 at %L to C_ASSOCIATED shall have the "
+            "type TYPE(C_PTR) or TYPE(C_FUNPTR)", &c_ptr_1->where);
+  return false;
+}
+
+static inline
+bool check_c_ptr_2 (gfc_expr *c_ptr_1, gfc_expr *c_ptr_2)
+{
+  switch (c_ptr_2->ts.type)
+  {
+    case BT_VOID:
+      if (c_ptr_2->expr_type == EXPR_FUNCTION)
        {
-         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_1->ts.type == BT_DERIVED)
+              && c_ptr_1->expr_type == EXPR_STRUCTURE
+              && (c_ptr_1->ts.u.derived->intmod_sym_id
+                 == ISOCBINDING_FUNPTR))
+           goto check_2_error;
        }
-    }
+      break;
+
+    case BT_DERIVED:
+      if ((c_ptr_2->expr_type == EXPR_STRUCTURE)
+          && (c_ptr_2->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR)
+          && (c_ptr_1->ts.type == BT_VOID)
+          && (c_ptr_1->expr_type == EXPR_FUNCTION))
+       return scalar_check (c_ptr_2, 1);
 
-  if (c_ptr_2 && !scalar_check (c_ptr_2, 1))
+      if ((c_ptr_2->expr_type == EXPR_STRUCTURE)
+          && (c_ptr_1->ts.type == BT_VOID)
+          && (c_ptr_1->expr_type == EXPR_FUNCTION))
+       goto check_2_error;
+
+      if (c_ptr_2->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING)
+       goto check_2_error;
+
+      if (c_ptr_1->ts.type == BT_DERIVED
+         && (c_ptr_1->ts.u.derived->intmod_sym_id
+             != c_ptr_2->ts.u.derived->intmod_sym_id))
+       goto check_2_error;
+      break;
+
+    default:
+      goto check_2_error;
+  }
+
+  if (scalar_check (c_ptr_2, 1))
+    return true;
+  else
+    /*  Return since the check_2_error message may not apply here. */
     return false;
 
-  return true;
+check_2_error:
+
+  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_2->where,
+            gfc_typename (&c_ptr_1->ts), gfc_typename (&c_ptr_2->ts));
+
+  return false;
+ }
+
+
+bool
+gfc_check_c_associated (gfc_expr *c_ptr_1, gfc_expr *c_ptr_2)
+{
+  if (c_ptr_2)
+    {
+      if (check_c_ptr_2 (c_ptr_1, c_ptr_2))
+       return check_c_ptr_1 (c_ptr_1);
+      else
+       return false;
+    }
+  else
+    return check_c_ptr_1 (c_ptr_1);
 }
 
 

diff --git a/gcc/fortran/misc.cc b/gcc/fortran/misc.cc
index 893c40fbba2c8414b35edfda9fbdc59ca117ad72..b8bdf7578de6225f4c41aa839911a88e2d73f976 100644 (file)
--- a/gcc/fortran/misc.cc
+++ b/gcc/fortran/misc.cc
@@ -214,6 +214,9 @@ gfc_typename (gfc_typespec *ts, bool for_hash)
     case BT_UNKNOWN:
       strcpy (buffer, "UNKNOWN");
       break;
+    case BT_VOID:
+      strcpy (buffer, "VOID");
+      break;
     default:
       gfc_internal_error ("gfc_typename(): Undefined type");
     }

diff --git a/gcc/testsuite/gfortran.dg/pr120049_2.f90 b/gcc/testsuite/gfortran.dg/pr120049_2.f90
new file mode 100644 (file)
index 0000000..1f91e06
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr120049_2.f90
@@ -0,0 +1,62 @@
+! Compiled with pr120049_b.f90
+! { dg-options -O0 }
+! { dg-do compile }
+! { dg-compile-aux-modules "pr120049_b.f90" }
+!
+! Test the fix for PR120049
+program tests_gtk_sup
+  use gtk_sup
+  implicit none
+  
+  type mytype
+    integer :: myint
+  end type mytype
+  type(mytype) :: ijkl = mytype(42)
+  logical :: truth
+  real :: var1
+  type(c_ptr), target :: val
+  type(c_funptr), target :: fptr
+  character(15) :: stringy
+  complex :: certainly
+  truth = .true.
+  var1 = 86.
+  stringy = "what the hay!"
+  certainly = (3.14,-4.13)
+  if (c_associated(val, c_loc(val))) then
+    stop 1
+  endif
+  if (c_associated(c_loc(val), val)) then
+    stop 2
+  endif
+  print *, c_associated(fptr, C_NULL_FUNPTR)
+  print *, c_associated(c_loc(val), C_NULL_PTR)
+  print *, c_associated(C_NULL_PTR, c_loc(val)) 
+  print *, c_associated(c_loc(val), 42) ! { dg-error "C_ASSOCIATED shall have the" }
+  print *, c_associated(c_loc(val), .42) ! { dg-error "C_ASSOCIATED shall have the" }
+  print *, c_associated(c_loc(val), truth) ! { dg-error "C_ASSOCIATED shall have the" }
+  print *, c_associated(c_loc(val), .false.) ! { dg-error "C_ASSOCIATED shall have the" }
+  print *, c_associated(c_loc(val), var1) ! { dg-error "C_ASSOCIATED shall have the" }
+  print *, c_associated(c_loc(val), stringy) ! { dg-error "C_ASSOCIATED shall have the" }
+  print *, c_associated(c_loc(val), certainly) ! { dg-error "C_ASSOCIATED shall have the" }
+  print *, c_associated(42) ! { dg-error "C_ASSOCIATED shall have the" }
+  print *, c_associated(.42) ! { dg-error "C_ASSOCIATED shall have the" }
+  print *, c_associated(truth) ! { dg-error "C_ASSOCIATED shall have the" }
+  print *, c_associated(.false.) ! { dg-error "C_ASSOCIATED shall have the" }
+  print *, c_associated(var1) ! { dg-error "C_ASSOCIATED shall have the" }
+  print *, c_associated(stringy) ! { dg-error "C_ASSOCIATED shall have the" }
+  print *, c_associated(certainly) ! { dg-error "C_ASSOCIATED shall have the" }
+  print *, c_associated(.42) ! { dg-error "C_ASSOCIATED shall have the" }
+  print *, c_associated(val, testit(val)) ! { dg-error "C_ASSOCIATED shall have the" }
+  print *, c_associated(testit(val), val) ! { dg-error "C_ASSOCIATED shall have the" }
+  print *, c_associated(testit(val)) ! { dg-error "C_ASSOCIATED shall have the" }
+  print *, c_associated(c_loc(val), C_NULL_FUNPTR) ! { dg-error "C_ASSOCIATED shall have the" }
+  print *, c_associated(C_NULL_FUNPTR, c_loc(val)) ! { dg-error "C_ASSOCIATED shall have the" }
+contains
+
+  function testit (avalue) result(res)
+    type(c_ptr) :: avalue
+    type(mytype) :: res
+    res%myint = 42
+  end function
+
+end program tests_gtk_sup

diff --git a/gcc/testsuite/gfortran.dg/pr120049_a.f90 b/gcc/testsuite/gfortran.dg/pr120049_a.f90
index c404a4dedd9aa791ae405d1f330d632288b3d94a..7095314fe0e6354c412381ae51667477b5ba48e3 100644 (file)
--- a/gcc/testsuite/gfortran.dg/pr120049_a.f90
+++ b/gcc/testsuite/gfortran.dg/pr120049_a.f90
@@ -1,5 +1,8 @@
-! { dg-do preprocess }
-! { dg-additional-options "-cpp" }
+! Compiled with pr120049_b.f90
+! { dg-options -O0 }
+! { dg-do run }
+! { dg-compile-aux-modules "pr120049_b.f90" }
+! { dg-additional-sources pr120049_b.f90 }
 !
 ! Test the fix for PR86248
 program tests_gtk_sup

diff --git a/gcc/testsuite/gfortran.dg/pr120049_b.f90 b/gcc/testsuite/gfortran.dg/pr120049_b.f90
index 127db984077d812f69b920326e75843dd8ba947d..28a2783abbd9e01ccf9af4b287e5bde3ef5e5243 100644 (file)
--- a/gcc/testsuite/gfortran.dg/pr120049_b.f90
+++ b/gcc/testsuite/gfortran.dg/pr120049_b.f90
@@ -1,5 +1,3 @@
-! { dg-do  run }
-! { dg-additional-sources pr120049_a.f90 }
 !
 ! Module for pr120049.f90
 !