Polishing.

7 files changed, 69 insertions, 104 deletions

diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 2efc6ca7f75..e2d1311d1a5 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -4942,36 +4942,6 @@ gfc_get_corank (gfc_expr *e)
 }
 
 
-/* Return true, when e refs a component of derived type coarray.  */
-
-bool
-gfc_is_coarray_sub_component (gfc_expr *e)
-{
-  if (e->expr_type != EXPR_VARIABLE)
-    return false;
-
-  gfc_ref *ref = e->ref;
-  gfc_symbol *sym = e->symtree->n.sym;
-  /* Because the _data-ref needs to be in e, classes are treated correctly by
-     the loop below.  */
-  bool is_codim = sym->attr.codimension;
-
-  while (ref)
-    {
-      if (ref->type == REF_COMPONENT)
-	{
-	  if (!is_codim && ref->u.c.component->attr.codimension)
-	    is_codim = true;
-	  else if (is_codim && strcmp (ref->u.c.component->name, "_data") != 0)
-	    return true;
-	}
-      ref = ref->next;
-    }
-
-  return false;
-}
-
-
 /* Check whether the expression has an ultimate allocatable component.
    Being itself allocatable does not count.  */
 bool
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 7392c7e17c0..370b2a0e89c 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3139,7 +3139,6 @@ bool gfc_ref_this_image (gfc_ref *ref);
 bool gfc_is_coindexed (gfc_expr *);
 bool gfc_is_coarray (gfc_expr *);
 int gfc_get_corank (gfc_expr *);
-bool gfc_is_coarray_sub_component (gfc_expr *);
 bool gfc_has_ultimate_allocatable (gfc_expr *);
 bool gfc_has_ultimate_pointer (gfc_expr *);
 gfc_expr* gfc_find_stat_co (gfc_expr *);
@@ -3275,7 +3274,7 @@ const char *gfc_dt_upper_string (const char *);
 /* primary.c */
 symbol_attribute gfc_variable_attr (gfc_expr *, gfc_typespec *);
 symbol_attribute gfc_expr_attr (gfc_expr *);
-symbol_attribute gfc_caf_attr (gfc_expr *, bool in_allocate = false);
+symbol_attribute gfc_caf_attr (gfc_expr *, bool i = false, bool *r = NULL);
 match gfc_match_rvalue (gfc_expr **);
 match gfc_match_varspec (gfc_expr*, int, bool, bool);
 int gfc_check_digit (char, int);
diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index 50d7072b670..c287e4466be 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -2418,10 +2418,15 @@ gfc_expr_attr (gfc_expr *e)
    attribute is.  This routine is similar to gfc_variable_attr with
    parts of gfc_expr_attr, but focuses more on the needs of
    coarrays.  For coarrays a codimension attribute is kind of
-   "infectious" being propagated once set and never cleared.  */
+   "infectious" being propagated once set and never cleared.
+   The coarray_comp is only set, when the expression refs a coarray
+   component.  REFS_COMP is set when present to true only, when this EXPR
+   refs a (non-_data) component.  To check whether EXPR refs an allocatable
+   component in a derived type coarray *refs_comp needs to be set and
+   coarray_comp has to false.  */
 
 static symbol_attribute
-caf_variable_attr (gfc_expr *expr, bool in_allocate)
+caf_variable_attr (gfc_expr *expr, bool in_allocate, bool *refs_comp)
 {
   int dimension, codimension, pointer, allocatable, target, coarray_comp,
       alloc_comp;
@@ -2436,13 +2441,15 @@ caf_variable_attr (gfc_expr *expr, bool in_allocate)
   sym = expr->symtree->n.sym;
   gfc_clear_attr (&attr);
 
+  if (refs_comp)
+    *refs_comp = 0;
+
   if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
     {
       dimension = CLASS_DATA (sym)->attr.dimension;
       codimension = CLASS_DATA (sym)->attr.codimension;
       pointer = CLASS_DATA (sym)->attr.class_pointer;
       allocatable = CLASS_DATA (sym)->attr.allocatable;
-      coarray_comp = CLASS_DATA (sym)->attr.coarray_comp;
       alloc_comp = CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp;
     }
   else
@@ -2451,12 +2458,11 @@ caf_variable_attr (gfc_expr *expr, bool in_allocate)
       codimension = sym->attr.codimension;
       pointer = sym->attr.pointer;
       allocatable = sym->attr.allocatable;
-      coarray_comp = sym->attr.coarray_comp;
       alloc_comp = sym->ts.type == BT_DERIVED
 	  ? sym->ts.u.derived->attr.alloc_comp : 0;
     }
 
-  target = attr.target;
+  target = coarray_comp = 0;
   if (pointer || attr.proc_pointer)
     target = 1;
 
