This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

Re: [Patch, fortran, PR44672, v2] [F08] ALLOCATE with SOURCE and no array-spec


Hi all,

during debugging another fortran code, I figured that some cases were not yet
met. Especially the case where a class array is in the source= or mold=
expression. This new version of the patch fixes the issue now.

Bootstraps and regtests ok on x86_64-linux-gnu/F20.

Ok for 5.2 trunk?

Regards,
	Andre

On Mon, 30 Mar 2015 19:47:49 +0200
Andre Vehreschild <vehre@gmx.de> wrote:

> Dear all,
> 
> please find attach a patch fixing pr44672:
> 
> integer, dimension(:) :: arr
> allocate(arr, source = [1,2,3])
> 
> as for F2008:C633 now is no longer flagged, beside when you insist on
> -std=f2003 or lower. Furthermore does the patch implement the F2008 feature of
> obsoleting the explicit array specification on the arrays to allocate, when
> an array valued source=/mold= expression is given.
> 
> Bootstrap and regtests ok on x86_64-linux-gnu/F20.
> 
> This batched is based on a trunk having my latest for pr60322 patched in (else
> deltas may occur).
> 
> Ok for 5.2 trunk?
> 
> Regards,
> 	Andre


-- 
Andre Vehreschild * Email: vehre ad gmx dot de 

Attachment: pr44672_2.clog
Description: Binary data

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 643cd6a..9835edc 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2394,6 +2394,9 @@ typedef struct gfc_code
     {
       gfc_typespec ts;
       gfc_alloc *list;
+      /* Take the array specification from expr3 to allocate arrays
+	 without an explicit array specification.  */
+      unsigned arr_spec_from_expr3:1;
     }
     alloc;
 
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 316b413..ce2e29e 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -6804,7 +6804,7 @@ conformable_arrays (gfc_expr *e1, gfc_expr *e2)
    have a trailing array reference that gives the size of the array.  */
 
 static bool
