trans-array.c (gfc_array_deallocate): Remove wrapper.

gcc/fortran/ChangeLog:

2016-12-09  Andre Vehreschild  <vehre@gcc.gnu.org>

	* trans-array.c (gfc_array_deallocate): Remove wrapper.
	(gfc_trans_dealloc_allocated): Same.
	(structure_alloc_comps): Restructure deallocation of (nested)
	allocatable components.  Insert dealloc of sub-component into the block
	guarded by the if != NULL for the component.
	(gfc_trans_deferred_array): Use the almightly deallocate_with_status.
	* trans-array.h: Remove prototypes.
	* trans-expr.c (gfc_conv_procedure_call): Use the almighty deallocate_
	with_status.
	* trans-openmp.c (gfc_walk_alloc_comps): Likewise.
	(gfc_omp_clause_assign_op): Likewise. 
	(gfc_omp_clause_dtor): Likewise.
	* trans-stmt.c (gfc_trans_deallocate): Likewise.
	* trans.c (gfc_deallocate_with_status): Allow deallocation of scalar
	and arrays as well as coarrays.
	(gfc_deallocate_scalar_with_status): Get the data member for coarrays
	only when freeing an array with descriptor.  And set correct caf_mode
	when freeing components of coarrays.
	* trans.h: Change prototype of gfc_deallocate_with_status to allow
	adding statements into the block guarded by the if (pointer != 0) and
	supply a coarray handle.

gcc/testsuite/ChangeLog:

2016-12-09  Andre Vehreschild  <vehre@gcc.gnu.org>

	* gfortran.dg/coarray_alloc_comp_3.f08: New test.
	* gfortran.dg/coarray_alloc_comp_4.f08: New test.
	* gfortran.dg/finalize_18.f90: Add count for additional guard against
	accessing null-pointer.
	* gfortran.dg/proc_ptr_comp_47.f90: New test.

From-SVN: r243480

gcc/fortran/ChangeLog

+2016-12-09  Andre Vehreschild  <vehre@gcc.gnu.org>
+
+	* trans-array.c (gfc_array_deallocate): Remove wrapper.
+	(gfc_trans_dealloc_allocated): Same.
+	(structure_alloc_comps): Restructure deallocation of (nested)
+	allocatable components.  Insert dealloc of sub-component into the block
+	guarded by the if != NULL for the component.
+	(gfc_trans_deferred_array): Use the almightly deallocate_with_status.
+	* trans-array.h: Remove prototypes.
+	* trans-expr.c (gfc_conv_procedure_call): Use the almighty deallocate_
+	with_status.
+	* trans-openmp.c (gfc_walk_alloc_comps): Likewise.
+	(gfc_omp_clause_assign_op): Likewise. 
+	(gfc_omp_clause_dtor): Likewise.
+	* trans-stmt.c (gfc_trans_deallocate): Likewise.
+	* trans.c (gfc_deallocate_with_status): Allow deallocation of scalar
+	and arrays as well as coarrays.
+	(gfc_deallocate_scalar_with_status): Get the data member for coarrays
+	only when freeing an array with descriptor.  And set correct caf_mode
+	when freeing components of coarrays.
+	* trans.h: Change prototype of gfc_deallocate_with_status to allow
+	adding statements into the block guarded by the if (pointer != 0) and
+	supply a coarray handle.
+
 2016-12-09  Paul Thomas  <pault@gcc.gnu.org>
 
 	PR fortran/44265

gcc/fortran/trans-array.h

@@ -18,9 +18,6 @@ You should have received a copy of the GNU General Public License
 along with GCC; see the file COPYING3.  If not see
 <http://www.gnu.org/licenses/>.  */
 
-/* Generate code to free an array.  */
-tree gfc_array_deallocate (tree, tree, tree, tree, tree, gfc_expr*, int c = -2);
-
 /* Generate code to initialize and allocate an array.  Statements are added to
    se, which should contain an expression for the array descriptor.  */
 bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, tree,
