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

2 files changed, 86 insertions, 0 deletions

diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog
index 2c4f5f8..3666964 100644
--- a/libgfortran/ChangeLog
+++ b/libgfortran/ChangeLog
@@ -1,3 +1,12 @@
+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
diff --git a/libgfortran/intrinsics/spread_generic.c b/libgfortran/intrinsics/spread_generic.c
index a9cddb0..bdcc0d1 100644
--- a/libgfortran/intrinsics/spread_generic.c
+++ b/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);
+}
+