gcc/fortran/ChangeLog:

2017-01-07  Andre Vehreschild  <vehre@gcc.gnu.org>

	PR fortran/78781
	PR fortran/78935
	* expr.c (gfc_check_pointer_assign): Return the same error message for
	rewritten coarray pointer assignments like for plain ones.
	* gfortran.h: Change prototype.
	* primary.c (caf_variable_attr): Set attributes used ones only only
	ones.  Add setting of pointer_comp attribute.
	(gfc_caf_attr): Add setting of pointer_comp attribute.
	* trans-array.c (gfc_array_allocate): Add flag that the component to
	allocate is not an ultimate coarray component.  Add allocation of
	pointer arrays.
	(structure_alloc_comps): Extend nullify to treat pointer components in
	coarrays correctly.  Restructure nullify to remove redundant code.
	(gfc_nullify_alloc_comp): Allow setting caf_mode flags.
	* trans-array.h: Change prototype of gfc_nullify_alloc_comp ().
	* trans-decl.c (generate_coarray_sym_init): Call nullify_alloc_comp for
	derived type coarrays with pointer components.
	* trans-expr.c (gfc_trans_structure_assign): Also treat pointer
	components.
	(trans_caf_token_assign): Handle assignment of token of scalar pointer
	components.
	(gfc_trans_pointer_assignment): Call above routine.
	* trans-intrinsic.c (conv_expr_ref_to_caf_ref): Add treating pointer
	components.
	(gfc_conv_intrinsic_caf_get): Likewise.
	(conv_caf_send): Likewise.
	* trans-stmt.c (gfc_trans_allocate): After allocating a derived type in
	a coarray pre-register the tokens.
	(gfc_trans_deallocate): Simply determining the coarray type (scalar or
	array) and deregistering it correctly.
	* trans-types.c (gfc_typenode_for_spec): Replace in_coarray flag by the
	actual codim to allow lookup of array types in the cache.
	(gfc_build_array_type): Likewise.
	(gfc_get_array_descriptor_base): Likewise.
	(gfc_get_array_type_bounds): Likewise.
	(gfc_get_derived_type): Likewise.
	* trans-types.h: Likewise.
	* trans.c (gfc_deallocate_with_status): Enable deregistering of all kind
	of coarray components.
	(gfc_deallocate_scalar_with_status): Use free() in fcoarray_single mode
	instead of caf_deregister.

libgfortran/ChangeLog:

2017-01-07  Andre Vehreschild  <vehre@gcc.gnu.org>

	PR fortran/78781
	PR fortran/78935
	* caf/single.c (send_by_ref): Fix addressing of non-allocatable scalar
	destination components.

gcc/testsuite/ChangeLog:

2017-01-07  Andre Vehreschild  <vehre@gcc.gnu.org>

	* gfortran.dg/coarray/ptr_comp_1.f08: New test.
	* gfortran.dg/coarray/ptr_comp_2.f08: New test.
	* gfortran.dg/coarray/ptr_comp_3.f08: New test.
	* gfortran.dg/coarray/ptr_comp_4.f08: New test.
	* gfortran.dg/coarray_ptr_comp_1.f08: New test.
	* gfortran.dg/coarray_ptr_comp_2.f08: New test.
	* gfortran.dg/coarray_ptr_comp_3.f08: New test.



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

23 files changed, 626 insertions, 106 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 30646921237..f89f9fd9972 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,47 @@
+2017-01-07  Andre Vehreschild  <vehre@gcc.gnu.org>
+
+	PR fortran/78781
+	PR fortran/78935
+	* expr.c (gfc_check_pointer_assign): Return the same error message for
+	rewritten coarray pointer assignments like for plain ones.
+	* gfortran.h: Change prototype.
+	* primary.c (caf_variable_attr): Set attributes used ones only only
+	ones.  Add setting of pointer_comp attribute.
+	(gfc_caf_attr): Add setting of pointer_comp attribute.
+	* trans-array.c (gfc_array_allocate): Add flag that the component to
+	allocate is not an ultimate coarray component.  Add allocation of
+	pointer arrays.
+	(structure_alloc_comps): Extend nullify to treat pointer components in
+	coarrays correctly.  Restructure nullify to remove redundant code.
+	(gfc_nullify_alloc_comp): Allow setting caf_mode flags.
+	* trans-array.h: Change prototype of gfc_nullify_alloc_comp ().
+	* trans-decl.c (generate_coarray_sym_init): Call nullify_alloc_comp for
+	derived type coarrays with pointer components.
+	* trans-expr.c (gfc_trans_structure_assign): Also treat pointer
+	components.
+	(trans_caf_token_assign): Handle assignment of token of scalar pointer
+	components.
+	(gfc_trans_pointer_assignment): Call above routine.
+	* trans-intrinsic.c (conv_expr_ref_to_caf_ref): Add treating pointer
+	components.
+	(gfc_conv_intrinsic_caf_get): Likewise.
+	(conv_caf_send): Likewise.
+	* trans-stmt.c (gfc_trans_allocate): After allocating a derived type in
+	a coarray pre-register the tokens.
+	(gfc_trans_deallocate): Simply determining the coarray type (scalar or
+	array) and deregistering it correctly.
+	* trans-types.c (gfc_typenode_for_spec): Replace in_coarray flag by the
+	actual codim to allow lookup of array types in the cache.
+	(gfc_build_array_type): Likewise.
+	(gfc_get_array_descriptor_base): Likewise.
+	(gfc_get_array_type_bounds): Likewise.
+	(gfc_get_derived_type): Likewise.
+	* trans-types.h: Likewise.
+	* trans.c (gfc_deallocate_with_status): Enable deregistering of all kind
+	of coarray components.
+	(gfc_deallocate_scalar_with_status): Use free() in fcoarray_single mode
+	instead of caf_deregister.
+
 2017-01-06  Jakub Jelinek  <jakub@redhat.com>
 
 	* simplify.c (simplify_transformation_to_array): Use
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 3c221eb67d5..7b95d206c53 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -3708,9 +3708,20 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
 
   if (rvalue->expr_type == EXPR_FUNCTION && !attr.pointer)
     {
-      gfc_error ("Target expression in pointer assignment "
-		 "at %L must deliver a pointer result",
-		 &rvalue->where);
+      /* F2008, C725.  For PURE also C1283.  Sometimes rvalue is a function call
+	 to caf_get.  Map this to the same error message as below when it is
+	 still a variable expression.  */
+      if (rvalue->value.function.isym
+	  && rvalue->value.function.isym->id == GFC_ISYM_CAF_GET)
+	/* The test above might need to be extend when F08, Note 5.4 has to be
+	   interpreted in the way that target and pointer with the same coindex
+	   are allowed.  */
+	gfc_error ("Data target at %L shall not have a coindex",
+		   &rvalue->where);
+      else
+	gfc_error ("Target expression in pointer assignment "
+		   "at %L must deliver a pointer result",
+		   &rvalue->where);
       return false;
     }
 
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index d168138cae9..f01a290e28f 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2836,7 +2836,7 @@ int gfc_validate_kind (bt, int, bool);
 int gfc_get_int_kind_from_width_isofortranenv (int size);
 int gfc_get_real_kind_from_width_isofortranenv (int size);
 tree gfc_get_union_type (gfc_symbol *);