@@ -41,8 +38,6 @@ void gfc_trans_auto_array_allocation (tree, gfc_symbol *, gfc_wrapped_block *);
 void gfc_trans_dummy_array_bias (gfc_symbol *, tree, gfc_wrapped_block *);
 /* Generate entry and exit code for g77 calling convention arrays.  */
 void gfc_trans_g77_array (gfc_symbol *, gfc_wrapped_block *);
-/* Generate code to deallocate an array, if it is allocated.  */
-tree gfc_trans_dealloc_allocated (tree, gfc_expr *, int);
 
 tree gfc_full_array_size (stmtblock_t *, tree, int);
 

gcc/fortran/trans-expr.c

@@ -5451,8 +5451,12 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		{
 		  tmp = build_fold_indirect_ref_loc (input_location,
 						     parmse.expr);
-		  tmp = gfc_trans_dealloc_allocated (tmp, e,
-						     GFC_CAF_COARRAY_NOCOARRAY);
+		  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
+		    tmp = gfc_conv_descriptor_data_get (tmp);
+		  tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
+						    NULL_TREE, NULL_TREE, true,
+						    e,
+						    GFC_CAF_COARRAY_NOCOARRAY);
 		  if (fsym->attr.optional
 		      && e->expr_type == EXPR_VARIABLE
 		      && e->symtree->n.sym->attr.optional)

gcc/fortran/trans-openmp.c

@@ -420,8 +420,11 @@ gfc_walk_alloc_comps (tree decl, tree dest, tree var,
 	  if (GFC_DESCRIPTOR_TYPE_P (ftype)
 	      && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE)
 	    {
-	      tem = gfc_trans_dealloc_allocated (unshare_expr (declf), NULL,
-						 GFC_CAF_COARRAY_NOCOARRAY);
+	      tem = gfc_conv_descriptor_data_get (unshare_expr (declf));
+	      tem = gfc_deallocate_with_status (tem, NULL_TREE, NULL_TREE,
+						NULL_TREE, NULL_TREE, true,
+						NULL,
+						GFC_CAF_COARRAY_NOCOARRAY);
 	      gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (tem));
 	    }
 	  else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field))
@@ -810,10 +813,13 @@ gfc_omp_clause_assign_op (tree clause, tree dest, tree src)
     {
       gfc_init_block (&cond_block);
       if (GFC_DESCRIPTOR_TYPE_P (type))
-	gfc_add_expr_to_block (&cond_block,
-			       gfc_trans_dealloc_allocated (unshare_expr (dest),
-							    NULL,
-						    GFC_CAF_COARRAY_NOCOARRAY));
+	{
+	  tree tmp = gfc_conv_descriptor_data_get (unshare_expr (dest));
+	  tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
+					    NULL_TREE, NULL_TREE, true, NULL,
+					    GFC_CAF_COARRAY_NOCOARRAY);
+	  gfc_add_expr_to_block (&cond_block, tmp);
+	}
       else
 	{
 	  destptr = gfc_evaluate_now (destptr, &cond_block);
@@ -987,9 +993,14 @@ gfc_omp_clause_dtor (tree clause, tree decl)
     }
 
   if (GFC_DESCRIPTOR_TYPE_P (type))
-    /* Allocatable arrays in FIRSTPRIVATE/LASTPRIVATE etc. clauses need
-       to be deallocated if they were allocated.  */
-    tem = gfc_trans_dealloc_allocated (decl, NULL, GFC_CAF_COARRAY_NOCOARRAY);
+    {
+      /* Allocatable arrays in FIRSTPRIVATE/LASTPRIVATE etc. clauses need
+	 to be deallocated if they were allocated.  */
+      tem = gfc_conv_descriptor_data_get (decl);
+      tem = gfc_deallocate_with_status (tem, NULL_TREE, NULL_TREE, NULL_TREE,
+					NULL_TREE, true, NULL,
+					GFC_CAF_COARRAY_NOCOARRAY);
+    }
   else
     tem = gfc_call_free (decl);
   tem = gfc_omp_unshare_expr (tem);

gcc/fortran/trans-stmt.c

