Re: [PATCH] Fortran: fixes for procedures with ALLOCATABLE,INTENT(OUT) arguments [PR92178]

[Mikael Morin <morin-mikael@orange.fr>]

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

Hello,

Le 07/07/2023 à 20:23, Harald Anlauf a écrit :
> Hi Mikael,
> 
> Am 07.07.23 um 14:21 schrieb Mikael Morin:
>> I'm attaching what I have (lightly) tested so far, which doesn't work.
>> It seems gfc_conv_class_to_class reevaluates part of the original
>> expression, which is not correct after deallocation.
> 
> this looks much more elegant than my attempt that passed an additional
> argument to gfc_conv_class_to_class, to achieve what your patch does.
> 
>> Will have a look again tonight.
> 
> Great.
> 
> Harald
> 

here is what I'm finally coming to.  This patch fixes my example, but is 
otherwise untested.
The patch has grown enough that I'm tempted to fix my example 
separately, in its own commit.

Mikael

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

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index e7c51bae052..1c2af55d436 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -3271,6 +3271,7 @@ gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
   gfc_add_block_to_block (block, &se.pre);
   info->descriptor = se.expr;
   ss_info->string_length = se.string_length;
+  ss_info->class_container = se.class_container;
 
   if (base)
     {
@@ -7687,6 +7688,8 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
 	  else if (deferred_array_component)
 	    se->string_length = ss_info->string_length;
 
+	  se->class_container = ss_info->class_container;
+
 	  gfc_free_ss_chain (ss);
 	  return;
 	}
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index ebef1a36577..01386bceaeb 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -529,24 +529,10 @@ gfc_find_and_cut_at_last_class_ref (gfc_expr *e, bool is_mold,
 }
 
 
-/* Reset the vptr to the declared type, e.g. after deallocation.  */
-
-void
-gfc_reset_vptr (stmtblock_t *block, gfc_expr *e)
+static void
+reset_vptr (stmtblock_t *block, gfc_expr *e, tree class_expr)
 {
-  gfc_symbol *vtab;
-  tree vptr;
-  tree vtable;
-  gfc_se se;
-
-  /* Evaluate the expression and obtain the vptr from it.  */
-  gfc_init_se (&se, NULL);
-  if (e->rank)
-    gfc_conv_expr_descriptor (&se, e);
-  else
-    gfc_conv_expr (&se, e);
-  gfc_add_block_to_block (block, &se.pre);
-  vptr = gfc_get_vptr_from_expr (se.expr);
+  tree vptr = gfc_get_vptr_from_expr (class_expr);
 
   /* If a vptr is not found, we can do nothing more.  */
   if (vptr == NULL_TREE)
@@ -556,6 +542,9 @@ gfc_reset_vptr (stmtblock_t *block, gfc_expr *e)
     gfc_add_modify (block, vptr, build_int_cst (TREE_TYPE (vptr), 0));
   else
     {
+      gfc_symbol *vtab;
+      tree vtable;
+
       /* Return the vptr to the address of the declared type.  */
       vtab = gfc_find_derived_vtab (e->ts.u.derived);
       vtable = vtab->backend_decl;
@@ -568,6 +557,24 @@ gfc_reset_vptr (stmtblock_t *block, gfc_expr *e)
 }
 
 
+/* Reset the vptr to the declared type, e.g. after deallocation.  */
+
+void
+gfc_reset_vptr (stmtblock_t *block, gfc_expr *e)
+{
+  gfc_se se;
+
+  /* Evaluate the expression and obtain the vptr from it.  */
+  gfc_init_se (&se, NULL);
+  if (e->rank)
+    gfc_conv_expr_descriptor (&se, e);
+  else
+    gfc_conv_expr (&se, e);
+  gfc_add_block_to_block (block, &se.pre);
+  reset_vptr (block, e, se.expr);
+}
+
+
 /* Reset the len for unlimited polymorphic objects.  */
 
 void
@@ -1266,6 +1273,8 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
 
       slen = build_zero_cst (size_type_node);
     }
