re PR fortran/18022 (problem with structure and calling a function)

2005-10-23  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/18022
	* trans-expr.c (gfc_trans_arrayfunc_assign): Return NULL
	if there is a component ref during an array ref to force
	use of temporary in assignment.

	PR fortran/24311
	PR fortran/24384
	* fortran/iresolve.c (check_charlen_present): New function to
	add a charlen to the typespec, in the case of constant
	expressions.
	(gfc_resolve_merge, gfc_resolve_spread): Call.the above.
	(gfc_resolve_spread): Make calls to library functions that
	handle the case of the spread intrinsic with a scalar source.
	* libgfortran/intrinsics/spread_generic.c (spread_internal
	_scalar): New function that handles the special case of spread
	with a scalar source. This has interface functions -
	(spread_scalar, spread_char_scalar): New functions to interface
	with the calls specified in gfc_resolve_spread.

2005-10-23  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/18022
	gfortran.dg/assign_func_dtcomp_1.f90: New test.

	PR fortran/24311
	gfortran.dg/merge_char_const.f90: New test.

	PR fortran/24384
	gfortran.dg/spread_scalar_source.f90: New test.

From-SVN: r105810

gcc/fortran/ChangeLog

+2005-10-23  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/18022
+	* trans-expr.c (gfc_trans_arrayfunc_assign): Return NULL
+	if there is a component ref during an array ref to force
+	use of temporary in assignment.
+
+	PR fortran/24311
+	PR fortran/24384
+	* fortran/iresolve.c (check_charlen_present): New function to
+	add a charlen to the typespec, in the case of constant
+	expressions.
+	(gfc_resolve_merge, gfc_resolve_spread): Call.the above.
+	(gfc_resolve_spread): Make calls to library functions that
+	handle the case of the spread intrinsic with a scalar source.
+
 2005-10-22  Erik Edelmann  <eedelman@gcc.gnu.org>
 
 	PR fortran/24426

gcc/fortran/iresolve.c

@@ -59,6 +59,21 @@ gfc_get_string (const char *format, ...)
   return IDENTIFIER_POINTER (ident);
 }
 
+/* MERGE and SPREAD need to have source charlen's present for passing
+   to the result expression.  */
+static void
+check_charlen_present (gfc_expr *source)
+{
+  if (source->expr_type == EXPR_CONSTANT && source->ts.cl == NULL)
+    {
+      source->ts.cl = gfc_get_charlen ();
+      source->ts.cl->next = gfc_current_ns->cl_list;
+      gfc_current_ns->cl_list = source->ts.cl;
+      source->ts.cl->length = gfc_int_expr (source->value.character.length);
+      source->rank = 0;
+    }
+}
+
 /********************** Resolution functions **********************/
 
 
@@ -996,6 +1011,9 @@ gfc_resolve_merge (gfc_expr * f, gfc_expr * tsource,
 		   gfc_expr * fsource ATTRIBUTE_UNUSED,
 		   gfc_expr * mask ATTRIBUTE_UNUSED)
 {
+  if (tsource->ts.type == BT_CHARACTER)
+    check_charlen_present (tsource);
+
   f->ts = tsource->ts;
   f->value.function.name =
     gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource->ts.type),