@@ -2494,19 +2500,26 @@ caf_variable_attr (gfc_expr *expr, bool in_allocate)
 
 	if (comp->ts.type == BT_CLASS)
 	  {
+	    /* Set coarray_comp only, when this component introduces the
+	       coarray.  */
+	    coarray_comp = !codimension && CLASS_DATA (comp)->attr.codimension;
 	    codimension |= CLASS_DATA (comp)->attr.codimension;
 	    pointer = CLASS_DATA (comp)->attr.class_pointer;
 	    allocatable = CLASS_DATA (comp)->attr.allocatable;
-	    coarray_comp |= CLASS_DATA (comp)->attr.coarray_comp;
 	  }
 	else
 	  {
+	    /* Set coarray_comp only, when this component introduces the
+	       coarray.  */
+	    coarray_comp = !codimension && comp->attr.codimension;
 	    codimension |= comp->attr.codimension;
 	    pointer = comp->attr.pointer;
 	    allocatable = comp->attr.allocatable;
-	    coarray_comp |= comp->attr.coarray_comp;
 	  }
 
+	if (refs_comp && strcmp (comp->name, "_data") != 0)
+	  *refs_comp = 1;
+
 	if (pointer || attr.proc_pointer)
 	  target = 1;
 
@@ -2531,14 +2544,14 @@ caf_variable_attr (gfc_expr *expr, bool in_allocate)
 
 
 symbol_attribute
-gfc_caf_attr (gfc_expr *e, bool in_allocate)
+gfc_caf_attr (gfc_expr *e, bool in_allocate, bool *refs_comp)
 {
   symbol_attribute attr;
 
   switch (e->expr_type)
     {
     case EXPR_VARIABLE:
-      attr = caf_variable_attr (e, in_allocate);
+      attr = caf_variable_attr (e, in_allocate, refs_comp);
       break;
 
     case EXPR_FUNCTION:
@@ -2557,7 +2570,7 @@ gfc_caf_attr (gfc_expr *e, bool in_allocate)
 	    }
 	}
       else if (e->symtree)
-	attr = caf_variable_attr (e, in_allocate);
+	attr = caf_variable_attr (e, in_allocate, refs_comp);
       else
 	gfc_clear_attr (&attr);
       break;
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 4ac36746a20..8051047526e 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -7968,8 +7968,8 @@ gfc_duplicate_allocatable_nocopy (tree dest, tree src, tree type, int rank)
 
 
 static tree
-duplicate_allocatable_coarray (tree dest, tree dest_tok, tree src, tree src_tok,
-			       tree type, int rank, int caf_mode)
+duplicate_allocatable_coarray (tree dest, tree dest_tok, tree src,
+			       tree type, int rank)
 {
   tree tmp;
   tree size;
@@ -7992,9 +7992,6 @@ duplicate_allocatable_coarray (tree dest, tree dest_tok, tree src, tree src_tok,
       gfc_init_se (&se, NULL);
       dummy_desc = gfc_conv_scalar_to_descriptor (&se, dest, attr);
       gfc_add_block_to_block (&globalblock, &se.pre);
-      //      if (str_sz != NULL_TREE)
-      //	size = str_sz;
-      //      else
       size = TYPE_SIZE_UNIT (TREE_TYPE (type));
 
       gfc_add_modify (&block, dest, fold_convert (type, null_pointer_node));
@@ -8006,22 +8003,16 @@ duplicate_allocatable_coarray (tree dest, tree dest_tok, tree src, tree src_tok,
 
       gfc_init_block (&block);
 
-//      if (!no_malloc)
-//	{
       gfc_allocate_using_caf_lib (&block, dummy_desc,
 				  fold_convert (size_type_node, size),
 				  gfc_build_addr_expr (NULL_TREE, dest_tok),
 				  NULL_TREE, NULL_TREE, NULL_TREE,
 				  GFC_CAF_COARRAY_ALLOC);
-//	}
 
-//      if (!no_memcpy)
-//	{
-	  tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
-	  tmp = build_call_expr_loc (input_location, tmp, 3, dest, src,
-				     fold_convert (size_type_node, size));
-	  gfc_add_expr_to_block (&block, tmp);
-//	}
+      tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
+      tmp = build_call_expr_loc (input_location, tmp, 3, dest, src,
+				 fold_convert (size_type_node, size));
+      gfc_add_expr_to_block (&block, tmp);
     }
   else
     {
@@ -8034,11 +8025,8 @@ duplicate_allocatable_coarray (tree dest, tree dest_tok, tree src, tree src_tok,
       else
 	nelems = integer_one_node;
 
-//      if (str_sz != NULL_TREE)
-//	tmp = fold_convert (gfc_array_index_type, str_sz);
-//      else
-	tmp = fold_convert (size_type_node,
-			    TYPE_SIZE_UNIT (gfc_get_element_type (type)));
+      tmp = fold_convert (size_type_node,
+			  TYPE_SIZE_UNIT (gfc_get_element_type (type)));
       size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
 			      fold_convert (size_type_node, nelems), tmp);
 
@@ -8051,33 +8039,24 @@ duplicate_allocatable_coarray (tree dest, tree dest_tok, tree src, tree src_tok,
       null_data = gfc_finish_block (&block);
 
       gfc_init_block (&block);
-//      if (!no_malloc)
-//	{
       gfc_allocate_using_caf_lib (&block, dest,
 				  fold_convert (size_type_node, size),
 				  gfc_build_addr_expr (NULL_TREE, dest_tok),
 				  NULL_TREE, NULL_TREE, NULL_TREE,
 				  GFC_CAF_COARRAY_ALLOC);
-//	}
 
-      /* We know the temporary and the value will be the same length,
-	 so can use memcpy.  */
-//      if (!no_memcpy)
-//	{
-	  tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
-	  tmp = build_call_expr_loc (input_location, tmp, 3,
-				     gfc_conv_descriptor_data_get (dest),
-				     gfc_conv_descriptor_data_get (src),
-				     fold_convert (size_type_node, size));
-	  gfc_add_expr_to_block (&block, tmp);
-//	}
+      tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
+      tmp = build_call_expr_loc (input_location, tmp, 3,
+				 gfc_conv_descriptor_data_get (dest),
+				 gfc_conv_descriptor_data_get (src),
+				 fold_convert (size_type_node, size));
+      gfc_add_expr_to_block (&block, tmp);
     }
 
-//  gfc_add_expr_to_block (&block, add_when_allocated);
   tmp = gfc_finish_block (&block);
 
   /* Null the destination if the source is null; otherwise do
-     the allocate and copy.  */
+     the register and copy.  */
   if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src)))
     null_cond = src;
   else
