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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@197281 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 7284c2cf3d2d6477698b0e1e8efb3b8c68b01cbc..92a5f00c0a29597fc765393a68f6ccce63f547e7 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,12 @@
+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.

diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index d8e7b6ded7a4e4d0e01133613803c473ea4b80e8..42c7fa6a5dbaf36d69c11d59e6b0ae18884714ca 100644 (file)
--- 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 2a51d10ffb654c0f618a1a46a3bd2d69b37b8a84..64df29656844f5103edee557f345afe3be995ee9 100644 (file)
--- 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 d7bdf268a37a2c92e7d5ce13584c081b244e638f..8211573e1b396f3caf296cfe0946b2984df0d0b0 100644 (file)
--- 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;