@@ -6489,8 +6489,9 @@ gfc_trans_deallocate (gfc_code *code)
 		    : GFC_CAF_COARRAY_DEREGISTER;
 	      else
 		caf_dtype = GFC_CAF_COARRAY_NOCOARRAY;
-	      tmp = gfc_array_deallocate (se.expr, pstat, errmsg, errlen,
-					  label_finish, expr, caf_dtype);
+	      tmp = gfc_deallocate_with_status (se.expr, pstat, errmsg, errlen,
+						label_finish, false, expr,
+						caf_dtype);
 	      gfc_add_expr_to_block (&se.pre, tmp);
 	    }
 	  else if (TREE_CODE (se.expr) == COMPONENT_REF

gcc/fortran/trans.c

@@ -1281,31 +1281,58 @@ tree
 gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
 			    tree errlen, tree label_finish,
 			    bool can_fail, gfc_expr* expr,
-			    int coarray_dealloc_mode)
+			    int coarray_dealloc_mode, tree add_when_allocated,
+			    tree caf_token)
 {
   stmtblock_t null, non_null;
   tree cond, tmp, error;
   tree status_type = NULL_TREE;
-  tree caf_decl = NULL_TREE;
+  tree token = NULL_TREE;
   gfc_coarray_deregtype caf_dereg_type = GFC_CAF_COARRAY_DEREGISTER;
 
   if (coarray_dealloc_mode >= GFC_CAF_COARRAY_ANALYZE)
     {
-      gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer)));
-      caf_decl = pointer;
-      pointer = gfc_conv_descriptor_data_get (caf_decl);
-      STRIP_NOPS (pointer);
-      if (coarray_dealloc_mode == GFC_CAF_COARRAY_ANALYZE)
+      if (flag_coarray == GFC_FCOARRAY_LIB)
 	{
-	  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.
+	  if (caf_token)
+	    token = caf_token;
+	  else
+	    {
+	      tree caf_type, caf_decl = pointer;
+	      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)
+		token = gfc_conv_descriptor_token (caf_decl);
+	      else if (DECL_LANG_SPECIFIC (caf_decl)
+		       && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
+		token = GFC_DECL_TOKEN (caf_decl);
+	      else
+		{
+		  gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
+			      && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type)
+				 != NULL_TREE);
+		  token = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
+		}
+	    }
+
+	  if (coarray_dealloc_mode == GFC_CAF_COARRAY_ANALYZE)
+	    {
+	      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.
+	    }
+	  else
+	    caf_dereg_type = (enum gfc_coarray_deregtype) coarray_dealloc_mode;
 	}
-      else
-	caf_dereg_type = (enum gfc_coarray_deregtype) coarray_dealloc_mode;
+      else if (flag_coarray == GFC_FCOARRAY_SINGLE)
+	pointer = gfc_conv_descriptor_data_get (pointer);
     }
+  else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer)))
+    pointer = gfc_conv_descriptor_data_get (pointer);
 
   cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer,
 			  build_int_cst (TREE_TYPE (pointer), 0));
@@ -1348,6 +1375,8 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
 
   /* When POINTER is not NULL, we free it.  */
   gfc_start_block (&non_null);
+  if (add_when_allocated)
+    gfc_add_expr_to_block (&non_null, add_when_allocated);
   gfc_add_finalizer_call (&non_null, expr);
   if (coarray_dealloc_mode == GFC_CAF_COARRAY_NOCOARRAY
       || flag_coarray != GFC_FCOARRAY_LIB)
@@ -1356,6 +1385,8 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
 				 builtin_decl_explicit (BUILT_IN_FREE), 1,
 				 fold_convert (pvoid_type_node, pointer));
       gfc_add_expr_to_block (&non_null, tmp);