@@ -8331,10 +8310,6 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 	      tree is_allocated;
 	      tree ubound;
 	      tree cdesc;
-	      tree zero = gfc_index_zero_node;
-	      // TODO: DELETE: build_int_cst (gfc_array_index_type, 0);
-	      tree unity = gfc_index_one_node;
-	      // TODO: DELETE: build_int_cst (gfc_array_index_type, 1);
 	      tree data;
 	      stmtblock_t dealloc_block;
 
@@ -8356,8 +8331,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 		  ubound = build_int_cst (gfc_array_index_type, 1);
 		}
 
-	      cdesc = gfc_get_array_type_bounds (tmp, 1, 0,
-						 &unity, &ubound, 1,
+	      cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node,
+						 &ubound, 1,
 						 GFC_ARRAY_ALLOCATABLE, false);
 
 	      cdesc = gfc_create_var (cdesc, "cdesc");
@@ -8366,11 +8341,13 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 	      gfc_add_modify (&dealloc_block, gfc_conv_descriptor_dtype (cdesc),
 			      gfc_get_dtype_rank_type (1, tmp));
 	      gfc_conv_descriptor_lbound_set (&dealloc_block, cdesc,
-					      zero, unity);
+					      gfc_index_zero_node,
+					      gfc_index_one_node);
 	      gfc_conv_descriptor_stride_set (&dealloc_block, cdesc,
-					      zero, unity);
+					      gfc_index_zero_node,
+					      gfc_index_one_node);
 	      gfc_conv_descriptor_ubound_set (&dealloc_block, cdesc,
-					      zero, ubound);
+					      gfc_index_zero_node, ubound);
 
 	      if (c->attr.dimension)
 		data = gfc_conv_descriptor_data_get (comp);
@@ -8775,8 +8752,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 							  c->caf_token,
 							  NULL_TREE);
 		  tmp = duplicate_allocatable_coarray (dcmp, dst_tok, comp,
-						       NULL_TREE, ctype, rank,
-						       caf_mode);
+						       ctype, rank);
 		}
 	      else
 		tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank,
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 7d506877833..147872fe0ba 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -6423,17 +6423,19 @@ gfc_trans_deallocate (gfc_code *code)
 
       if (flag_coarray == GFC_FCOARRAY_LIB)
 	{
-	  symbol_attribute caf_attr = gfc_caf_attr (expr);
+	  bool comp_ref;
+	  symbol_attribute caf_attr = gfc_caf_attr (expr, false, &comp_ref);
 	  if (caf_attr.codimension)
 	    {
-	      bool ref_to_component = gfc_is_coarray_sub_component (al->expr);
 	      is_coarray = true;
-	      is_coarray_array = caf_attr.dimension || !ref_to_component;
+	      is_coarray_array = caf_attr.dimension || !comp_ref
+		  || caf_attr.coarray_comp;
 
 	      /* When the expression to deallocate is referencing a
 		 component, then only deallocate it, but do not deregister.  */
 	      caf_mode = GFC_STRUCTURE_CAF_MODE_IN_COARRAY |
-		  (ref_to_component ? GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY : 0);
+		  (comp_ref && !caf_attr.coarray_comp
+		   ? GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY : 0);
 	    }
 	}
       else if (flag_coarray == GFC_FCOARRAY_SINGLE)