@@ -1395,11 +1413,19 @@ gfc_resolve_spread (gfc_expr * f, gfc_expr * source,
 		    gfc_expr * dim,
 		    gfc_expr * ncopies)
 {
+  if (source->ts.type == BT_CHARACTER)
+    check_charlen_present (source);
+
   f->ts = source->ts;
   f->rank = source->rank + 1;
-  f->value.function.name = (source->ts.type == BT_CHARACTER
-			    ? PREFIX("spread_char")
-			    : PREFIX("spread"));
+  if (source->rank == 0)
+    f->value.function.name = (source->ts.type == BT_CHARACTER
+			      ? PREFIX("spread_char_scalar")
+			      : PREFIX("spread_scalar"));
+  else
+    f->value.function.name = (source->ts.type == BT_CHARACTER
+			      ? PREFIX("spread_char")
+			      : PREFIX("spread"));
 
   gfc_resolve_dim_arg (dim);
   gfc_resolve_index (ncopies, 1);

gcc/fortran/trans-expr.c

@@ -2591,6 +2591,8 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
 {
   gfc_se se;
   gfc_ss *ss;
+  gfc_ref * ref;
+  bool seen_array_ref;
 
   /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION.  */
   if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
@@ -2605,6 +2607,20 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
   if (gfc_ref_needs_temporary_p (expr1->ref))
     return NULL;
 
+  /* Check that no LHS component references appear during an array
+     reference. This is needed because we do not have the means to
+     span any arbitrary stride with an array descriptor. This check
+     is not needed for the rhs because the function result has to be
+     a complete type.  */
+  seen_array_ref = false;
+  for (ref = expr1->ref; ref; ref = ref->next)
+    {
+      if (ref->type == REF_ARRAY)
+	seen_array_ref= true;
+      else if (ref->type == REF_COMPONENT && seen_array_ref)
+	return NULL;
+    }
+
   /* Check for a dependency.  */
   if (gfc_check_fncall_dependency (expr1, expr2))
     return NULL;

gcc/testsuite/ChangeLog

+2005-10-23  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/18022
+	gfortran.dg/assign_func_dtcomp_1.f90: New test.
+
+	PR fortran/24311
+	gfortran.dg/merge_char_const.f90: New test.
+
+	PR fortran/24384
+	gfortran.dg/spread_scalar_source.f90: New test.
+
 2005-10-22  Hans-Peter Nilsson  <hp@axis.com>
 
 	* g++.old-deja/g++.jason/thunk2.C: Guard test with { target fpic }.

gcc/testsuite/gfortran.dg/assign_func_dtcomp_1.f90

+! { dg-do run }
+! { dg-options "-O0" }
+!
+! Test fix for PR18022.
+!
+! Contributed by Paul Thomas <pault@gcc.gnu.org>
+!
+program assign_func_dtcomp
+ implicit none
+ type                         ::  mytype
+   real                       ::  x
+   real                       ::  y
+ end type mytype
+ type (mytype), dimension (4) ::  z
+
+ type                         ::  thytype
+   real                       ::  x(4)
+ end type thytype
+ type (thytype)               ::  w
+ real, dimension (4)          ::  a = (/1.,2.,3.,4./)
+ real, dimension (4)          ::  b = (/5.,6.,7.,8./)
+
+
+! Test the original problem is fixed.
+ z(:)%x = foo (a)
+ z(:)%y = foo (b)
+
+
+ if (any(z%x.ne.a).or.any(z%y.ne.b)) call abort ()
+
+! Make sure we did not break anything on the way.
+ w%x(:) = foo (b)
+ a = foo (b)
+
+ if (any(w%x.ne.b).or.any(a.ne.b)) call abort ()
+
+contains
+
+ function foo (v) result (ans)
+   real, dimension (:), intent(in)   ::  v
+   real, dimension (size(v))  ::  ans
+   ans = v
+ end function foo
+
+
+end program assign_func_dtcomp
+

gcc/testsuite/gfortran.dg/merge_char_const.f90

+! { dg-do run }
+! { dg-options "-O0" }
+! This tests the patch for PR24311 in which the PRINT statement would
+! ICE on trying to print a MERGE statement with character constants
+! for the first two arguments.
+!
+! Contributed by Paul Thomas <pault@gcc.gnu.org>
+!
+  integer, dimension(6) :: i = (/1,0,0,1,1,0/)
+  print '(6a1)', Merge ("a", "b", i  == 1) ! { dg-output "abbaab" }
+  end
+
+

gcc/testsuite/gfortran.dg/spread_scalar_source.f90

+! { dg-do run }
+! { dg-options "-O0" }
+
+  character*1 :: i, j(10)
+  character*8 :: buffer
+  integer*1 :: ii, jj(10)
+  type :: mytype
+    real*8 :: x
+    integer*1 :: i
+    character*15 :: ch
+  end type mytype
+  type(mytype) :: iii, jjj(10)
+
+  i = "w"
+  ii = 42
+  iii = mytype (41.9999_8, 77, "test_of_spread_")
+
+! Test constant sources.
+
+  j = spread ("z", 1 , 10)
+  if (any (j /= "z")) call abort ()
+  jj = spread (19, 1 , 10)
+  if (any (jj /= 19)) call abort ()
+
+! Test variable sources.
+
+  j = spread (i, 1 , 10)
+  if (any (j /= "w")) call abort ()
+  jj = spread (ii, 1 , 10)
+  if (any (jj /= 42)) call abort ()
+  jjj = spread (iii, 1 , 10)
+  if (any (jjj%x /= 41.9999_8)) call abort ()
+  if (any (jjj%i /= 77)) call abort ()
+  if (any (jjj%ch /= "test_of_spread_")) call abort ()
+
+! Check that spread != 1 is OK.
+
+  jj(2:10:2) = spread (1, 1, 5)
+  if (any (jj(1:9:2) /= 42) .or. any (jj(2:10:2) /= 1)) call abort ()
+
+! Finally, check that temporaries and trans-io.c work correctly.
+
+  write (buffer, '(4a1)') spread (i, 1 , 4)
+  if (trim(buffer) /= "wwww") call abort ()
+  write (buffer, '(4a1)') spread ("r", 1 , 4)
+  if (trim(buffer) /= "rrrr") call abort ()
+  write (buffer, '(4i2)') spread (ii, 1 , 4)
+  if (trim(buffer) /= "42424242") call abort ()
+  write (buffer, '(4i2)') spread (31, 1 , 4)
+  if (trim(buffer) /= "31313131") call abort ()
+
+  end
\ No newline at end of file

libgfortran/ChangeLog

+2005-10-23  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/24384
+	* intrinsics/spread_generic.c (spread_internal_scalar): New
+	function that handles the special case of spread with a scalar
+	source. This has new interface functions -
+	(spread_scalar, spread_char_scalar): New functions to interface
+	with the calls specified in gfc_resolve_spread.
+
 2005-10-21  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
 
 	PR libfortran/24383

libgfortran/intrinsics/spread_generic.c

@@ -176,6 +176,49 @@ spread_internal (gfc_array_char *ret, const gfc_array_char *source,
     }
 }
 
+/* This version of spread_internal treats the special case of a scalar
+   source.  This is much simpler than the more general case above.  */
+
+static void
+spread_internal_scalar (gfc_array_char *ret, const char *source,
+			const index_type *along, const index_type *pncopies,
+			index_type size)
+{
+  int n;
+  int ncopies = *pncopies;
+  char * dest;
+
+  if (GFC_DESCRIPTOR_RANK (ret) != 1)
+    runtime_error ("incorrect destination rank in spread()");
+
+  if (*along > 1)
+    runtime_error ("dim outside of rank in spread()");
+
+  if (ret->data == NULL)
+    {
+      ret->data = internal_malloc_size (ncopies * size);
+      ret->offset = 0;
+      ret->dim[0].stride = 1;
+      ret->dim[0].lbound = 0;
+      ret->dim[0].ubound = ncopies - 1;
+    }
+  else
+    {
+      if (ret->dim[0].stride == 0)
+	ret->dim[0].stride = 1;
+
+      if (ncopies - 1 > (ret->dim[0].ubound - ret->dim[0].lbound)
+			   / ret->dim[0].stride)
+	runtime_error ("dim too large in spread()");
+    }
+
+  for (n = 0; n < ncopies; n++)
+    {
+      dest = (char*)(ret->data + n*size*ret->dim[0].stride);
+      memcpy (dest , source, size);
+    }
+}
+
 extern void spread (gfc_array_char *, const gfc_array_char *,
 		    const index_type *, const index_type *);
 export_proto(spread);
@@ -200,3 +243,37 @@ spread_char (gfc_array_char *ret,
 {
   spread_internal (ret, source, along, pncopies, source_length);
 }
+
+/* The following are the prototypes for the versions of spread with a
+   scalar source.  */
+
+extern void spread_scalar (gfc_array_char *, const char *,
+			   const index_type *, const index_type *);
+export_proto(spread_scalar);
+
+void
+spread_scalar (gfc_array_char *ret, const char *source,
+	       const index_type *along, const index_type *pncopies)
+{
+  if (!ret->dtype)
+    runtime_error ("return array missing descriptor in spread()");
+  spread_internal_scalar (ret, source, along, pncopies, GFC_DESCRIPTOR_SIZE (ret));
+}
+
+
+extern void spread_char_scalar (gfc_array_char *, GFC_INTEGER_4,
+				const char *, const index_type *,
+				const index_type *, GFC_INTEGER_4);
+export_proto(spread_char_scalar);
+
+void
+spread_char_scalar (gfc_array_char *ret,
+		    GFC_INTEGER_4 ret_length __attribute__((unused)),
+		    const char *source, const index_type *along,
+		    const index_type *pncopies, GFC_INTEGER_4 source_length)
+{
+  if (!ret->dtype)
+    runtime_error ("return array missing descriptor in spread()");
+  spread_internal_scalar (ret, source, along, pncopies, source_length);
+}
+