+      gfc_add_modify (&non_null, pointer, build_int_cst (TREE_TYPE (pointer),
+							 0));
 
       if (status != NULL_TREE && !integer_zerop (status))
 	{
@@ -1378,8 +1409,7 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
     }
   else
     {
-      tree caf_type, token, cond2;
-      tree pstat = null_pointer_node;
+      tree cond2, pstat = null_pointer_node;
 
       if (errmsg == NULL_TREE)
 	{
@@ -1394,27 +1424,12 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
 	    errmsg = gfc_build_addr_expr (NULL_TREE, errmsg);
 	}
 
-      caf_type = TREE_TYPE (caf_decl);
-
       if (status != NULL_TREE && !integer_zerop (status))
 	{
 	  gcc_assert (status_type == integer_type_node);
 	  pstat = status;
 	}
 
-      if (GFC_DESCRIPTOR_TYPE_P (caf_type)
-	  && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
-	token = gfc_conv_descriptor_token (caf_decl);
-      else if (DECL_LANG_SPECIFIC (caf_decl)
-	       && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
-	token = GFC_DECL_TOKEN (caf_decl);
-      else
-	{
-	  gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
-		      && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
-	  token = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
-	}
-
       token = gfc_build_addr_expr  (NULL_TREE, token);
       gcc_assert (caf_dereg_type > GFC_CAF_COARRAY_ANALYZE);
       tmp = build_call_expr_loc (input_location,
@@ -1435,6 +1450,10 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
       if (status != NULL_TREE)
 	{
 	  tree stat = build_fold_indirect_ref_loc (input_location, status);
+	  tree nullify = fold_build2_loc (input_location, MODIFY_EXPR,
+					  void_type_node, pointer,
+					  build_int_cst (TREE_TYPE (pointer),
+							 0));
 
 	  TREE_USED (label_finish) = 1;
 	  tmp = build1_v (GOTO_EXPR, label_finish);
@@ -1442,9 +1461,12 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg,
 				   stat, build_zero_cst (TREE_TYPE (stat)));
 	  tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
 				 gfc_unlikely (cond2, PRED_FORTRAN_REALLOC),
-				 tmp, build_empty_stmt (input_location));
+				 tmp, nullify);
 	  gfc_add_expr_to_block (&non_null, tmp);
 	}
+      else
+	gfc_add_modify (&non_null, pointer, build_int_cst (TREE_TYPE (pointer),
+							   0));
     }
 
   return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
@@ -1516,11 +1538,17 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, tree label_finish,
   finalizable = gfc_add_finalizer_call (&non_null, expr);
   if (!finalizable && ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
     {
-      if (coarray)
+      int caf_mode = coarray
+	  ? ((caf_dereg_type == GFC_CAF_COARRAY_DEALLOCATE_ONLY
+	      ? GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY : 0)
+	     | GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY
+	     | GFC_STRUCTURE_CAF_MODE_IN_COARRAY)
+	  : 0;
+      if (coarray && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer)))
 	tmp = gfc_conv_descriptor_data_get (pointer);
       else
 	tmp = build_fold_indirect_ref_loc (input_location, pointer);
-      tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
+      tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0, caf_mode);
       gfc_add_expr_to_block (&non_null, tmp);
     }
 
@@ -1573,7 +1601,7 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, tree label_finish,
       gfc_add_expr_to_block (&non_null, tmp);
 
       /* It guarantees memory consistency within the same segment.  */
-      tmp = gfc_build_string_const (strlen ("memory")+1, "memory"),
+      tmp = gfc_build_string_const (strlen ("memory")+1, "memory");
       tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
 			gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
 			tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);

gcc/fortran/trans.h

@@ -719,7 +719,8 @@ void gfc_allocate_using_malloc (stmtblock_t *, tree, tree, tree);
 
 /* Generate code to deallocate an array.  */
 tree gfc_deallocate_with_status (tree, tree, tree, tree, tree, bool,
-				 gfc_expr *, int);
+				 gfc_expr *, int, tree a = NULL_TREE,
+				 tree c = NULL_TREE);
 tree gfc_deallocate_scalar_with_status (tree, tree, tree, bool, gfc_expr*,
 					gfc_typespec, bool c = false);
 

gcc/testsuite/ChangeLog