-tree gfc_get_derived_type (gfc_symbol * derived, bool in_coarray = false);
+tree gfc_get_derived_type (gfc_symbol * derived, int codimen = 0);
 extern int gfc_index_integer_kind;
 extern int gfc_default_integer_kind;
 extern int gfc_max_integer_kind;
diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index 25a2829ce3d..d62f6bb1818 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -2436,8 +2436,7 @@ gfc_expr_attr (gfc_expr *e)
 static symbol_attribute
 caf_variable_attr (gfc_expr *expr, bool in_allocate, bool *refs_comp)
 {
-  int dimension, codimension, pointer, allocatable, target, coarray_comp,
-      alloc_comp;
+  int dimension, codimension, pointer, allocatable, target, coarray_comp;
   symbol_attribute attr;
   gfc_ref *ref;
   gfc_symbol *sym;
@@ -2458,7 +2457,8 @@ caf_variable_attr (gfc_expr *expr, bool in_allocate, bool *refs_comp)
       codimension = CLASS_DATA (sym)->attr.codimension;
       pointer = CLASS_DATA (sym)->attr.class_pointer;
       allocatable = CLASS_DATA (sym)->attr.allocatable;
-      alloc_comp = CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp;
+      attr.alloc_comp = CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp;
+      attr.pointer_comp = CLASS_DATA (sym)->ts.u.derived->attr.pointer_comp;
     }
   else
     {
@@ -2466,8 +2466,10 @@ caf_variable_attr (gfc_expr *expr, bool in_allocate, bool *refs_comp)
       codimension = sym->attr.codimension;
       pointer = sym->attr.pointer;
       allocatable = sym->attr.allocatable;
-      alloc_comp = sym->ts.type == BT_DERIVED
+      attr.alloc_comp = sym->ts.type == BT_DERIVED
 	  ? sym->ts.u.derived->attr.alloc_comp : 0;
+      attr.pointer_comp = sym->ts.type == BT_DERIVED
+	  ? sym->ts.u.derived->attr.pointer_comp : 0;
     }
 
   target = coarray_comp = 0;
@@ -2545,7 +2547,6 @@ caf_variable_attr (gfc_expr *expr, bool in_allocate, bool *refs_comp)
   attr.target = target;
   attr.save = sym->attr.save;
   attr.coarray_comp = coarray_comp;
-  attr.alloc_comp = alloc_comp;
 
   return attr;
 }
@@ -2575,6 +2576,8 @@ gfc_caf_attr (gfc_expr *e, bool in_allocate, bool *refs_comp)
 	      attr.pointer = CLASS_DATA (sym)->attr.class_pointer;
 	      attr.allocatable = CLASS_DATA (sym)->attr.allocatable;
 	      attr.alloc_comp = CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp;
+	      attr.pointer_comp = CLASS_DATA (sym)->ts.u.derived
+		  ->attr.pointer_comp;
 	    }
 	}
       else if (e->symtree)
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 9a755fbf58d..a3aab8e4528 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -5469,7 +5469,8 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
   gfc_expr **lower;
   gfc_expr **upper;
   gfc_ref *ref, *prev_ref = NULL, *coref;
-  bool allocatable, coarray, dimension, alloc_w_e3_arr_spec = false;
+  bool allocatable, coarray, dimension, alloc_w_e3_arr_spec = false,
+      non_ulimate_coarray_ptr_comp;
 
   ref = expr->ref;
 
@@ -5483,10 +5484,17 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
     {
       allocatable = expr->symtree->n.sym->attr.allocatable;
       dimension = expr->symtree->n.sym->attr.dimension;
+      non_ulimate_coarray_ptr_comp = false;
     }
   else
     {
       allocatable = prev_ref->u.c.component->attr.allocatable;
+      /* Pointer components in coarrayed derived types must be treated
+	 specially in that they are registered without a check if the are
+	 already associated.  This does not hold for ultimate coarray
+	 pointers.  */
+      non_ulimate_coarray_ptr_comp = (prev_ref->u.c.component->attr.pointer
+	      && !prev_ref->u.c.component->attr.codimension);
       dimension = prev_ref->u.c.component->attr.dimension;
     }
 
@@ -5599,20 +5607,27 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
   if (POINTER_TYPE_P (TREE_TYPE (se->expr)))
     se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
 
-  pointer = gfc_conv_descriptor_data_get (se->expr);
-  STRIP_NOPS (pointer);
-
   if (coarray && flag_coarray == GFC_FCOARRAY_LIB)
     {
+      pointer = non_ulimate_coarray_ptr_comp ? se->expr
+				      : gfc_conv_descriptor_data_get (se->expr);
       token = gfc_conv_descriptor_token (se->expr);
       token = gfc_build_addr_expr (NULL_TREE, token);
     }
+  else
+    pointer = gfc_conv_descriptor_data_get (se->expr);
+  STRIP_NOPS (pointer);
 
   /* The allocatable variant takes the old pointer as first argument.  */
   if (allocatable)
     gfc_allocate_allocatable (&elseblock, pointer, size, token,
 			      status, errmsg, errlen, label_finish, expr,
 			      coref != NULL ? coref->u.ar.as->corank : 0);
+  else if (non_ulimate_coarray_ptr_comp && token)
+    /* The token is set only for GFC_FCOARRAY_LIB mode.  */
+    gfc_allocate_using_caf_lib (&elseblock, pointer, size, token, status,
+				errmsg, errlen,
+				GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY);
   else
     gfc_allocate_using_malloc (&elseblock, pointer, size, status);
 
@@ -8411,55 +8426,64 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 	  break;
 
 	case NULLIFY_ALLOC_COMP:
-	  if (c->attr.pointer || c->attr.proc_pointer
+	  /* Nullify
+	     - allocatable components (regular or in class)
+	     - components that have allocatable components
+	     - pointer components when in a coarray.
+	     Skip everything else especially proc_pointers, which may come
+	     coupled with the regular pointer attribute.  */
+	  if (c->attr.proc_pointer
 	      || !(c->attr.allocatable || (c->ts.type == BT_CLASS
 					   && CLASS_DATA (c)->attr.allocatable)
-		   || cmp_has_alloc_comps))
+		   || (cmp_has_alloc_comps
+		       && ((c->ts.type == BT_DERIVED && !c->attr.pointer)
+			   || (c->ts.type == BT_CLASS
+			       && !CLASS_DATA (c)->attr.class_pointer)))
+		   || (caf_in_coarray (caf_mode) && c->attr.pointer)))
 	    continue;
 
-	  /* Coarrays need the component to be initialized before the api-call
-	     is made.  */
-	  if (c->attr.allocatable && (c->attr.dimension || c->attr.codimension))
-	    {
-	      comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
-				      decl, cdecl, NULL_TREE);
-	      gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
-	      cmp_has_alloc_comps = false;
-	    }
-	  else if (c->attr.allocatable)
+	  /* Process class components first, because they always have the
+	     pointer-attribute set which would be caught wrong else.  */
+	  if (c->ts.type == BT_CLASS
+	      && (CLASS_DATA (c)->attr.allocatable
+		  || CLASS_DATA (c)->attr.class_pointer))
 	    {
-	      /* Allocatable scalar components.  */
+	      /* Allocatable CLASS components.  */
 	      comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
 				      decl, cdecl, NULL_TREE);