@@ -6443,7 +6445,8 @@ gfc_trans_deallocate (gfc_code *code)
 	{
 	  gfc_ref *ref;
 
-	  if (gfc_bt_struct (expr->ts.type) && expr->ts.u.derived->attr.alloc_comp
+	  if (gfc_bt_struct (expr->ts.type)
+	      && expr->ts.u.derived->attr.alloc_comp
 	      && !gfc_is_finalizable (expr->ts.u.derived, NULL))
 	    {
 	      gfc_ref *last = NULL;
@@ -6457,8 +6460,8 @@ gfc_trans_deallocate (gfc_code *code)
 	      if (!(last && last->u.c.component->attr.pointer)
 		    && !(!last && expr->symtree->n.sym->attr.pointer))
 		{
-		  if (is_coarray && (!last
-				     || !last->u.c.component->attr.dimension))
+		  if (is_coarray && expr->rank == 0
+		      && (!last || !last->u.c.component->attr.dimension))
 		    {
 		      /* Add the ref to the data member only, when this is not
 			 a regular array or deallocate_alloc_comp will try to
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index 6067cf07d8c..b441e1a2b64 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -783,7 +783,7 @@ gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size,
   tree tmp, null_mem, alloc, error;
   tree type = TREE_TYPE (mem);
   symbol_attribute caf_attr;
-  bool need_assign = false;
+  bool need_assign = false, refs_comp = false;
   gfc_coarray_regtype caf_alloc_type = GFC_CAF_COARRAY_ALLOC;
 
   size = fold_convert (size_type_node, size);
@@ -797,7 +797,7 @@ gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size,
   gfc_start_block (&alloc_block);
 
   if (flag_coarray == GFC_FCOARRAY_LIB)
-    caf_attr = gfc_caf_attr (expr, true);
+    caf_attr = gfc_caf_attr (expr, true, &refs_comp);
 
   if (flag_coarray == GFC_FCOARRAY_LIB
       && (corank > 0 || caf_attr.codimension))
@@ -820,7 +820,9 @@ gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size,
 	  compute_special_caf_types_size = true;
 	  caf_alloc_type = GFC_CAF_EVENT_ALLOC;
 	}
-      else if (gfc_is_coarray_sub_component (expr))
+      else if (!caf_attr.coarray_comp && refs_comp)
+	/* Only allocatable components in a derived type coarray can be
+	   allocate only.  */
 	caf_alloc_type = GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY;
 
       gfc_init_se (&se, NULL);
@@ -1295,7 +1297,9 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
       STRIP_NOPS (pointer);
       if (coarray_dealloc_mode == GFC_CAF_COARRAY_ANALYZE)
 	{
-	  if (expr && gfc_is_coarray_sub_component (expr))
+	  bool comp_ref;
+	  if (expr && !gfc_caf_attr(expr, false, &comp_ref).coarray_comp
+	      && comp_ref)
 	    caf_dereg_type = GFC_CAF_COARRAY_DEALLOCATE_ONLY;
 	  // else do a deregister as set by default.
 	}
@@ -1460,10 +1464,11 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, tree label_finish,
 {
   stmtblock_t null, non_null;
   tree cond, tmp, error;
-  bool finalizable;
+  bool finalizable, comp_ref;
   gfc_coarray_deregtype caf_dereg_type = GFC_CAF_COARRAY_DEREGISTER;
 
-  if (coarray && expr && gfc_is_coarray_sub_component (expr))
+  if (coarray && expr && !gfc_caf_attr (expr, false, &comp_ref).coarray_comp
+      && comp_ref)
     caf_dereg_type = GFC_CAF_COARRAY_DEALLOCATE_ONLY;
 
   cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer,
diff --git a/libgfortran/caf/single.c b/libgfortran/caf/single.c
index 847e146076c..5e2932ca007 100644
--- a/libgfortran/caf/single.c
+++ b/libgfortran/caf/single.c
@@ -149,8 +149,7 @@ _gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token,
   else
     local = malloc (size);
 
-  if (type != CAF_REGTYPE_COARRAY_ALLOC_ALLOCATE_ONLY
-      && (type != CAF_REGTYPE_COARRAY_ALLOC || *token == NULL))
+  if (type != CAF_REGTYPE_COARRAY_ALLOC_ALLOCATE_ONLY)
     *token = malloc (sizeof (struct caf_single_token));
 
   if (unlikely (*token == NULL