+2016-12-09  Andre Vehreschild  <vehre@gcc.gnu.org>
+
+	* gfortran.dg/coarray_alloc_comp_3.f08: New test.
+	* gfortran.dg/coarray_alloc_comp_4.f08: New test.
+	* gfortran.dg/finalize_18.f90: Add count for additional guard against
+	accessing null-pointer.
+	* gfortran.dg/proc_ptr_comp_47.f90: New test.
+
 2016-12-09  Nathan Sidwell  <nathan@acm.org>
 
 	PR c++/78550

gcc/testsuite/gfortran.dg/coarray_alloc_comp_3.f08

+! { dg-do run }
+! { dg-options "-fcoarray=lib -lcaf_single" }
+!
+! Contributed by Andre Vehreschild
+! Check that manually freeing components does not lead to a runtime crash,
+! when the auto-deallocation is taking care.
+
+program coarray_alloc_comp_3
+  implicit none
+
+  type dt
+    integer, allocatable :: i
+  end type dt
+
+  type linktype
+    type(dt), allocatable :: link
+  end type linktype
+
+  type(linktype), allocatable :: obj[:]
+
+  allocate(obj[*])
+  allocate(obj%link)
+
+  if (.not. allocated(obj)) error stop "Test failed. 'obj' not allocated."
+  if (.not. allocated(obj%link)) error stop "Test failed. 'obj%link' not allocated."
+  if (allocated(obj%link%i)) error stop "Test failed. 'obj%link%i' already allocated."
+
+  allocate(obj%link%i, source = 42)
+
+  if (.not. allocated(obj)) error stop "Test failed. 'obj' not allocated."
+  if (.not. allocated(obj%link)) error stop "Test failed. 'obj%link' not allocated."
+  if (.not. allocated(obj%link%i)) error stop "Test failed. 'obj%link%i' not allocated."
+  if (obj%link%i /= 42) error stop "Test failed. obj%link%i /= 42."
+
+  deallocate(obj%link%i)
+
+  if (allocated(obj%link%i)) error stop "Test failed. 'obj%link%i' still allocated."
+  if (.not. allocated(obj%link)) error stop "Test failed. 'obj%link' no longer allocated."
+  if (.not. allocated(obj)) error stop "Test failed. 'obj' no longer allocated."
+
+  ! Freeing this object, lead to crash with older gfortran...
+  deallocate(obj%link)
+
+  if (allocated(obj%link)) error stop "Test failed. 'obj%link' still allocated."
+  if (.not. allocated(obj)) error stop "Test failed. 'obj' no longer allocated."
+
+  ! ... when auto-deallocating the allocated components.
+  deallocate(obj)
+
+  if (allocated(obj)) error stop "Test failed. 'obj' still allocated."
+end program

gcc/testsuite/gfortran.dg/coarray_alloc_comp_4.f08

+! { dg-do compile }
+! { dg-options "-fcoarray=lib -fdump-tree-original" }
+!
+! Contributed by Andre Vehreschild
+! Check that sub-components are caf_deregistered and not freed.
+
+program coarray_alloc_comp_3
+  implicit none
+
+  type dt
+    integer, allocatable :: i
+  end type dt
+
+  type linktype
+    type(dt), allocatable :: link
+  end type linktype
+
+  type(linktype) :: obj[*]
+
+  allocate(obj%link)
+
+  if (.not. allocated(obj%link)) error stop "Test failed. 'obj%link' not allocated."
+  if (allocated(obj%link%i)) error stop "Test failed. 'obj%link%i' already allocated."
+
+  allocate(obj%link%i, source = 42)
+
+  if (.not. allocated(obj%link)) error stop "Test failed. 'obj%link' not allocated."
+  if (.not. allocated(obj%link%i)) error stop "Test failed. 'obj%link%i' not allocated."
+  if (obj%link%i /= 42) error stop "Test failed. obj%link%i /= 42."
+
+  deallocate(obj%link%i)
+
+  if (allocated(obj%link%i)) error stop "Test failed. 'obj%link%i' still allocated."
+  if (.not. allocated(obj%link)) error stop "Test failed. 'obj%link' no longer allocated."
+
+  ! Freeing this object, lead to crash with older gfortran...
+  deallocate(obj%link)
+
+  if (allocated(obj%link)) error stop "Test failed. 'obj%link' still allocated."
+end program
+! Ensure, that three calls to deregister are present.
+! { dg-final { scan-tree-dump-times "_caf_deregister" 3 "original" } }
+! And ensure that no calls to builtin_free are made.
+! { dg-final { scan-tree-dump-not "_builtin_free" "original" } }