-resolve_allocate_expr (gfc_expr *e, gfc_code *code)
+resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec)
 {
   int i, pointer, allocatable, dimension, is_abstract;
   int codimension;
@@ -7103,9 +7103,20 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
   if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
       || (dimension && ref2->u.ar.dimen == 0))
     {
-      gfc_error ("Array specification required in ALLOCATE statement "
-		 "at %L", &e->where);
-      goto failure;
+      /* F08:C633.  */
+      if (code->expr3)
+	{
+	  if (!gfc_notify_std (GFC_STD_F2008, "Array specification required "
+			       "in ALLOCATE statement at %L", &e->where))
+	    goto failure;
+	  *array_alloc_wo_spec = true;
+	}
+      else
+	{
+	  gfc_error ("Array specification required in ALLOCATE statement "
+		     "at %L", &e->where);
+	  goto failure;
+	}
     }
 
   /* Make sure that the array section reference makes sense in the
@@ -7124,7 +7135,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
 
   for (i = 0; i < ar->dimen; i++)
     {
-      if (ref2->u.ar.type == AR_ELEMENT)
+      if (ar->type == AR_ELEMENT || ar->type == AR_FULL)
 	goto check_symbols;
 
       switch (ar->dimen_type[i])
@@ -7375,8 +7386,103 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn)
 
   if (strcmp (fcn, "ALLOCATE") == 0)
     {
+      bool arr_alloc_wo_spec = false;
       for (a = code->ext.alloc.list; a; a = a->next)
-	resolve_allocate_expr (a->expr, code);
+	resolve_allocate_expr (a->expr, code, &arr_alloc_wo_spec);
+
+      if (arr_alloc_wo_spec && code->expr3)
+	{
+	  /* Mark the allocate to have to take the array specification
+	     from the expr3.  */
+	  code->ext.alloc.arr_spec_from_expr3 = 1;
+
+	  if (code->expr3->expr_type == EXPR_ARRAY
+	      || code->expr3->expr_type == EXPR_FUNCTION)
+	    {
+	      /* The trans stage can not cope with expr3->expr_type
+	     being EXPR_ARRAY or EXPR_FUNCTION, therefore create a
+	     temporary variable and assign expr3 to it, substituting
+	     the variable in expr3.  */
+	      char name[25];
+	      static unsigned int alloc_sym_count = 0;
+	      gfc_symbol *temp_var_sym;
+	      gfc_expr *temp_var;
+	      gfc_code *ass, *iter;
+	      gfc_namespace *ns = code->ext.alloc.list->expr->symtree->n.sym->ns;
+	      gfc_array_spec *as;
+	      int dim;
+	      mpz_t dim_size;
+
+	      /* The name of the new variable.  */
+	      sprintf (name, "alloc_arr_init.%d", alloc_sym_count++);
+	      gfc_get_symbol (name, ns, &temp_var_sym);
+	      temp_var_sym->attr.artificial = 1;
+	      temp_var_sym->attr.flavor = FL_VARIABLE;
+	      temp_var_sym->ts = code->expr3->ts;
+	      /* Build an EXPR_VARIABLE node.  */
+	      temp_var = gfc_get_expr ();
+	      temp_var->expr_type = EXPR_VARIABLE;
+	      temp_var->symtree = gfc_find_symtree (ns->sym_root, name);
+	      temp_var->ts = code->expr3->ts;
+	      temp_var->where = code->expr3->where;
+
+	      /* Now to the most important: Set the array specification
+	     correctly.  */
+	      as = gfc_get_array_spec ();
+	      temp_var->rank = as->rank = code->expr3->rank;
+	      if (code->expr3->expr_type == EXPR_ARRAY)
+		{
+		  /* For EXPR_ARRAY the as can be deduced from the shape.  */
+		  as->type = AS_EXPLICIT;
+		  for (dim = 0; dim < as->rank; ++dim)
+		    {
+		      gfc_array_dimen_size (code->expr3, dim, &dim_size);
+		      as->lower[dim] = gfc_get_int_expr (gfc_index_integer_kind,
+							 &code->expr3->where, 1);
+		      as->upper[dim] = gfc_get_int_expr (gfc_index_integer_kind,
+							 &code->expr3->where,
+							 mpz_get_si (dim_size));
+		    }
+		}
+	      else if (code->expr3->expr_type == EXPR_FUNCTION)
+		{
+		  /* For functions this is far more complicated.  */
+		  as->type = AS_DEFERRED;
+		  temp_var_sym->attr.allocatable = 1;
+		}
+	      else
+		gcc_unreachable ();
+
+	      temp_var_sym->as = as;
+	      temp_var_sym->attr.dimension = 1;
+	      gfc_add_full_array_ref (temp_var, as);
+
+	      ass = gfc_get_code (EXEC_ASSIGN);
+	      ass->expr1 = gfc_copy_expr (temp_var);
+	      ass->expr2 = code->expr3;
+	      ass->loc = code->expr3->where;
+
+	      gfc_resolve_code (ass, ns);
+	      /* Now add the new code before this ones.  */
+	      iter = ns->code;
+	      /* At least one code has to be present in the ns, this one.  */
+	      if (iter == code)
+		ns->code = ass;
+	      else
+		{
+		  while (iter->next && iter->next != code)
+		    iter = iter->next;
+		  gcc_assert (iter->next);
+		  iter->next = ass;
+		}
+	      ass->next = code;
+
+	      /* Do not gfc_free_expr (temp_var), because it is inserted
+	     without copy into expr3.  */
+	      code->expr3 = temp_var;
+	      gfc_set_sym_referenced (temp_var_sym);
+	    }
+	}
     }
   else
     {
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 0804d45..f1db69c 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -4981,7 +4981,8 @@ static tree
 gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
 		     gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
 		     stmtblock_t * descriptor_block, tree * overflow,
-		     tree expr3_elem_size, tree *nelems, gfc_expr *expr3)
+		     tree expr3_elem_size, tree *nelems, gfc_expr *expr3,
+		     tree expr3_desc)
 {
   tree type;
   tree tmp;
@@ -5024,20 +5025,25 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
 
       /* Set lower bound.  */
       gfc_init_se (&se, NULL);
-      if (lower == NULL)
-	se.expr = gfc_index_one_node;
+      if (expr3_desc != NULL_TREE)
+	se.expr = gfc_conv_descriptor_lbound_get (expr3_desc, gfc_rank_cst[n]);
       else
 	{
-	  gcc_assert (lower[n]);
-	  if (ubound)
-	    {
-	      gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
-	      gfc_add_block_to_block (pblock, &se.pre);
-	    }
+	  if (lower == NULL)
+	    se.expr = gfc_index_one_node;
 	  else
 	    {
-	      se.expr = gfc_index_one_node;
-	      ubound = lower[n];
+	      gcc_assert (lower[n]);
+	      if (ubound)
+		{
+		  gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
+		  gfc_add_block_to_block (pblock, &se.pre);
+		}
+	      else
+		{
+		  se.expr = gfc_index_one_node;
+		  ubound = lower[n];
+		}
 	    }
 	}
       gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
@@ -5052,10 +5058,14 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
 
       /* Set upper bound.  */
       gfc_init_se (&se, NULL);
-      gcc_assert (ubound);
-      gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
-      gfc_add_block_to_block (pblock, &se.pre);
-
+      if (expr3_desc != NULL_TREE)
+	se.expr = gfc_conv_descriptor_ubound_get (expr3_desc, gfc_rank_cst[n]);
+      else
+	{
+	  gcc_assert (ubound);
+	  gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
+	  gfc_add_block_to_block (pblock, &se.pre);
+	}
       gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
 				      gfc_rank_cst[n], se.expr);
       conv_ubound = se.expr;
