Re: [Patch, Fortran, 4.9] Minor FINAL preparation patch

[Tobias Burnus <burnus at net-b dot de>]

** PING **

And an updated patch. Changes:
- Updated isym handling due to the ISO_C_BINDING patch
- Fixed some bugs in the generated code for finalizing arrays (mainly 
missing gfc_copy_expr)

Build and tested on x86-64-gnu-linux.
OK for the trunk?

Tobias

PS: Regarding true FINAL support: The current draft patch* mostly works, 
except for: Polymorphic arrays aren't deallocated at the end of the 
scope (old bug), allocatables are wrongly finalized at the end of the 
main program, and for allocatable,intent(out), no finalization is done. 
After those issues are fixed and some code cleanup has be done, the 
patch should be ready.
*https://userpage.physik.fu-berlin.de/~tburnus/final/


On March 13, 2013 11:26 a.m., Tobias Burnus wrote:
> Dear all,
>
> this small patch fixes some small issues with the current FINAL 
> implementation, which is still disabled. Namely:
>
> (a) class.c: TRANSFER has an optional size= argument; if one doesn't 
> has an actual-argument (which can be expr == NULL), it segfaults.
> (b) class.c: SIZE needs to return an index-size-kind integer not a 
> default-kind integer (tree checking error, but potentially also wrong 
> code)
> (c) trans.c: Scalar coarrays (with -fcoarray=lib) were mishandled - 
> they also use an array descriptor
>
> Build and regtested on x86-64-gnu-linux.
> OK?
>
> (I target 4.9 with this patch; in principle, it could also be applied 
> to 4.8: The code is not used, yet, and thus it shouldn't harm on 4.8 
> but there is also no benefit.)
>
>
> The full patch, which enables finalization and regtests is available 
> at: https://userpage.physik.fu-berlin.de/~tburnus/final/ â The patch 
> still requires some clean up. In addition, finalization (with a user 
> FINAL subroutine) is mishandled for allocatable INTENT(OUT) as 
> gfortran handles it (at least partially) in the caller (trans-expr.c's 
> gfc_conv_procedure_call) and not in the callee (trans-decl.c). That 
> will lead to not finalizing and segfaults at run time. There are more 
> issues, but for an experimental implementation, fixing this issue 
> should be enough. (Note: the .mod version should be bumped to force 
> recompilation, which is required due to the ABI change of the vtable.)
>
> Tobias
2013-03-27  Tobias Burnus  <burnus@net-b.de>

	* class.c (finalization_scalarizer, finalizer_insert_packed_call,
	generate_finalization_wrapper): Avoid segfault with absent SIZE=
	argment to TRANSFER and use correct result kind for SIZE.
	* intrinsic.c (gfc_isym_id_by_intmod): Also handle ids of
	nonmodules.
	* trans.c (gfc_build_final_call): Handle coarrays.

/fortran/class.c b/gcc/fortran/class.c
index d8e7b6d..564b4c7 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -956,8 +956,10 @@ finalization_scalarizer (gfc_symbol *array, gfc_symbol *ptr,
   block->resolved_sym = block->symtree->n.sym;
   block->resolved_sym->attr.flavor = FL_PROCEDURE;
   block->resolved_sym->attr.intrinsic = 1;
+  block->resolved_sym->attr.subroutine = 1;
   block->resolved_sym->from_intmod = INTMOD_ISO_C_BINDING;
   block->resolved_sym->intmod_sym_id = ISOCBINDING_F_POINTER;
+  block->resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_C_F_POINTER);
   gfc_commit_symbol (block->resolved_sym);
 
   /* C_F_POINTER's first argument: TRANSFER ( <addr>, c_intptr_t).  */
@@ -965,6 +967,7 @@ finalization_scalarizer (gfc_symbol *array, gfc_symbol *ptr,
   block->ext.actual->next = gfc_get_actual_arglist ();
   block->ext.actual->next->expr = gfc_get_int_expr (gfc_index_integer_kind,
 						    NULL, 0);
+  block->ext.actual->next->next = gfc_get_actual_arglist (); /* SIZE. */
 
   /* The <addr> part: TRANSFER (C_LOC (array), c_intptr_t).  */
 
@@ -976,7 +979,7 @@ finalization_scalarizer (gfc_symbol *array, gfc_symbol *ptr,
   expr->symtree->n.sym->intmod_sym_id = ISOCBINDING_LOC;
   expr->symtree->n.sym->attr.intrinsic = 1;
   expr->symtree->n.sym->from_intmod = INTMOD_ISO_C_BINDING;
-  expr->value.function.esym = expr->symtree->n.sym;
+  expr->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_C_LOC);
   expr->value.function.actual = gfc_get_actual_arglist ();
   expr->value.function.actual->expr
 	    = gfc_lval_expr_from_sym (array);
@@ -987,9 +990,9 @@ finalization_scalarizer (gfc_symbol *array, gfc_symbol *ptr,
 
   /* TRANSFER.  */
   expr2 = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_TRANSFER, "transfer",
-				    gfc_current_locus, 2, expr,
+				    gfc_current_locus, 3, expr,
 				    gfc_get_int_expr (gfc_index_integer_kind,
-						      NULL, 0));
+						      NULL, 0), NULL);
   expr2->ts.type = BT_INTEGER;
   expr2->ts.kind = gfc_index_integer_kind;
 