gcc/testsuite/gfortran.dg/finalize_18.f90

@@ -33,8 +33,8 @@ end
 
 ! { dg-final { scan-tree-dump-times "if \\(y.aa != 0B\\)" 2 "original" } }
 ! { dg-final { scan-tree-dump-times "if \\(y.cc._data != 0B\\)" 2 "original" } }
-! { dg-final { scan-tree-dump-times "if \\(\\(struct t\\\[0:\\\] . restrict\\) y.bb.data != 0B\\)" 1 "original" } }
-! { dg-final { scan-tree-dump-times "if \\(\\(struct t\\\[0:\\\] . restrict\\) y.dd._data.data != 0B\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "if \\(\\(struct t\\\[0:\\\] . restrict\\) y.bb.data != 0B\\)" 2 "original" } }
+! { dg-final { scan-tree-dump-times "if \\(\\(struct t\\\[0:\\\] . restrict\\) y.dd._data.data != 0B\\)" 2 "original" } }
 
 ! { dg-final { scan-tree-dump-times "desc.\[0-9\]+.data = \\(void . restrict\\) y.aa;" 1 "original" } }
 ! { dg-final { scan-tree-dump-times "desc.\[0-9\]+.data = \\(void . restrict\\) y.cc._data;" 1 "original" } }

gcc/testsuite/gfortran.dg/proc_ptr_comp_47.f90

+! { dg-do run }
+
+MODULE distribution_types
+  ABSTRACT INTERFACE
+     FUNCTION dist_map_blk_to_proc_func ( row, col, nrow_tot, ncol_tot, proc_grid ) RESULT( reslt )
+       INTEGER, INTENT( IN ) :: row, col, nrow_tot, ncol_tot
+       INTEGER, DIMENSION( : ), INTENT( IN ) :: proc_grid
+       INTEGER, DIMENSION( : ), ALLOCATABLE :: reslt
+     END FUNCTION dist_map_blk_to_proc_func
+  END INTERFACE
+  TYPE, PUBLIC :: dist_type
+     INTEGER, DIMENSION( : ), ALLOCATABLE :: task_coords
+     PROCEDURE( dist_map_blk_to_proc_func ), NOPASS, POINTER :: map_blk_to_proc => NULL( )
+  END TYPE dist_type
+END MODULE distribution_types
+
+MODULE sparse_matrix_types
+  USE distribution_types,  ONLY : dist_type
+  TYPE, PUBLIC :: sm_type
+     TYPE( dist_type ) :: dist
+  END TYPE sm_type
+END MODULE sparse_matrix_types
+
+PROGRAM comp_proc_ptr_test
+  USE sparse_matrix_types,      ONLY : sm_type
+
+ call  sm_multiply_a ()
+CONTAINS
+  SUBROUTINE sm_multiply_a (  )
+    INTEGER :: n_push_tot, istat
+    TYPE( sm_type ), DIMENSION( : ), ALLOCATABLE :: matrices_a, matrices_b
+    n_push_tot =2
+    ALLOCATE( matrices_a( n_push_tot + 1 ), matrices_b( n_push_tot + 1), STAT=istat )
+    if (istat /= 0) call abort()
+    if (.not. allocated(matrices_a)) call abort()
+    if (.not. allocated(matrices_b)) call abort()
+    if (associated(matrices_a(1)%dist%map_blk_to_proc)) call abort()
+  END SUBROUTINE sm_multiply_a
+END PROGRAM comp_proc_ptr_test
+