@@ -5225,6 +5235,33 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
 }
 
 
+/* Retrieve the last ref from the chain.  This routine is specific to
+   gfc_array_allocate ()'s needs.  */
+
+bool
+retrieve_last_ref (gfc_ref **ref_in, gfc_ref **prev_ref_in)
+{
+  gfc_ref *ref, *prev_ref;
+
+  ref = *ref_in;
+  /* Prevent warnings for uninitialized variables.  */
+  prev_ref = *prev_ref_in;
+  while (ref && ref->next != NULL)
+    {
+      gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
+		  || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
+      prev_ref = ref;
+      ref = ref->next;
+    }
+
+  if (ref == NULL || ref->type != REF_ARRAY)
+    return false;
+
+  *ref_in = ref;
+  *prev_ref_in = prev_ref;
+  return true;
+}
+
 /* Initializes the descriptor and generates a call to _gfor_allocate.  Does
    the work for an ALLOCATE statement.  */
 /*GCC ARRAYS*/
@@ -5232,7 +5269,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
 bool
 gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
 		    tree errlen, tree label_finish, tree expr3_elem_size,
-		    tree *nelems, gfc_expr *expr3)
+		    tree *nelems, gfc_expr *expr3, tree e3_arr_desc)
 {
   tree tmp;
   tree pointer;
@@ -5250,21 +5287,24 @@ 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;
-  bool allocatable, coarray, dimension;
+  bool allocatable, coarray, dimension, alloc_w_e3_arr_spec = false;
 
   ref = expr->ref;
 
   /* Find the last reference in the chain.  */
-  while (ref && ref->next != NULL)
+  if (!retrieve_last_ref (&ref, &prev_ref))
+    return false;
+
+  if (ref->u.ar.type == AR_FULL && expr3 != NULL)
     {
-      gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
-		  || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
-      prev_ref = ref;
-      ref = ref->next;
-    }
+      /* F08:C633: Array shape from expr3.  */
+      ref = expr3->ref;
 
-  if (ref == NULL || ref->type != REF_ARRAY)
-    return false;
+      /* Find the last reference in the chain.  */
+      if (!retrieve_last_ref (&ref, &prev_ref))
+	return false;
+      alloc_w_e3_arr_spec = true;
+    }
 
   if (!prev_ref)
     {
@@ -5300,7 +5340,8 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
       break;
 
     case AR_FULL:
-      gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
+      gcc_assert (ref->u.ar.as->type == AS_EXPLICIT
+		  || alloc_w_e3_arr_spec);
 
       lower = ref->u.ar.as->lower;
       upper = ref->u.ar.as->upper;
@@ -5317,7 +5358,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
   size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
 			      ref->u.ar.as->corank, &offset, lower, upper,
 			      &se->pre, &set_descriptor_block, &overflow,
-			      expr3_elem_size, nelems, expr3);
+			      expr3_elem_size, nelems, expr3, e3_arr_desc);
 
   if (dimension)
     {
@@ -7054,6 +7095,16 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
       desc = parm;
     }
 