@@ -1200,9 +1203,9 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
   size_expr->value.op.op1
 	= gfc_build_intrinsic_call (sub_ns, GFC_ISYM_STORAGE_SIZE,
 				    "storage_size", gfc_current_locus, 2,
-				    gfc_lval_expr_from_sym (array));
+				    gfc_lval_expr_from_sym (array),
 				    gfc_get_int_expr (gfc_index_integer_kind,
-						      NULL, 0);
+						      NULL, 0));
 
   /* NUMERIC_STORAGE_SIZE.  */
   size_expr->value.op.op2 = gfc_get_int_expr (gfc_index_integer_kind, NULL,
@@ -1215,7 +1218,6 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
 			|| is_contiguous)
 		   || 0 == size_expr.  */
   block->expr1 = gfc_get_expr ();
-  block->expr1->expr_type = EXPR_FUNCTION;
   block->expr1->ts.type = BT_LOGICAL;
   block->expr1->ts.kind = gfc_default_logical_kind;
   block->expr1->expr_type = EXPR_OP;
@@ -1234,8 +1236,9 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
 	= gfc_lval_expr_from_sym (byte_stride);
   expr->value.op.op2 = size_expr;
 
-  /* If strides aren't allowd (not assumed shape or CONTIGUOUS),
+  /* If strides aren't allowed (not assumed shape or CONTIGUOUS),
      add is_contiguous check.  */
+
   if (fini->proc_tree->n.sym->formal->sym->as->type != AS_ASSUMED_SHAPE
       || fini->proc_tree->n.sym->formal->sym->attr.contiguous)
     {
@@ -1315,7 +1318,7 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
       gfc_expr *shape_expr;
       tmp_array->as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind,
 						  NULL, 1);
-      /* SIZE (array, dim=i+1, kind=default_kind).  */
+      /* SIZE (array, dim=i+1, kind=gfc_index_integer_kind).  */
       shape_expr
 	= gfc_build_intrinsic_call (sub_ns, GFC_ISYM_SIZE, "size",
 				    gfc_current_locus, 3,
@@ -1323,7 +1326,9 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
 				    gfc_get_int_expr (gfc_default_integer_kind,
 						      NULL, i+1),
 				    gfc_get_int_expr (gfc_default_integer_kind,
-						      NULL, 0));
+						      NULL,
+						      gfc_index_integer_kind));
+      shape_expr->ts.kind = gfc_index_integer_kind;
       tmp_array->as->upper[i] = shape_expr;
     }
   gfc_set_sym_referenced (tmp_array);
@@ -1346,7 +1351,6 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
 
   /* Offset calculation for the new array: idx * size of type (in bytes).  */
   offset2 = gfc_get_expr ();
-  offset2 = block->ext.actual->expr;
   offset2->expr_type = EXPR_OP;
   offset2->value.op.op = INTRINSIC_TIMES;
   offset2->value.op.op1 = gfc_lval_expr_from_sym (idx);
@@ -1365,13 +1369,15 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
 					  sub_ns);
   block2 = block2->next;
   block2->next = finalization_scalarizer (tmp_array, ptr2, offset2, sub_ns);
+  block2 = block2->next;
 
   /* ptr2 = ptr.  */
   block2->next = XCNEW (gfc_code);
-  block2->next->op = EXEC_ASSIGN;
-  block2->next->loc = gfc_current_locus;
-  block2->next->expr1 = gfc_lval_expr_from_sym (ptr2);
-  block2->next->expr2 = gfc_lval_expr_from_sym (ptr);
+  block2 = block2->next;
+  block2->op = EXEC_ASSIGN;
+  block2->loc = gfc_current_locus;
+  block2->expr1 = gfc_lval_expr_from_sym (ptr2);
+  block2->expr2 = gfc_lval_expr_from_sym (ptr);
 
   /* Call now the user's final subroutine. */
   block->next  = XCNEW (gfc_code);
@@ -1414,7 +1420,8 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
 					  gfc_lval_expr_from_sym (offset),
 					  sub_ns);
   block2 = block2->next;
-  block2->next = finalization_scalarizer (tmp_array, ptr2, offset2, sub_ns);
+  block2->next = finalization_scalarizer (tmp_array, ptr2,
+					  gfc_copy_expr (offset2), sub_ns);
   block2 = block2->next;
 
   /* ptr = ptr2.  */
