[OG12][committed] Fortran: Add attr.class_ok check for generate_callback_wrapper

[OG12][committed] Fortran: Add attr.class_ok check for generate_callback_wrapper

[Tobias Burnus]

[-- Attachment #1: Type: text/plain, Size: 1580 bytes --]

On OG12, the OpenMP deep-mapping support added a callback procedure to the vtable.
That one did not handle error recovery well (ICE when a CLASS component as not (class_)ok.

The attached patch has been committed as https://gcc.gnu.org/g:9c18db65914a751e4a1d9330ccc1659fe5ef270d
and applies only to OG12 (= git branch devel/omp/gcc-12) as mainline does not have this
code (yet).

* * *

The plan is to upstream the deep-mapping support, i.e. mapping of allocatable components.
The current OG12 implementation handles both mapping the declared type and the dynamic type,
the latter requires the wrapper, generated by generate_callback_wrapper.

I plan to upstream first the static part - and only then think about the wrapper. I think
the wrapper could be useful for coarrays as well - namely, for the user-defined reduction,
but I have not fully thought about it. It would break the ABI as the vtable gets another
entry before the type-bound procedures, which is why I am a bit hesitant; it it gets merged,
we it would be the opportunity to change some other things as well - like: generating the
CLASS functions/vtable only when used. (→ weak symbols to permit it in multiple translation
units; storing the fact that it has been generated in the module.)
But that's offtopic.

Tobias
-----------------
Siemens Electronic Design Automation GmbH; Anschrift: Arnulfstraße 201, 80634 München; Gesellschaft mit beschränkter Haftung; Geschäftsführer: Thomas Heurung, Frank Thürauf; Sitz der Gesellschaft: München; Registergericht München, HRB 106955

[-- Attachment #2: committed.diff --]
[-- Type: text/x-patch, Size: 2554 bytes --]

commit 9c18db65914a751e4a1d9330ccc1659fe5ef270d
Author: Tobias Burnus <tobias@codesourcery.com>
Date:   Thu Mar 23 14:29:00 2023 +0100

    Fortran: Add attr.class_ok check for generate_callback_wrapper
    
    Proper variables/components of type BT_CLASS have 'class_ok' set; check
    for that to avoid an ICE on invalid code for gfortran.dg/pr108434.f90.
    
    gcc/fortran/
            * class.cc (generate_callback_wrapper): Add attr.class_ok check.
            * resolve.cc (resolve_fl_derived): Likewise.

diff --git a/gcc/fortran/ChangeLog.omp b/gcc/fortran/ChangeLog.omp
index 663102d9329..f7d1f91f178 100644
--- a/gcc/fortran/ChangeLog.omp
+++ b/gcc/fortran/ChangeLog.omp
@@ -1,3 +1,8 @@
+2023-03-23  Tobias Burnus  <tobias@codesourcery.com>
+
+	* class.cc (generate_callback_wrapper): Add attr.class_ok check.
+	* resolve.cc (resolve_fl_derived): Likewise.
+
 2023-03-23  Tobias Burnus  <tobias@codesourcery.com>
 
 	* trans-openmp.cc (gfc_trans_omp_clauses): Fix unmapping of
diff --git a/gcc/fortran/class.cc b/gcc/fortran/class.cc
index 35dc35d2ee6..7ab6923523f 100644
--- a/gcc/fortran/class.cc
+++ b/gcc/fortran/class.cc
@@ -2550,6 +2550,9 @@ generate_callback_wrapper (gfc_symbol *vtab, gfc_symbol *derived,
 	 cb (token, comp->var(.data), size, 0, var's cb fn);  */
   for (gfc_component *comp = derived->components; comp; comp = comp->next)
     {
+      if (__builtin_expect (comp->ts.type == BT_CLASS
+			    && !comp->attr.class_ok, 0))
+	continue;
       bool pointer = (comp->ts.type == BT_CLASS
 		      ? CLASS_DATA (comp)->attr.pointer : comp->attr.pointer);
       bool proc_ptr = comp->attr.proc_pointer;
@@ -2590,7 +2593,7 @@ generate_callback_wrapper (gfc_symbol *vtab, gfc_symbol *derived,
 	  size->where = gfc_current_locus;
 	}
 
-      if (!proc_ptr && comp->ts.type == BT_CLASS)
+      if (!proc_ptr && comp->ts.type == BT_CLASS && comp->attr.class_ok)
 	{
 	  gfc_add_data_component (expr);
 	  if (comp->attr.dimension)
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index aaeaf396b91..15db1252366 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -15173,7 +15173,8 @@ resolve_fl_derived (gfc_symbol *sym)
   gfc_component *c = (sym->attr.is_class
 		      ? CLASS_DATA (sym->components) : sym->components);
   for ( ; c; c = c->next)
-    if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+    if ((c->ts.type == BT_DERIVED
+	|| (c->ts.type == BT_CLASS && c->attr.class_ok))
 	&& !c->ts.u.derived->resolve_symbol_called)
       {
 	if (c->ts.u.derived->components == NULL