re PR fortran/44672 ([F08] ALLOCATE with SOURCE and no array-spec)

gcc/testsuite/ChangeLog:

2015-06-15  Andre Vehreschild  <vehre@gmx.de>

	PR fortran/44672
	PR fortran/45440
	PR fortran/57307
	* gfortran.dg/allocate_with_source_3.f90: Removed check for
	unimplemented error.
	* gfortran.dg/allocate_with_source_7.f08: New test.
	* gfortran.dg/allocate_with_source_8.f08: New test.

gcc/fortran/ChangeLog:

2015-06-15  Andre Vehreschild  <vehre@gmx.de>

	PR fortran/44672
	PR fortran/45440
	PR fortran/57307
	* gfortran.h: Extend gfc_code.ext.alloc to carry a
	flag indicating that the array specification has to be
	taken from expr3.
	* resolve.c (resolve_allocate_expr): Add F2008 notify
	and flag indicating source driven array spec.
	(resolve_allocate_deallocate): Check for source driven
	array spec, when array to allocate has no explicit
	array spec.
	* trans-array.c (gfc_array_init_size): Get lower and
	upper bound from a tree array descriptor, except when
	the source expression is an array-constructor which is
	fixed to be one-based.
	(retrieve_last_ref): Extracted from gfc_array_allocate().
	(gfc_array_allocate): Enable allocate(array, source= 
	array_expression) as specified by F2008:C633.
	(gfc_conv_expr_descriptor): Add class tree expression
	into the saved descriptor for class arrays.
	* trans-array.h: Add temporary array descriptor to
	gfc_array_allocate ().
	* trans-expr.c (gfc_conv_procedure_call): Special handling
	for _copy() routine translation, that comes without an
	interface. Third and fourth argument are now passed by value.
	* trans-stmt.c (gfc_trans_allocate): Get expr3 array
	descriptor for temporary arrays to allow allocate(array,
	source = array_expression) for array without array
	specification.

From-SVN: r224477

1 files changed, 19 insertions, 4 deletions

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index e3f49f5..77d2cda 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -4561,6 +4561,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
   int has_alternate_specifier = 0;
   bool need_interface_mapping;
   bool callee_alloc;
+  bool ulim_copy;
   gfc_typespec ts;
   gfc_charlen cl;
   gfc_expr *e;
@@ -4569,6 +4570,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
   enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
   gfc_component *comp = NULL;
   int arglen;
+  unsigned int argc;
 
   arglist = NULL;
   retargs = NULL;
@@ -4624,10 +4626,16 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
     }
 
   base_object = NULL_TREE;
+  /* For _vprt->_copy () routines no formal symbol is present.  Nevertheless
+     is the third and fourth argument to such a function call a value
+     denoting the number of elements to copy (i.e., most of the time the
+     length of a deferred length string).  */
+  ulim_copy = formal == NULL && UNLIMITED_POLY (sym)
+      && strcmp ("_copy", comp->name) == 0;
 
   /* Evaluate the arguments.  */
-  for (arg = args; arg != NULL;
-       arg = arg->next, formal = formal ? formal->next : NULL)
+  for (arg = args, argc = 0; arg != NULL;
+       arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
     {
       e = arg->expr;
       fsym = formal ? formal->sym : NULL;
@@ -4729,7 +4737,14 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	  gfc_init_se (&parmse, se);
 	  parm_kind = ELEMENTAL;
 
-	  if (fsym && fsym->attr.value)
+	  /* When no fsym is present, ulim_copy is set and this is a third or
+	     fourth argument, use call-by-value instead of by reference to
+	     hand the length properties to the copy routine (i.e., most of the
+	     time this will be a call to a __copy_character_* routine where the
+	     third and fourth arguments are the lengths of a deferred length
+	     char array).  */
+	  if ((fsym && fsym->attr.value)
+	      || (ulim_copy && (argc == 2 || argc == 3)))
 	    gfc_conv_expr (&parmse, e);
 	  else
 	    gfc_conv_expr_reference (&parmse, e);
@@ -5322,7 +5337,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
       if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
 	    && e->ts.u.derived->attr.alloc_comp
 	    && !(e->symtree && e->symtree->n.sym->attr.pointer)
-	    && (e->expr_type != EXPR_VARIABLE && !e->rank))
+	    && e->expr_type != EXPR_VARIABLE && !e->rank)
         {
 	  int parm_rank;
 	  tmp = build_fold_indirect_ref_loc (input_location,