+  else if (parmse->class_container != NULL_TREE)
+    tmp = parmse->class_container;
   else
     {
       /* Remove everything after the last class reference, convert the
@@ -3078,6 +3087,11 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
 	  return;
 	}
 
+      if (sym->ts.type == BT_CLASS
+	  && sym->attr.class_ok
+	  && sym->ts.u.derived->attr.is_class)
+	se->class_container = se->expr;
+
       /* Dereference the expression, where needed.  */
       se->expr = gfc_maybe_dereference_var (sym, se->expr, se->descriptor_only,
 					    is_classarray);
@@ -3135,6 +3149,15 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
 	    conv_parent_component_references (se, ref);
 
 	  gfc_conv_component_ref (se, ref);
+
+	  if (ref->u.c.component->ts.type == BT_CLASS
+	      && ref->u.c.component->attr.class_ok
+	      && ref->u.c.component->ts.u.derived->attr.is_class)
+	    se->class_container = se->expr;
+	  else if (!(ref->u.c.sym->attr.flavor == FL_DERIVED
+		     && ref->u.c.sym->attr.is_class))
+	    se->class_container = NULL_TREE;
+		
 	  if (!ref->next && ref->u.c.sym->attr.codimension
 	      && se->want_pointer && se->descriptor_only)
 	    return;
@@ -6784,6 +6807,21 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		  stmtblock_t block;
 		  tree ptr;
 
+		  /* In case the data reference to deallocate is dependent on
+		     its own content, save the resulting pointer to a variable
+		     and only use that variable from now on, before the
+		     expression becomes invalid.  */
+		  tree t = gfc_build_addr_expr (NULL_TREE, parmse.expr);
+		  t = gfc_evaluate_now (t, &parmse.pre);
+		  parmse.expr = build_fold_indirect_ref_loc (input_location, t);
+
+		  if (parmse.class_container != NULL_TREE)
+		    {
+		      t = gfc_build_addr_expr (NULL_TREE, parmse.class_container);
+		      t = gfc_evaluate_now (t, &parmse.pre);
+		      parmse.class_container = build_fold_indirect_ref_loc (input_location, t);
+		    }
+
 		  gfc_init_block  (&block);
 		  ptr = parmse.expr;
 		  ptr = gfc_class_data_get (ptr);
@@ -6797,7 +6835,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 					 void_type_node, ptr,
 					 null_pointer_node);
 		  gfc_add_expr_to_block (&block, tmp);
-		  gfc_reset_vptr (&block, e);
+		  if (parmse.class_container == NULL_TREE)
+		    gfc_reset_vptr (&block, e);
+		  else
+		    reset_vptr (&block, e, parmse.class_container);
 
 		  if (fsym->attr.optional
 		      && e->expr_type == EXPR_VARIABLE
@@ -6819,9 +6860,13 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		  defer_to_dealloc_blk = true;
 		}
 
+	      gfc_se class_se = parmse;
+	      gfc_init_block (&class_se.pre);
+	      gfc_init_block (&class_se.post);
+
 	      /* The conversion does not repackage the reference to a class
 	         array - _data descriptor.  */
-	      gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
+	      gfc_conv_class_to_class (&class_se, e, fsym->ts, false,
 				     fsym->attr.intent != INTENT_IN
 				     && (CLASS_DATA (fsym)->attr.class_pointer
 					 || CLASS_DATA (fsym)->attr.allocatable),
@@ -6831,9 +6876,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 				     CLASS_DATA (fsym)->attr.class_pointer
 				     || CLASS_DATA (fsym)->attr.allocatable);
 
-	      /* Defer repackaging after deallocation.  */
-	      if (defer_to_dealloc_blk)
-		gfc_add_block_to_block (&dealloc_blk, &parmse.pre);
+	      parmse.expr = class_se.expr;
+	      stmtblock_t *class_pre_block = defer_to_dealloc_blk ? &dealloc_blk : &parmse.pre;
+	      gfc_add_block_to_block (class_pre_block, &class_se.pre);
+	      gfc_add_block_to_block (&parmse.post, &class_se.post);
 	    }
 	  else
 	    {
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 0c8d004736d..9254de733de 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -57,6 +57,10 @@ typedef struct gfc_se
      here.  */
   tree class_vptr;
 
+  /* When expr is a reference to class subobject, store the class object
+     here.  */
+  tree class_container;
+
   /* Whether expr is a reference to an unlimited polymorphic object.  */
   unsigned unlimited_polymorphic:1;
 
@@ -263,6 +267,7 @@ typedef struct gfc_ss_info
   gfc_ss_type type;
   gfc_expr *expr;
   tree string_length;
+  tree class_container;
 
   union
   {