-	      tmp = fold_build2_loc (input_location, MODIFY_EXPR,
-				     void_type_node, comp,
-				     build_int_cst (TREE_TYPE (comp), 0));
-	      gfc_add_expr_to_block (&fnblock, tmp);
-	      if (gfc_deferred_strlen (c, &comp))
+
+	      comp = gfc_class_data_get (comp);
+	      if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
+		gfc_conv_descriptor_data_set (&fnblock, comp,
+					      null_pointer_node);
+	      else
 		{
-		  comp = fold_build3_loc (input_location, COMPONENT_REF,
-					  TREE_TYPE (comp),
-					  decl, comp, NULL_TREE);
 		  tmp = fold_build2_loc (input_location, MODIFY_EXPR,
-					 TREE_TYPE (comp), comp,
+					 void_type_node, comp,
 					 build_int_cst (TREE_TYPE (comp), 0));
 		  gfc_add_expr_to_block (&fnblock, tmp);
 		}
 	      cmp_has_alloc_comps = false;
 	    }
-	  else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
+	  /* Coarrays need the component to be nulled before the api-call
+	     is made.  */
+	  else if (c->attr.pointer || c->attr.allocatable)
 	    {
-	      /* Allocatable CLASS components.  */
 	      comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
 				      decl, cdecl, NULL_TREE);
-
-	      comp = gfc_class_data_get (comp);
-	      if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
-		gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
+	      if (c->attr.dimension || c->attr.codimension)
+		gfc_conv_descriptor_data_set (&fnblock, comp,
+					      null_pointer_node);
 	      else
+		gfc_add_modify (&fnblock, comp,
+				build_int_cst (TREE_TYPE (comp), 0));
+	      if (gfc_deferred_strlen (c, &comp))
 		{
+		  comp = fold_build3_loc (input_location, COMPONENT_REF,
+					  TREE_TYPE (comp),
+					  decl, comp, NULL_TREE);
 		  tmp = fold_build2_loc (input_location, MODIFY_EXPR,
-					 void_type_node, comp,
+					 TREE_TYPE (comp), comp,
 					 build_int_cst (TREE_TYPE (comp), 0));
 		  gfc_add_expr_to_block (&fnblock, tmp);
 		}
@@ -8476,6 +8500,9 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 				      decl, cdecl, NULL_TREE);
 	      if (c->attr.dimension || c->attr.codimension)
 		{
+		  /* Set the dtype, because caf_register needs it.  */
+		  gfc_add_modify (&fnblock, gfc_conv_descriptor_dtype (comp),
+				  gfc_get_dtype (TREE_TYPE (comp)));
 		  tmp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
 					 decl, cdecl, NULL_TREE);
 		  token = gfc_conv_descriptor_token (tmp);
@@ -8494,10 +8521,6 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 		  gfc_add_block_to_block (&fnblock, &se.pre);
 		}
 
-	      /* NULL the member-token before registering it or uninitialized
-		 memory accesses may occur.  */
-	      gfc_add_modify (&fnblock, token, fold_convert (TREE_TYPE (token),
-							    null_pointer_node));
 	      gfc_allocate_using_caf_lib (&fnblock, comp, size_zero_node,
 					  gfc_build_addr_expr (NULL_TREE,
 							       token),
@@ -8711,11 +8734,12 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
    nullify allocatable components.  */
 
 tree
-gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
+gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
+			int caf_mode)
 {
   return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
 				NULLIFY_ALLOC_COMP,
-				GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY);
+			      GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode);
 }
 
 
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index e3df8860aa3..d87a9d88071 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -49,7 +49,7 @@ tree gfc_duplicate_allocatable_nocopy (tree, tree, tree, int);
 
 bool gfc_caf_is_dealloc_only (int);
 
-tree gfc_nullify_alloc_comp (gfc_symbol *, tree, int);
+tree gfc_nullify_alloc_comp (gfc_symbol *, tree, int, int cm = 0);
 
 tree gfc_deallocate_alloc_comp (gfc_symbol *, tree, int, int cm = 0);
 tree gfc_deallocate_alloc_comp_no_caf (gfc_symbol *, tree, int);
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 979ccdbf6ef..fffb4928f1c 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -5147,6 +5147,13 @@ generate_coarray_sym_init (gfc_symbol *sym)
       sym->attr.pointer = 0;
       gfc_add_expr_to_block (&caf_init_block, tmp);
     }
+  else if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pointer_comp)
+    {
+      tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, decl, sym->as
+				    ? sym->as->rank : 0,
+				    GFC_STRUCTURE_CAF_MODE_IN_COARRAY);
+      gfc_add_expr_to_block (&caf_init_block, tmp);
+    }
 }
 
 
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index b9c134a11d4..caaee6b42da 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -7506,7 +7506,8 @@ gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init, bool coarray)
 	 Register only allocatable components, that are not coarray'ed
 	 components (%comp[*]).  Only register when the constructor is not the
 	 null-expression.  */
-      if (coarray && !cm->attr.codimension && cm->attr.allocatable
+      if (coarray && !cm->attr.codimension
+	  && (cm->attr.allocatable || cm->attr.pointer)
 	  && (!c->expr || c->expr->expr_type == EXPR_NULL))
 	{
 	  tree token, desc, size;
@@ -8121,6 +8122,52 @@ trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
   return lhs_vptr;
 }
 
+
+/* Assign tokens for pointer components.  */
+
+static void
+trans_caf_token_assign (gfc_se *lse, gfc_se *rse, gfc_expr *expr1,
+			gfc_expr *expr2)
+{
+  symbol_attribute lhs_attr, rhs_attr;
+  tree tmp, lhs_tok, rhs_tok;
+  /* Flag to indicated component refs on the rhs.  */
+  bool rhs_cr;
+
+  lhs_attr = gfc_caf_attr (expr1);
+  if (expr2->expr_type != EXPR_NULL)
+    {
+      rhs_attr = gfc_caf_attr (expr2, false, &rhs_cr);
+      if (lhs_attr.codimension && rhs_attr.codimension)
+	{
+	  lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
+	  lhs_tok = build_fold_indirect_ref (lhs_tok);
+
+	  if (rhs_cr)
+	    rhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (rse, expr2);
+	  else
+	    {
+	      tree caf_decl;
+	      caf_decl = gfc_get_tree_for_caf_expr (expr2);
+	      gfc_get_caf_token_offset (rse, &rhs_tok, NULL, caf_decl,
+					NULL_TREE, NULL);
+	    }
+	  tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
+			    lhs_tok,
+			    fold_convert (TREE_TYPE (lhs_tok), rhs_tok));
+	  gfc_prepend_expr_to_block (&lse->post, tmp);
+	}
+    }
+  else if (lhs_attr.codimension)
+    {
+      lhs_tok = gfc_get_ultimate_alloc_ptr_comps_caf_token (lse, expr1);
+      lhs_tok = build_fold_indirect_ref (lhs_tok);
+      tmp = build2_loc (input_location, MODIFY_EXPR, void_type_node,
+			lhs_tok, null_pointer_node);
+      gfc_prepend_expr_to_block (&lse->post, tmp);
+    }
+}
+
 /* Indentify class valued proc_pointer assignments.  */
 
 static bool
@@ -8241,6 +8288,11 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
       gfc_add_modify (&block, lse.expr,
 		      fold_convert (TREE_TYPE (lse.expr), rse.expr));
 