@@ -1799,7 +1806,9 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
 				    gfc_lval_expr_from_sym (array),
 				    gfc_lval_expr_from_sym (idx),
 				    gfc_get_int_expr (gfc_index_integer_kind,
-						      NULL, 0));
+						      NULL,
+						      gfc_index_integer_kind));
+  block->expr2->value.op.op2->ts.kind = gfc_index_integer_kind;
   block->expr2->ts = idx->ts;
 
   /* if (strides(idx) /= sizes(idx-1)) is_contiguous = .false.  */
@@ -1960,7 +1969,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
 	    block->ext.block.case_list->low
 		= gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
 	  block->ext.block.case_list->high
-		= block->ext.block.case_list->low;
+		= gfc_copy_expr (block->ext.block.case_list->low);
 
 	  /* CALL fini_rank (array) - possibly with packing.  */
           if (fini->proc_tree->n.sym->formal->sym->attr.dimension)
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index 358c33e..e451c36 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -813,7 +813,9 @@ find_sym (gfc_intrinsic_sym *start, int n, const char *name)
 gfc_isym_id
 gfc_isym_id_by_intmod (intmod_id from_intmod, int intmod_sym_id)
 {
-  if (from_intmod == INTMOD_ISO_C_BINDING)
+  if (from_intmod == INTMOD_NONE)
+    return (gfc_isym_id) intmod_sym_id;
+  else if (from_intmod == INTMOD_ISO_C_BINDING)
     return (gfc_isym_id) c_interop_kinds_table[intmod_sym_id].value;
   else if (from_intmod == INTMOD_ISO_FORTRAN_ENV)
     switch (intmod_sym_id)
@@ -829,9 +831,7 @@ gfc_isym_id_by_intmod (intmod_id from_intmod, int intmod_sym_id)
 	gcc_unreachable ();
       }
   else
-    {
-      gcc_unreachable ();
-    }
+    gcc_unreachable ();
   return (gfc_isym_id) 0;
 }
 
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index d7bdf26..0644d6f 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -1031,6 +1031,7 @@ gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var,
   stmtblock_t block;
   gfc_se se;
   tree final_fndecl, array, size, tmp;
+  symbol_attribute attr;
 
   gcc_assert (final_wrapper->expr_type == EXPR_VARIABLE);
   gcc_assert (var);
@@ -1041,6 +1042,8 @@ gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var,
   if (POINTER_TYPE_P (TREE_TYPE (final_fndecl)))
     final_fndecl = build_fold_indirect_ref_loc (input_location, final_fndecl);
 
+  attr = gfc_expr_attr (var);
+
   if (ts.type == BT_DERIVED)
     {
       tree elem_size;
@@ -1052,8 +1055,12 @@ gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var,
 
       gfc_init_se (&se, NULL);
       se.want_pointer = 1;
-      if (var->rank || gfc_expr_attr (var).dimension)
+      if (var->rank || attr.dimension
+	  || (attr.codimension && attr.allocatable
+	      && gfc_option.coarray == GFC_FCOARRAY_LIB))
 	{
+	  if (var->rank == 0)
+	    se.want_coarray = 1;
 	  se.descriptor_only = 1;
 	  gfc_conv_expr_descriptor (&se, var);
 	  array = se.expr;
@@ -1062,7 +1069,6 @@ gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var,
 	}
       else
 	{
-	  symbol_attribute attr;
 	  gfc_clear_attr (&attr);
 	  gfc_conv_expr (&se, var);
 	  gcc_assert (se.pre.head == NULL_TREE && se.post.head == NULL_TREE);
@@ -1087,22 +1093,25 @@ gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var,
       size = se.expr;
 
       array_expr = gfc_copy_expr (var);
-      gfc_add_data_component (array_expr);
       gfc_init_se (&se, NULL);
       se.want_pointer = 1;
-      if (array_expr->rank || gfc_expr_attr (array_expr).dimension)
+      if (array_expr->rank || attr.dimension
+	  || (attr.codimension && attr.allocatable
+	      && gfc_option.coarray == GFC_FCOARRAY_LIB))
 	{
+	  gfc_add_class_array_ref (array_expr);
+	  if (array_expr->rank == 0)
+	    se.want_coarray = 1;
 	  se.descriptor_only = 1;
-	  gfc_conv_expr_descriptor (&se, var);
+	  gfc_conv_expr_descriptor (&se, array_expr);
 	  array = se.expr;
 	  if (! POINTER_TYPE_P (TREE_TYPE (array)))
 	    array = gfc_build_addr_expr (NULL, array);
 	}
       else
 	{
-	  symbol_attribute attr;
-
 	  gfc_clear_attr (&attr);
+	  gfc_add_data_component (array_expr);
 	  gfc_conv_expr (&se, array_expr);
 	  gcc_assert (se.pre.head == NULL_TREE && se.post.head == NULL_TREE);
 	  array = se.expr;