2013-03-31 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.

From-SVN: r197281

gcc/fortran/ChangeLog

+2013-03-31  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.
+
 2013-03-30  Thomas Koenig  <tkoenig@gcc.gnu.org>
 
 	* trans-expr.c (build_memcmp_call):  New function.

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)

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 ();
-    }
   return (gfc_isym_id) 0;
 }
 

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;