+      /* Also set the tokens for pointer components in derived typed
+	 coarrays.  */
+      if (flag_coarray == GFC_FCOARRAY_LIB)
+	trans_caf_token_assign (&lse, &rse, expr1, expr2);
+
       gfc_add_block_to_block (&block, &rse.post);
       gfc_add_block_to_block (&block, &lse.post);
     }
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index a13d3fb3e3f..14781ac4814 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -1123,7 +1123,8 @@ conv_expr_ref_to_caf_ref (stmtblock_t *block, gfc_expr *expr)
   if (expr->symtree)
     {
       last_component_ref_tree = expr->symtree->n.sym->backend_decl;
-      ref_static_array = !expr->symtree->n.sym->attr.allocatable;
+      ref_static_array = !expr->symtree->n.sym->attr.allocatable
+	  && !expr->symtree->n.sym->attr.pointer;
     }
 
   /* Prevent uninit-warning.  */
@@ -1219,7 +1220,8 @@ conv_expr_ref_to_caf_ref (stmtblock_t *block, gfc_expr *expr)
 	  tmp = fold_build3_loc (input_location, COMPONENT_REF,
 				 TREE_TYPE (field), inner_struct, field,
 				 NULL_TREE);
-	  if (ref->u.c.component->attr.allocatable
+	  if ((ref->u.c.component->attr.allocatable
+	       || ref->u.c.component->attr.pointer)
 	      && ref->u.c.component->attr.dimension)
 	    {
 	      tree arr_desc_token_offset;
@@ -1243,7 +1245,8 @@ conv_expr_ref_to_caf_ref (stmtblock_t *block, gfc_expr *expr)
 
 	  /* Remember whether this ref was to a non-allocatable/non-pointer
 	     component so the next array ref can be tailored correctly.  */
-	  ref_static_array = !ref->u.c.component->attr.allocatable;
+	  ref_static_array = !ref->u.c.component->attr.allocatable
+	      && !ref->u.c.component->attr.pointer;
 	  last_component_ref_tree = ref_static_array
 	      ? ref->u.c.component->backend_decl : NULL_TREE;
 	  break;
@@ -1627,7 +1630,7 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind,
 
   /* Only use the new get_by_ref () where it is necessary.  I.e., when the lhs
      is reallocatable or the right-hand side has allocatable components.  */
-  if (caf_attr->alloc_comp || may_realloc)
+  if (caf_attr->alloc_comp || caf_attr->pointer_comp || may_realloc)
     {
       /* Get using caf_get_by_ref.  */
       caf_reference = conv_expr_ref_to_caf_ref (&se->pre, array_expr);
@@ -1876,7 +1879,8 @@ conv_caf_send (gfc_code *code) {
       lhs_se.expr = gfc_conv_scalar_to_descriptor (&lhs_se, lhs_se.expr, attr);
       lhs_se.expr = gfc_build_addr_expr (NULL_TREE, lhs_se.expr);
     }
-  else if (lhs_caf_attr.alloc_comp && lhs_caf_attr.codimension)
+  else if ((lhs_caf_attr.alloc_comp || lhs_caf_attr.pointer_comp)
+	   && lhs_caf_attr.codimension)
     {
       lhs_se.want_pointer = 1;
       gfc_conv_expr_descriptor (&lhs_se, lhs_expr);
@@ -1930,12 +1934,13 @@ conv_caf_send (gfc_code *code) {
      temporary and a loop.  */
   if (!gfc_is_coindexed (lhs_expr)
       && (!lhs_caf_attr.codimension
-	  || !(lhs_expr->rank > 0 && lhs_caf_attr.allocatable)))
+	  || !(lhs_expr->rank > 0
+	       && (lhs_caf_attr.allocatable || lhs_caf_attr.pointer))))
     {
       bool lhs_may_realloc = lhs_expr->rank > 0 && lhs_caf_attr.allocatable;
       gcc_assert (gfc_is_coindexed (rhs_expr));
       gfc_init_se (&rhs_se, NULL);
-      if (lhs_expr->rank == 0 && gfc_expr_attr (lhs_expr).allocatable)
+      if (lhs_expr->rank == 0 && lhs_caf_attr.allocatable)
 	{
 	  gfc_se scal_se;
 	  gfc_init_se (&scal_se, NULL);
@@ -1997,7 +2002,8 @@ conv_caf_send (gfc_code *code) {
       rhs_se.expr = gfc_conv_scalar_to_descriptor (&rhs_se, rhs_se.expr, attr);
       rhs_se.expr = gfc_build_addr_expr (NULL_TREE, rhs_se.expr);
     }
-  else if (rhs_caf_attr.alloc_comp && rhs_caf_attr.codimension)
+  else if ((rhs_caf_attr.alloc_comp || rhs_caf_attr.pointer_comp)
+	   && rhs_caf_attr.codimension)
     {
       tree tmp2;
       rhs_se.want_pointer = 1;
@@ -2065,7 +2071,7 @@ conv_caf_send (gfc_code *code) {
 
   if (!gfc_is_coindexed (rhs_expr))
     {
-      if (lhs_caf_attr.alloc_comp)
+      if (lhs_caf_attr.alloc_comp || lhs_caf_attr.pointer_comp)
 	{
 	  tree reference, dst_realloc;
 	  reference = conv_expr_ref_to_caf_ref (&block, lhs_expr);
@@ -2100,7 +2106,7 @@ conv_caf_send (gfc_code *code) {
 	caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
       rhs_image_index = gfc_caf_get_image_index (&block, rhs_expr, caf_decl);
       tmp = rhs_se.expr;
-      if (rhs_caf_attr.alloc_comp)
+      if (rhs_caf_attr.alloc_comp || rhs_caf_attr.pointer_comp)
 	{
 	  tmp_stat = gfc_find_stat_co (lhs_expr);
 
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index df61bab8304..856008779ba 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -6299,6 +6299,40 @@ gfc_trans_allocate (gfc_code * code)
 	  gfc_add_expr_to_block (&block, tmp);
 	}
 
+      /* Nullify all pointers in derived type coarrays.  This registers a
+	 token for them which allows their allocation.  */
+      if (is_coarray)
+	{
+	  gfc_symbol *type = NULL;
+	  symbol_attribute caf_attr;
+	  int rank = 0;
+	  if (code->ext.alloc.ts.type == BT_DERIVED
+	      && code->ext.alloc.ts.u.derived->attr.pointer_comp)
+	    {
+	      type = code->ext.alloc.ts.u.derived;
+	      rank = type->attr.dimension ? type->as->rank : 0;
+	      gfc_clear_attr (&caf_attr);
+	    }
+	  else if (expr->ts.type == BT_DERIVED
+		   && expr->ts.u.derived->attr.pointer_comp)
+	    {
+	      type = expr->ts.u.derived;
+	      rank = expr->rank;
+	      caf_attr = gfc_caf_attr (expr, true);
+	    }
+
+	  /* Initialize the tokens of pointer components in derived type
+	     coarrays.  */
+	  if (type)
+	    {
+	      tmp = (caf_attr.codimension && !caf_attr.dimension)
+		  ? gfc_conv_descriptor_data_get (se.expr) : se.expr;
+	      tmp = gfc_nullify_alloc_comp (type, tmp, rank,
+					    GFC_STRUCTURE_CAF_MODE_IN_COARRAY);
+	      gfc_add_expr_to_block (&block, tmp);
+	    }
+	}
+
       gfc_free_expr (expr);
     } // for-loop
 
@@ -6443,7 +6477,8 @@ gfc_trans_deallocate (gfc_code *code)
       se.descriptor_only = 1;
       gfc_conv_expr (&se, expr);
 
-      if (flag_coarray == GFC_FCOARRAY_LIB)
+      if (flag_coarray == GFC_FCOARRAY_LIB
+	  || flag_coarray == GFC_FCOARRAY_SINGLE)
 	{
 	  bool comp_ref;
 	  symbol_attribute caf_attr = gfc_caf_attr (expr, false, &comp_ref);
@@ -6453,15 +6488,15 @@ gfc_trans_deallocate (gfc_code *code)
 	      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
-		  | (comp_ref && !caf_attr.coarray_comp
-		     ? GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY : 0);
+	      if (flag_coarray == GFC_FCOARRAY_LIB)
+		/* 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
+		    | (comp_ref && !caf_attr.coarray_comp
+		       ? GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY : 0);
 	    }
 	}
-      else if (flag_coarray == GFC_FCOARRAY_SINGLE)
-	is_coarray = is_coarray_array = gfc_caf_attr (expr).codimension;
 
       if (expr->rank || is_coarray_array)
 	{
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index a214aae22d8..156c0dac15d 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -1050,7 +1050,7 @@ gfc_get_character_type (int kind, gfc_charlen * cl)
 /* Convert a basic type.  This will be an array for character types.  */
 
 tree
-gfc_typenode_for_spec (gfc_typespec * spec, bool in_coarray)
+gfc_typenode_for_spec (gfc_typespec * spec, int codim)
 {
   tree basetype;
 
@@ -1103,7 +1103,7 @@ gfc_typenode_for_spec (gfc_typespec * spec, bool in_coarray)
 
     case BT_DERIVED:
     case BT_CLASS:
-      basetype = gfc_get_derived_type (spec->u.derived, in_coarray);
+      basetype = gfc_get_derived_type (spec->u.derived, codim);
 
       if (spec->type == BT_CLASS)
 	GFC_CLASS_TYPE_P (basetype) = 1;
@@ -1307,7 +1307,7 @@ gfc_is_nodesc_array (gfc_symbol * sym)
 static tree
 gfc_build_array_type (tree type, gfc_array_spec * as,
 		      enum gfc_array_kind akind, bool restricted,
-		      bool contiguous, bool in_coarray)
+		      bool contiguous, int codim)
 {
   tree lbound[GFC_MAX_DIMENSIONS];
   tree ubound[GFC_MAX_DIMENSIONS];
@@ -1315,10 +1315,10 @@ gfc_build_array_type (tree type, gfc_array_spec * as,
 
   /* Assumed-shape arrays do not have codimension information stored in the
      descriptor.  */
-  corank = as->corank;
+  corank = MAX (as->corank, codim);
   if (as->type == AS_ASSUMED_SHAPE ||
       (as->type == AS_ASSUMED_RANK && akind == GFC_ARRAY_ALLOCATABLE))
-    corank = 0;
+    corank = codim;
 
   if (as->type == AS_ASSUMED_RANK)
     for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
@@ -1356,8 +1356,8 @@ gfc_build_array_type (tree type, gfc_array_spec * as,
 		       : GFC_ARRAY_ASSUMED_RANK;
   return gfc_get_array_type_bounds (type, as->rank == -1
 					  ? GFC_MAX_DIMENSIONS : as->rank,
-				    corank, lbound,
-				    ubound, 0, akind, restricted, in_coarray);
+				    corank, lbound, ubound, 0, akind,
+				    restricted);
 }
 
 /* Returns the struct descriptor_dimension type.  */
@@ -1719,8 +1719,7 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed,
 /* Return or create the base type for an array descriptor.  */
 
 static tree
-gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted,
-			       enum gfc_array_kind akind, bool in_coarray)
+gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted)
 {
   tree fat_type, decl, arraytype, *chain = NULL;
   char name[16 + 2*GFC_RANK_DIGITS + 1 + 1];
@@ -1782,8 +1781,7 @@ gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted,
       TREE_NO_WARNING (decl) = 1;
     }
 
-  if (flag_coarray == GFC_FCOARRAY_LIB && (codimen || in_coarray)
-      && akind == GFC_ARRAY_ALLOCATABLE)
+  if (flag_coarray == GFC_FCOARRAY_LIB && codimen)
     {
       decl = gfc_add_field_to_struct_1 (fat_type,
 					get_identifier ("token"),
@@ -1795,8 +1793,7 @@ gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted,
   gfc_finish_type (fat_type);
   TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (fat_type)) = 1;
 
-  if (flag_coarray == GFC_FCOARRAY_LIB && codimen
-      && akind == GFC_ARRAY_ALLOCATABLE)
+  if (flag_coarray == GFC_FCOARRAY_LIB && codimen)
     gfc_array_descriptor_base_caf[idx] = fat_type;
   else
     gfc_array_descriptor_base[idx] = fat_type;
@@ -1810,21 +1807,18 @@ gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted,
 tree
 gfc_get_array_type_bounds (tree etype, int dimen, int codimen, tree * lbound,
 			   tree * ubound, int packed,
-			   enum gfc_array_kind akind, bool restricted,
-			   bool in_coarray)
+			   enum gfc_array_kind akind, bool restricted)
 {
   char name[8 + 2*GFC_RANK_DIGITS + 1 + GFC_MAX_SYMBOL_LEN];
   tree fat_type, base_type, arraytype, lower, upper, stride, tmp, rtype;
   const char *type_name;
   int n;
 
-  base_type = gfc_get_array_descriptor_base (dimen, codimen, restricted, akind,
-					     in_coarray);
+  base_type = gfc_get_array_descriptor_base (dimen, codimen, restricted);
   fat_type = build_distinct_type_copy (base_type);
   /* Make sure that nontarget and target array type have the same canonical
      type (and same stub decl for debug info).  */
-  base_type = gfc_get_array_descriptor_base (dimen, codimen, false, akind,
-					     in_coarray);
+  base_type = gfc_get_array_descriptor_base (dimen, codimen, false);
   TYPE_CANONICAL (fat_type) = base_type;
   TYPE_STUB_DECL (fat_type) = TYPE_STUB_DECL (base_type);
 
@@ -2416,7 +2410,7 @@ gfc_get_union_type (gfc_symbol *un)
    in a parent namespace, this is used.  */
 
 tree
-gfc_get_derived_type (gfc_symbol * derived, bool in_coarray)
+gfc_get_derived_type (gfc_symbol * derived, int codimen)
 {
   tree typenode = NULL, field = NULL, field_type = NULL;
   tree canonical = NULL_TREE;
@@ -2568,9 +2562,11 @@ gfc_get_derived_type (gfc_symbol * derived, bool in_coarray)
       if ((!c->attr.pointer && !c->attr.proc_pointer
 	  && !same_alloc_type)
 	  || c->ts.u.derived->backend_decl == NULL)
-	c->ts.u.derived->backend_decl = gfc_get_derived_type (c->ts.u.derived,
-							      in_coarray
-							|| c->attr.codimension);
+	{
+	  int local_codim = c->attr.codimension ? c->as->corank: codimen;
+	  c->ts.u.derived->backend_decl = gfc_get_derived_type (c->ts.u.derived,
+								local_codim);
+	}
 
       if (c->ts.u.derived->attr.is_iso_c)
         {
@@ -2629,7 +2625,7 @@ gfc_get_derived_type (gfc_symbol * derived, bool in_coarray)
 	    c->ts.u.cl->backend_decl
 			= build_int_cst (gfc_charlen_type_node, 0);
 
-	  field_type = gfc_typenode_for_spec (&c->ts, in_coarray);
+	  field_type = gfc_typenode_for_spec (&c->ts, codimen);
 	}
 
       /* This returns an array descriptor type.  Initialization may be
@@ -2650,7 +2646,7 @@ gfc_get_derived_type (gfc_symbol * derived, bool in_coarray)
 						 !c->attr.target
 						 && !c->attr.pointer,
 						 c->attr.contiguous,
-						 in_coarray);
+						 codimen);
 	    }
 	  else
 	    field_type = gfc_get_nodesc_array_type (field_type, c->as,
@@ -2697,9 +2693,9 @@ gfc_get_derived_type (gfc_symbol * derived, bool in_coarray)
 	c->backend_decl = field;
 
       /* Do not add a caf_token field for classes' data components.  */
-      if (in_coarray && !c->attr.dimension && !c->attr.codimension
-	  && c->attr.allocatable && c->caf_token == NULL_TREE
-	  && strcmp ("_data", c->name) != 0)
+      if (codimen && !c->attr.dimension && !c->attr.codimension
+	  && (c->attr.allocatable || c->attr.pointer)
+	  && c->caf_token == NULL_TREE && strcmp ("_data", c->name) != 0)
 	{
 	  char caf_name[GFC_MAX_SYMBOL_LEN];
 	  snprintf (caf_name, GFC_MAX_SYMBOL_LEN, "_caf_%s", c->name);
diff --git a/gcc/fortran/trans-types.h b/gcc/fortran/trans-types.h
index 9f1b64f4877..2974e451304 100644
--- a/gcc/fortran/trans-types.h
+++ b/gcc/fortran/trans-types.h
@@ -70,7 +70,7 @@ tree gfc_get_character_type_len (int, tree);
 tree gfc_get_character_type_len_for_eltype (tree, tree);
 
 tree gfc_sym_type (gfc_symbol *);
-tree gfc_typenode_for_spec (gfc_typespec *, bool in_coarray = false);
+tree gfc_typenode_for_spec (gfc_typespec *, int c = 0);
 int gfc_copy_dt_decls_ifequal (gfc_symbol *, gfc_symbol *, bool);
 
 tree gfc_get_function_type (gfc_symbol *);
@@ -81,8 +81,7 @@ tree gfc_build_uint_type (int);
 
 tree gfc_get_element_type (tree);
 tree gfc_get_array_type_bounds (tree, int, int, tree *, tree *, int,
-				enum gfc_array_kind, bool,
-				bool in_coarray = false);
+				enum gfc_array_kind, bool);
 tree gfc_get_nodesc_array_type (tree, gfc_array_spec *, gfc_packed, bool);
 
 /* Add a field of given name and type to a UNION_TYPE or RECORD_TYPE.  */
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index dcbf7c346d3..82ed19ac283 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -1302,8 +1302,7 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
 	      pointer = gfc_conv_descriptor_data_get (caf_decl);
 	      caf_type = TREE_TYPE (caf_decl);
 	      STRIP_NOPS (pointer);
-	      if (GFC_DESCRIPTOR_TYPE_P (caf_type)
-		  && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
+	      if (GFC_DESCRIPTOR_TYPE_P (caf_type))
 		token = gfc_conv_descriptor_token (caf_decl);
 	      else if (DECL_LANG_SPECIFIC (caf_decl)
 		       && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
@@ -1552,7 +1551,7 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, tree label_finish,
       gfc_add_expr_to_block (&non_null, tmp);
     }
 
-  if (!coarray)
+  if (!coarray || flag_coarray == GFC_FCOARRAY_SINGLE)
     {
       tmp = build_call_expr_loc (input_location,
 				 builtin_decl_explicit (BUILT_IN_FREE), 1,
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 6d2162d547d..0d5aa52cc0a 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,13 @@
+2017-01-07  Andre Vehreschild  <vehre@gcc.gnu.org>
+
+	* gfortran.dg/coarray/ptr_comp_1.f08: New test.
+	* gfortran.dg/coarray/ptr_comp_2.f08: New test.
+	* gfortran.dg/coarray/ptr_comp_3.f08: New test.
+	* gfortran.dg/coarray/ptr_comp_4.f08: New test.
+	* gfortran.dg/coarray_ptr_comp_1.f08: New test.
+	* gfortran.dg/coarray_ptr_comp_2.f08: New test.
+	* gfortran.dg/coarray_ptr_comp_3.f08: New test.
+
 2017-01-06  Aaron Sawdey  <acsawdey@linux.vnet.ibm.com>
 	* gcc.dg/memcmp-1.c: New.
 	* gcc.dg/strncmp-1.c: New.
diff --git a/gcc/testsuite/gfortran.dg/coarray/ptr_comp_1.f08 b/gcc/testsuite/gfortran.dg/coarray/ptr_comp_1.f08
new file mode 100644
index 00000000000..fe70e63c32f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray/ptr_comp_1.f08
@@ -0,0 +1,36 @@
+! { dg-do run }
+
+program alloc_comp
+   type t
+      integer, pointer :: z
+   end type
+   type(t), save :: obj[*]
+   integer, allocatable, target :: i[:]
+
+   if (associated(obj%z)) error stop "'z' should not be associated yet."
+   allocate (obj%z)
+   call f(obj)
+   if (associated(obj%z)) error stop "'z' should not be associated anymore."
+
+   allocate(i[*], SOURCE=42)
+   obj%z => i
+   if (.not. allocated(i)) error stop "'i' no longer allocated."
+   i = 15
+   if (obj%z /= 15) error stop "'obj%z' is deep copy and not pointer."
+
+   nullify (obj%z)
+   if (.not. allocated(i)) error stop "'i' should still be allocated."
+   if (associated(obj%z)) error stop "'obj%z' should not be associated anymore."
+
+   obj%z => i
+   call f(obj)
+   ! One can not say anything about i here. The memory should be deallocated, but
+   ! the pointer in i is still set.
+   if (associated(obj%z)) error stop "'obj%z' should not be associated anymore."
+contains
+   subroutine f(x)
+      type(t) :: x[*]
+      if ( associated(x%z) ) deallocate(x%z)
+   end subroutine
+end program
+
diff --git a/gcc/testsuite/gfortran.dg/coarray/ptr_comp_2.f08 b/gcc/testsuite/gfortran.dg/coarray/ptr_comp_2.f08
new file mode 100644
index 00000000000..91977ff1d35
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray/ptr_comp_2.f08
@@ -0,0 +1,36 @@
+! { dg-do run }
+
+program ptr_comp 
+   type t
+      integer, pointer :: z(:)
+   end type
+   type(t), save :: obj[*]
+   integer, allocatable, target :: i(:)[:]
+
+   if (associated(obj%z)) error stop "'z' should not be associated yet."
+   allocate (obj%z(5))
+   call f(obj)
+   if (associated(obj%z)) error stop "'z' should not be associated anymore."
+
+   allocate(i(7)[*], SOURCE=42)
+   obj%z => i
+   if (.not. allocated(i)) error stop "'i' no longer allocated."
+   i = 15
+   if (any(obj%z(:) /= 15)) error stop "'obj%z' is deep copy and not pointer."
+
+   nullify (obj%z)
+   if (.not. allocated(i)) error stop "'i' should still be allocated."
+   if (associated(obj%z)) error stop "'obj%z' should not be associated anymore."
+
+   obj%z => i
+   call f(obj)
+   ! One can not say anything about i here. The memory should be deallocated, but
+   ! the pointer in i is still set.
+   if (associated(obj%z)) error stop "'obj%z' should not be associated anymore."
+contains
+   subroutine f(x)
+      type(t) :: x[*]
+      if ( associated(x%z) ) deallocate(x%z)
+   end subroutine
+end program
+
diff --git a/gcc/testsuite/gfortran.dg/coarray/ptr_comp_3.f08 b/gcc/testsuite/gfortran.dg/coarray/ptr_comp_3.f08
new file mode 100644
index 00000000000..ad7137f009e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray/ptr_comp_3.f08
@@ -0,0 +1,22 @@
+! { dg-do run }
+
+! Contributed by Damian Rouson
+! Same like coarray/alloc_comp_4
+
+program main
+
+  implicit none
+
+  type mytype
+    integer, pointer :: indices(:)
+  end type
+
+  type(mytype), save :: object[*]
+  integer :: me
+
+  me=this_image()
+  allocate(object%indices(me))
+  object%indices = 42
+
+  if ( any( object[me]%indices(:) /= 42 ) ) call abort()
+end program
diff --git a/gcc/testsuite/gfortran.dg/coarray/ptr_comp_4.f08 b/gcc/testsuite/gfortran.dg/coarray/ptr_comp_4.f08
new file mode 100644
index 00000000000..e6189213122
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray/ptr_comp_4.f08
@@ -0,0 +1,20 @@
+! { dg-do run }
+
+! Same like coarray/alloc_comp_5 but for pointer comp.
+
+program Jac
+  type Domain
+    integer :: n=64
+    integer, pointer :: endsi(:)
+  end type
+  type(Domain),allocatable :: D[:,:,:]
+
+  allocate(D[2,2,*])
+  allocate(D%endsi(2), source = 0)
+  ! No caf-runtime call needed her.
+  D%endsi(2) = D%n
+  if (any(D%endsi /= [ 0, 64])) error stop
+  deallocate(D%endsi)
+  deallocate(D)
+end program
+
diff --git a/gcc/testsuite/gfortran.dg/coarray_ptr_comp_1.f08 b/gcc/testsuite/gfortran.dg/coarray_ptr_comp_1.f08
new file mode 100644
index 00000000000..f0b51d5ead1
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_ptr_comp_1.f08
@@ -0,0 +1,99 @@
+! { dg-do run }
+! { dg-options "-fcoarray=lib -lcaf_single" }
+! { dg-additional-options "-latomic" { target libatomic_available } }
+
+! Contributed by Damian Rouson
+! Check the new _caf_get_by_ref()-routine.
+! Same like coarray_alloc_comp_1 but for pointers.
+
+program main
+
+implicit none
+
+type :: mytype
+  integer :: i
+  integer, pointer :: indices(:)
+  real, dimension(2,5,3) :: volume
+  integer, pointer :: scalar
+  integer :: j
+  integer, pointer :: matrix(:,:)
+  real, pointer :: dynvol(:,:,:)
+end type
+
+type arrtype
+  type(mytype), pointer :: vec(:)
+  type(mytype), pointer :: mat(:,:)
+end type arrtype
+
+type(mytype), save :: object[*]
+type(arrtype), save :: bar[*]
+integer :: i,j,me,neighbor
+integer :: idx(5)
+real, allocatable :: volume(:,:,:), vol2(:,:,:)
+real, target :: vol_static(2,5,3)
+
+idx = (/ 1,2,1,7,5 /)
+
+me=this_image()
+allocate(object%indices, source=[(i,i=1,5)])
+allocate(object%scalar, object%matrix(10,7))
+object%i = 37
+object%scalar = 42
+vol_static = reshape([(i, i=1, 2*5*3)], [2, 5, 3])
+object%volume = vol_static
+object%matrix = reshape([(i, i=1, 70)], [10, 7])
+object%dynvol => vol_static
+sync all
+neighbor = merge(1,neighbor,me==num_images())
+if (object[neighbor]%scalar /= 42) call abort()
+if (object[neighbor]%indices(4) /= 4) call abort()
+if (object[neighbor]%matrix(3,6) /= 53) call abort()
+if (any( object[neighbor]%indices(:) /= [1,2,3,4,5] )) call abort()
+if (any( object[neighbor]%matrix(:,:) /= reshape([(i, i=1, 70)], [10, 7]))) call abort()
+if (any( object[neighbor]%matrix(3,:) /= [(i * 10 + 3, i=0, 6)])) call abort()
+if (any( object[neighbor]%matrix(:,2) /= [(i + 10, i=1, 10)])) call abort()
+if (any( object[neighbor]%matrix(idx,2) /= [11, 12, 11, 17, 15])) call abort()
+if (any( object[neighbor]%matrix(3,idx) /= [3, 13, 3, 63, 43])) call abort()
+if (any( object[neighbor]%matrix(2:8:4, 5:1:-1) /= reshape([42, 46, 32, 36, 22, 26, 12, 16, 2, 6], [2,5]))) call abort()
+if (any( object[neighbor]%matrix(:8:4, 2::2) /= reshape([11, 15, 31, 35, 51, 55], [2,3]))) call abort()
+if (any( object[neighbor]%volume /= vol_static)) call abort()
+if (any( object[neighbor]%dynvol /= vol_static)) call abort()
+if (any( object[neighbor]%volume(:, 2:4, :) /= vol_static(:, 2:4, :))) call abort()
+if (any( object[neighbor]%dynvol(:, 2:4, :) /= vol_static(:, 2:4, :))) call abort()
+
+vol2 = vol_static(:, ::2, :)
+if (any( object[neighbor]%volume(:, ::2, :) /= vol2)) call abort()
+if (any( object[neighbor]%dynvol(:, ::2, :) /= vol2)) call abort()
+
+allocate(bar%vec(-2:2))
+
+bar%vec(1)%volume = vol_static
+if (any(bar[neighbor]%vec(1)%volume /= vol_static)) call abort()
+
+i = 15
+allocate(bar%vec(1)%scalar, bar%vec(0)%scalar)
+bar%vec(1)%scalar = i
+if (.not. associated(bar%vec(1)%scalar)) call abort()
+if (bar[neighbor]%vec(1)%scalar /= 15) call abort()
+
+bar%vec(0)%scalar = 27
+if (.not. associated(bar%vec(0)%scalar)) call abort()
+if (bar[neighbor]%vec(0)%scalar /= 27) call abort()
+
+allocate(bar%vec(1)%indices(3), bar%vec(2)%indices(5))
+bar%vec(1)%indices = [ 3, 4, 15 ]
+bar%vec(2)%indices = 89
+
+if (.not. associated(bar%vec(1)%indices)) call abort()
+if (associated(bar%vec(-2)%indices)) call abort()
+if (associated(bar%vec(-1)%indices)) call abort()
+if (associated(bar%vec( 0)%indices)) call abort()
+if (.not. associated(bar%vec( 2)%indices)) call abort()
+if (any(bar[me]%vec(2)%indices /= 89)) call abort()
+
+if (any (bar[neighbor]%vec(1)%indices /= [ 3,4,15])) call abort()
+
+deallocate(bar%vec(2)%indices, bar%vec(1)%indices, bar%vec(1)%scalar, bar%vec(0)%scalar)
+deallocate(object%indices, object%scalar, object%matrix)
+deallocate(bar%vec)
+end program
diff --git a/gcc/testsuite/gfortran.dg/coarray_ptr_comp_2.f08 b/gcc/testsuite/gfortran.dg/coarray_ptr_comp_2.f08
new file mode 100644
index 00000000000..d930a82f8a3
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_ptr_comp_2.f08
@@ -0,0 +1,88 @@
+! { dg-do run }
+! { dg-options "-fcoarray=lib -lcaf_single" }
+! { dg-additional-options "-latomic" { target libatomic_available } }
+
+! Contributed by Damian Rouson
+! Check the new _caf_send_by_ref()-routine.
+! Same as coarray_alloc_comp_2 but for pointers.
+
+program main
+
+implicit none
+
+type :: mytype
+  integer :: i
+  integer, pointer :: indices(:)
+  real, dimension(2,5,3) :: volume
+  integer, pointer :: scalar
+  integer :: j
+  integer, pointer :: matrix(:,:)
+  real, pointer :: dynvol(:,:,:)
+end type
+
+type arrtype
+  type(mytype), pointer :: vec(:)
+  type(mytype), pointer :: mat(:,:)
+end type arrtype
+
+type(mytype), save :: object[*]
+type(arrtype), save :: bar[*]
+integer :: i,j,me,neighbor
+integer :: idx(5)
+real, allocatable :: volume(:,:,:), vol2(:,:,:)
+real :: vol_static(2,5,3)
+
+idx = (/ 1,2,1,7,5 /)
+
+me=this_image()
+neighbor = merge(1,me+1,me==num_images())
+allocate(object%indices(5), object%scalar, object%matrix(10,7), object%dynvol(2,5,3))
+object[neighbor]%indices=[(i,i=1,5)]
+object[neighbor]%i = 37
+object[neighbor]%scalar = 42
+vol_static = reshape([(i, i=1, 2*5*3)], [2, 5, 3])
+object[neighbor]%volume = vol_static
+object[neighbor]%matrix = reshape([(i, i=1, 70)], [10, 7])
+object[neighbor]%dynvol = vol_static
+sync all
+if (object%scalar /= 42) call abort()
+if (any( object%indices /= [1,2,3,4,5] )) call abort()
+if (any( object%matrix /= reshape([(i, i=1, 70)], [10, 7]))) call abort()
+if (any( object%volume /= vol_static)) call abort()
+if (any( object%dynvol /= vol_static)) call abort()
+
+vol2 = vol_static
+vol2(:, ::2, :) = 42
+object[neighbor]%volume(:, ::2, :) = 42
+object[neighbor]%dynvol(:, ::2, :) = 42
+if (any( object%volume /= vol2)) call abort()
+if (any( object%dynvol /= vol2)) call abort()
+
+allocate(bar%vec(-2:2))
+
+bar[neighbor]%vec(1)%volume = vol_static
+if (any(bar%vec(1)%volume /= vol_static)) call abort()
+
+allocate(bar%vec(1)%scalar, bar%vec(0)%scalar, bar%vec(1)%indices(3))
+i = 15
+bar[neighbor]%vec(1)%scalar = i
+if (.not. associated(bar%vec(1)%scalar)) call abort()
+if (bar%vec(1)%scalar /= 15) call abort()
+
+bar[neighbor]%vec(0)%scalar = 27
+if (.not. associated(bar%vec(0)%scalar)) call abort()
+if (bar%vec(0)%scalar /= 27) call abort()
+
+bar[neighbor]%vec(1)%indices = [ 3, 4, 15 ]
+allocate(bar%vec(2)%indices(5))
+bar[neighbor]%vec(2)%indices = 89
+
+if (.not. associated(bar%vec(1)%indices)) call abort()
+if (associated(bar%vec(-2)%indices)) call abort()
+if (associated(bar%vec(-1)%indices)) call abort()
+if (associated(bar%vec( 0)%indices)) call abort()
+if (.not. associated(bar%vec( 2)%indices)) call abort()
+if (any(bar%vec(2)%indices /= 89)) call abort()
+
+if (any (bar%vec(1)%indices /= [ 3,4,15])) call abort()
+end program
diff --git a/gcc/testsuite/gfortran.dg/coarray_ptr_comp_3.f08 b/gcc/testsuite/gfortran.dg/coarray_ptr_comp_3.f08
new file mode 100644
index 00000000000..efdfb367040
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_ptr_comp_3.f08
@@ -0,0 +1,13 @@
+! { dg-do compile }
+! { dg-options "-fcoarray=lib" }
+
+program ptr_comp 
+   type t
+      integer, pointer :: z(:)
+   end type
+   type(t), save :: obj[*]
+   integer, allocatable, target :: i(:)[:]
+
+   obj%z => i(:)[4] ! { dg-error "shall not have a coindex" }
+end program
+
diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog
index f86dd33c787..f07dff1b8d6 100644
--- a/libgfortran/ChangeLog
+++ b/libgfortran/ChangeLog
@@ -1,3 +1,10 @@
+2017-01-07  Andre Vehreschild  <vehre@gcc.gnu.org>
+
+	PR fortran/78781
+	PR fortran/78935
+	* caf/single.c (send_by_ref): Fix addressing of non-allocatable scalar
+	destination components.
+
 2017-01-01  Jakub Jelinek  <jakub@redhat.com>
 
 	Update copyright years.
diff --git a/libgfortran/caf/single.c b/libgfortran/caf/single.c
index fa50431db42..cf78a1a48fd 100644
--- a/libgfortran/caf/single.c
+++ b/libgfortran/caf/single.c
@@ -1953,11 +1953,24 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index,
 		}
 	      else
 		{
-		  ds = GFC_DESCRIPTOR_DATA (dst);
-		  dst_type = GFC_DESCRIPTOR_TYPE (dst);
+		  single_token = *(caf_single_token_t *)
+					       (ds + ref->u.c.caf_token_offset);
+		  dst = single_token->desc;
+		  if (dst)
+		    {
+		      ds = GFC_DESCRIPTOR_DATA (dst);
+		      dst_type = GFC_DESCRIPTOR_TYPE (dst);
+		    }
+		  else
+		    {
+		      /* When no destination descriptor is present, assume that
+			 source and dest type are identical.  */
+		      dst_type = GFC_DESCRIPTOR_TYPE (src);
+		      ds = *(void **)(ds + ref->u.c.offset);
+		    }
 		}
 	      copy_data (ds, sr, dst_type, GFC_DESCRIPTOR_TYPE (src),
-		  dst_kind, src_kind, ref->item_size, src_size, 1, stat);
+			 dst_kind, src_kind, ref->item_size, src_size, 1, stat);
 	    }
 	  else
 	    copy_data (ds + ref->u.c.offset, sr,
@@ -2055,7 +2068,7 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index,
 	  return;
 	}
       /* Only when on the left most index switch the data pointer to
-	     the array's data pointer.  And only for non-static arrays.  */
+	 the array's data pointer.  And only for non-static arrays.  */
       if (dst_dim == 0 && ref->type != CAF_REF_STATIC_ARRAY)
 	ds = GFC_DESCRIPTOR_DATA (dst);
       switch (ref->u.a.mode[dst_dim])