From: Harald Anlauf <anlauf@gmx.de>
Date: Tue, 20 Dec 2022 20:17:08 +0000 (+0100)
Subject: Fortran: a C interoperable function cannot have the CLASS attribute [PR95375]
X-Git-Tag: basepoints/gcc-14~2398
X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=aed5584ff6891560dc567e54517b9722dadc503e;p=thirdparty%2Fgcc.git

Fortran: a C interoperable function cannot have the CLASS attribute [PR95375]

gcc/fortran/ChangeLog:

	PR fortran/95375
	* decl.cc (verify_bind_c_sym): Extend interoperability check to
	CLASS variables.

gcc/testsuite/ChangeLog:

	PR fortran/95375
	* gfortran.dg/bind_c_procs_4.f90: New test.
---

diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index 1562dc22bc6e..e593518a77ee 100644
--- a/gcc/fortran/decl.cc
+++ b/gcc/fortran/decl.cc
@@ -5998,10 +5998,14 @@ verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts,
 	    }
 	  else
 	    {
-              if (tmp_sym->ts.type == BT_DERIVED || ts->type == BT_DERIVED)
-                gfc_error ("Type declaration %qs at %L is not C "
-                           "interoperable but it is BIND(C)",
-                           tmp_sym->name, &(tmp_sym->declared_at));
+	      if (tmp_sym->ts.type == BT_DERIVED || ts->type == BT_DERIVED
+		  || tmp_sym->ts.type == BT_CLASS || ts->type == BT_CLASS)
+		{
+		  gfc_error ("Type declaration %qs at %L is not C "
+			     "interoperable but it is BIND(C)",
+			     tmp_sym->name, &(tmp_sym->declared_at));
+		  retval = false;
+		}
               else if (warn_c_binding_type)
                 gfc_warning (OPT_Wc_binding_type, "Variable %qs at %L "
                              "may not be a C interoperable "
diff --git a/gcc/testsuite/gfortran.dg/bind_c_procs_4.f90 b/gcc/testsuite/gfortran.dg/bind_c_procs_4.f90
new file mode 100644
index 000000000000..407d8bb9afc8
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/bind_c_procs_4.f90
@@ -0,0 +1,17 @@
+! { dg-do compile }
+! PR fortran/95375 - ICE in add_use_op
+! Contributed by G.Steinmetz
+
+function f() result(n) bind(c)      ! { dg-error "not C interoperable" }
+  class(*), allocatable :: n
+end
+program p
+  interface
+     function f() result(n) bind(c)
+       integer :: n
+     end
+  end interface
+  if ( f() /= 0 ) stop
+end
+
+! { dg-prune-output "Type mismatch" }