+  /* For class arrays add the class tree into the saved descriptor to
+     enable getting of _vptr and the like.  */
+  if (expr->expr_type == EXPR_VARIABLE && VAR_P (desc)
+      && IS_CLASS_ARRAY (expr->symtree->n.sym)
+      && DECL_LANG_SPECIFIC (expr->symtree->n.sym->backend_decl))
+    {
+      gfc_allocate_lang_decl (desc);
+      GFC_DECL_SAVED_DESCRIPTOR (desc) =
+	  GFC_DECL_SAVED_DESCRIPTOR (expr->symtree->n.sym->backend_decl);
+    }
   if (!se->direct_byref || se->byref_noassign)
     {
       /* Get a pointer to the new descriptor.  */
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 8544534..389a644 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -24,7 +24,7 @@ tree gfc_array_deallocate (tree, tree, tree, tree, tree, gfc_expr*);
 /* 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,
-			 tree, tree *, gfc_expr *);
+			 tree, tree *, gfc_expr *, tree);
 
 /* Allow the bounds of a loop to be set from a callee's array spec.  */
 void gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping *,
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 68b343b..060af8f 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -4974,7 +4974,7 @@ gfc_trans_allocate (gfc_code * code)
      element size, i.e. _vptr%size, is stored in expr3_esize.  Any of
      the trees may be the NULL_TREE indicating that this is not
      available for expr3's type.  */
-  tree expr3, expr3_vptr, expr3_len, expr3_esize;
+  tree expr3, expr3_vptr, expr3_len, expr3_esize, expr3_desc;
   stmtblock_t block;
   stmtblock_t post;
   tree nelems;
@@ -4986,6 +4986,7 @@ gfc_trans_allocate (gfc_code * code)
   stat = tmp = memsz = al_vptr = al_len = NULL_TREE;
   expr3 = expr3_vptr = expr3_len = expr3_esize = NULL_TREE;
   label_errmsg = label_finish = errmsg = errlen = NULL_TREE;
+  expr3_desc = NULL_TREE;
 
   gfc_init_block (&block);
   gfc_init_block (&post);
@@ -5040,12 +5041,13 @@ gfc_trans_allocate (gfc_code * code)
 
       /* A array expr3 needs the scalarizer, therefore do not process it
 	 here.  */
-      if (code->expr3->expr_type != EXPR_ARRAY
-	  && (code->expr3->rank == 0
-	      || code->expr3->expr_type == EXPR_FUNCTION)
-	  && (!code->expr3->symtree
-	      || !code->expr3->symtree->n.sym->as)
-	  && !gfc_is_class_array_ref (code->expr3, NULL))
+      if (code->ext.alloc.arr_spec_from_expr3
+	  || (code->expr3->expr_type != EXPR_ARRAY
+	      && (code->expr3->rank == 0
+		  || code->expr3->expr_type == EXPR_FUNCTION)
+	      && (!code->expr3->symtree
+		  || !code->expr3->symtree->n.sym->as)
+	      && !gfc_is_class_array_ref (code->expr3, NULL)))
 	{
 	  /* When expr3 is a variable, i.e., a very simple expression,
 	     then convert it once here.  */
@@ -5054,17 +5056,26 @@ gfc_trans_allocate (gfc_code * code)
 	    {
 	      if (!code->expr3->mold
 		  || code->expr3->ts.type == BT_CHARACTER
-		  || vtab_needed)
+		  || vtab_needed
+		  || code->ext.alloc.arr_spec_from_expr3)
 		{
 		  /* Convert expr3 to a tree.  */
 		  gfc_init_se (&se, NULL);
-		  se.want_pointer = 1;
-		  gfc_conv_expr (&se, code->expr3);
-		  if (!code->expr3->mold)
-		    expr3 = se.expr;
+		  if (code->ext.alloc.arr_spec_from_expr3)
+		    {
+		      gfc_conv_expr_descriptor (&se, code->expr3);
+		      expr3_desc = se.expr;
+		    }
 		  else
-		    expr3_tmp = se.expr;
-		  expr3_len = se.string_length;
+		    {
+		      se.want_pointer = 1;
+		      gfc_conv_expr (&se, code->expr3);
+		      if (!code->expr3->mold)
+			expr3 = se.expr;
+		      else
+			expr3_tmp = se.expr;
+		      expr3_len = se.string_length;
+		    }
 		  gfc_add_block_to_block (&block, &se.pre);
 		  gfc_add_block_to_block (&post, &se.post);
 		}
@@ -5102,6 +5113,10 @@ gfc_trans_allocate (gfc_code * code)
 		expr3 = tmp;
 	      else
 		expr3_tmp = tmp;
+	      /* Insert this check for security reasons.  A array descriptor
+		 for a complicated expr3 is very unlikely.  */
+	      if (code->ext.alloc.arr_spec_from_expr3)
+		gcc_unreachable ();
 	      /* When he length of a char array is easily available
 		 here, fix it for future use.  */
 	      if (se.string_length)
@@ -5297,7 +5312,8 @@ gfc_trans_allocate (gfc_code * code)
       else
 	tmp = expr3_esize;
       if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen,
-			       label_finish, tmp, &nelems, code->expr3))
+			       label_finish, tmp, &nelems,
+			       code->expr3, expr3_desc))
 	{
 	  /* A scalar or derived type.  First compute the size to
 	     allocate.
@@ -5501,17 +5517,25 @@ gfc_trans_allocate (gfc_code * code)
 	  /* Initialization via SOURCE block
 	     (or static default initializer).  */
 	  gfc_expr *rhs = gfc_copy_expr (code->expr3);
-	  if (expr3 != NULL_TREE
-	      && ((POINTER_TYPE_P (TREE_TYPE (expr3))
-		   && TREE_CODE (expr3) != POINTER_PLUS_EXPR)
-		  || VAR_P (expr3))
+	  if (((expr3 != NULL_TREE
+		&& ((POINTER_TYPE_P (TREE_TYPE (expr3))
+		     && TREE_CODE (expr3) != POINTER_PLUS_EXPR)
+		    || VAR_P (expr3)))
+	       || expr3_desc != NULL_TREE)
 	      && code->expr3->ts.type == BT_CLASS
 	      && (expr->ts.type == BT_CLASS
 		  || expr->ts.type == BT_DERIVED))
 	    {
-	      tree to;
+	      /* copy_class_to_class can be used for class arrays, too.
+		 It just needs to be ensured, that the decl_saved_descriptor
+		 has a way to get to the vptr.  */
+	      tree to, from;
 	      to = VAR_P (se.expr) ? se.expr : TREE_OPERAND (se.expr, 0);
-	      tmp = gfc_copy_class_to_class (expr3, to,
+	      /* Only use the array descriptor in expr3_desc, when it is
+		 set and not in a mold= expression.  */
+	      from = expr3_desc == NULL_TREE || code->expr3->mold ?
+		    expr3 : GFC_DECL_SAVED_DESCRIPTOR (expr3_desc);
+	      tmp = gfc_copy_class_to_class (from, to,
 					     nelems, upoly_expr);
 	    }
 	  else if (code->expr3->ts.type == BT_CHARACTER)
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90
index f7e0109..59d08d6 100644
--- a/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90
@@ -1,28 +1,110 @@
-! { dg-do compile }
+! { dg-do run }
 !
 ! Contributed by Reinhold Bader
 !
 program assumed_shape_01
-  use, intrinsic :: iso_c_binding
   implicit none
-  type, bind(c) :: cstruct
-     integer(c_int) :: i
-     real(c_float) :: r(2)
+  type :: cstruct
+     integer :: i
+     real :: r(2)
   end type cstruct
-  interface
-     subroutine psub(this, that) bind(c, name='Psub')
-       import :: c_float, cstruct
-       real(c_float) :: this(:,:)
-       type(cstruct) :: that(:)
-     end subroutine psub
-  end interface
-
-  real(c_float) :: t(3,7)
+
   type(cstruct), pointer :: u(:)
+  integer, allocatable :: iv(:), iv2(:)
+  integer, allocatable :: im(:,:)
+  integer, parameter :: cim(2,3) = reshape([1,2,3, 2,3,4], [2,3])
+  integer :: i
+  integer, parameter :: lcim(2,10) = reshape([(i, i=1,10),(i,i=1,10)], [2,10])
+
+  allocate(iv, source= [ 1, 2, 3, 4])
+  if (any(iv /= [ 1, 2, 3, 4])) call abort()
+  deallocate(iv)
+
+  allocate(iv, source=(/(i, i=1,10)/))
+  if (any(iv /= (/(i, i=1,10)/))) call abort()
+
+  ! Now 2D
+  allocate(im, source= cim)
+  if (any(im /= cim)) call abort()
+  deallocate(im)
+
+  allocate(im, source= reshape([iv, iv], [2, size(iv, 1)]))
+  if (any(im /= lcim)) call abort()
+  deallocate(im)
+  deallocate(iv)
+
+  allocate(u, source=[cstruct( 4, [1.1,2.2] )] )
+  if (u(1)%i /= 4 .or. any(abs(u(1)%r(:) - [1.1,2.2]) > 1E-6)) call abort()
+  deallocate (u)
 
-! The following is VALID Fortran 2008 but NOT YET supported 
-  allocate(u, source=[cstruct( 4, [1.1,2.2] ) ]) ! { dg-error "Array specification required in ALLOCATE statement" }
-  call psub(t, u)
+  allocate(iv, source= arrval())
+  if (any(iv /= [ 1, 2, 4, 5, 6])) call abort()
+  ! Check simple array assign
+  allocate(iv2, source=iv)
+  if (any(iv2 /= [ 1, 2, 4, 5, 6])) call abort()
+  deallocate(iv, iv2)
+
+  ! Now check for mold=
+  allocate(iv, mold= [ 1, 2, 3, 4])
+  if (any(shape(iv) /= [4])) call abort()
+  deallocate(iv)
+
+  allocate(iv, mold=(/(i, i=1,10)/))
+  if (any(shape(iv) /= [10])) call abort()
+
+  ! Now 2D
+  allocate(im, mold= cim)
+  if (any(shape(im) /= shape(cim))) call abort()
+  deallocate(im)
+
+  allocate(im, mold= reshape([iv, iv], [2, size(iv, 1)]))
+  if (any(shape(im) /= shape(lcim))) call abort()
+  deallocate(im)
+  deallocate(iv)
+
+  allocate(u, mold=[cstruct( 4, [1.1,2.2] )] )
+  if (any(shape(u(1)%r(:)) /= 2)) call abort()
   deallocate (u)
 
+  allocate(iv, mold= arrval())
+  if (any(shape(iv) /= [5])) call abort()
+  ! Check simple array assign
+  allocate(iv2, mold=iv)
+  if (any(shape(iv2) /= [5])) call abort()
+  deallocate(iv, iv2)
+
+  call addData([4, 5])
+  call addData(["foo", "bar"])
+contains
+  function arrval()
+    integer, dimension(5) :: arrval
+    arrval = [ 1, 2, 4, 5, 6]
+  end function
+
+  subroutine addData(P)
+    class(*), intent(in) :: P(:)
+    class(*), allocatable :: cP(:)
+    allocate (cP, source= P)
+    select type (cP)
+      type is (integer)
+        if (any(cP /= [4,5])) call abort()
+      type is (character(*))
+        if (len(cP) /= 3) call abort()
+        if (any(cP /= ["foo", "bar"])) call abort()
+      class default
+        call abort()
+    end select
+    deallocate (cP)
+    allocate (cP, mold= P)
+    select type (cP)
+      type is (integer)
+        if (any(size(cP) /= [2])) call abort()
+      type is (character(*))
+        if (len(cP) /= 3) call abort()
+        if (any(size(cP) /= [2])) call abort()
+      class default
+        call abort()
+    end select
+    deallocate (cP)
+  end subroutine
 end program assumed_shape_01

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]