re PR fortran/19294 (intrinsic_transpose.f90 runtime crash)

2005-01-23  James A. Morrison  <phython@gcc.gnu.org>
	Paul Brook  <paul@codesourcery.com>

	PR fortran/19294
	* iresolve.c (gfc_resolve_transpose): Resolve to transpose_c4 or
	transpose_c8 for complex types.
libgfortran/
	* Makefile.am: Add transpose_c4.c and transpose_c8.c.
	* intrinsics/cshift0.c: Use separate optimized loops for complex types.
	* m4/transpose.m4: Include type letter in function name.
	* Makefile.in: Regenerate.
	* generated/transpose_*.c: Regenerate.

Co-Authored-By: Paul Brook <paul@codesourcery.com>

From-SVN: r94116

1 files changed, 79 insertions, 27 deletions

diff --git a/libgfortran/intrinsics/cshift0.c b/libgfortran/intrinsics/cshift0.c
index 4042ec4..2dd6a02 100644
--- a/libgfortran/intrinsics/cshift0.c
+++ b/libgfortran/intrinsics/cshift0.c
@@ -1,5 +1,5 @@
 /* Generic implementation of the CSHIFT intrinsic
-   Copyright 2003 Free Software Foundation, Inc.
+   Copyright 2003, 2005 Free Software Foundation, Inc.
    Contributed by Feng Wang <wf_cs@yahoo.com>
 
 This file is part of the GNU Fortran 95 runtime library (libgfortran).
@@ -72,6 +72,8 @@ DEF_COPY_LOOP(int, int)
 DEF_COPY_LOOP(long, long)
 DEF_COPY_LOOP(double, double)
 DEF_COPY_LOOP(ldouble, long double)
+DEF_COPY_LOOP(cfloat, _Complex float)
+DEF_COPY_LOOP(cdouble, _Complex double)
 
 
 static void
@@ -96,12 +98,11 @@ cshift0 (gfc_array_char * ret, const gfc_array_char * array,
   index_type size;
   index_type len;
   index_type n;
+  int whichloop;
 
   if (which < 1 || which > GFC_DESCRIPTOR_RANK (array))
     runtime_error ("Argument 'DIM' is out of range in call to 'CSHIFT'");
 
-  size = GFC_DESCRIPTOR_SIZE (ret);
-
   which = which - 1;
 
   extent[0] = 1;
@@ -109,6 +110,34 @@ cshift0 (gfc_array_char * ret, const gfc_array_char * array,
   size = GFC_DESCRIPTOR_SIZE (array);
   n = 0;
 
+  /* The values assigned here must match the cases in the inner loop.  */
+  whichloop = 0;
+  switch (GFC_DESCRIPTOR_TYPE (array))
+    {
+    case GFC_DTYPE_LOGICAL:
+    case GFC_DTYPE_INTEGER:
+    case GFC_DTYPE_REAL:
+      if (size == sizeof (int))
+	whichloop = 1;
+      else if (size == sizeof (long))
+	whichloop = 2;
+      else if (size == sizeof (double))
+	whichloop = 3;
+      else if (size == sizeof (long double))
+	whichloop = 4;
+      break;
+
+    case GFC_DTYPE_COMPLEX:
+      if (size == sizeof (_Complex float))
+	whichloop = 5;
+      else if (size == sizeof (_Complex double))
+	whichloop = 6;
+      break;
+
+    default:
+      break;
+    }
+
   /* Initialized for avoiding compiler warnings.  */
   roffset = size;
   soffset = size;
@@ -187,31 +216,54 @@ cshift0 (gfc_array_char * ret, const gfc_array_char * array,
 	  /* Otherwise, we'll have to perform the copy one element at
 	     a time.  We can speed this up a tad for common cases of 
 	     fundamental types.  */
-	  if (size == sizeof(int))
-	    copy_loop_int (rptr, sptr, roffset, soffset, len, shift);
-	  else if (size == sizeof(long))
-	    copy_loop_long (rptr, sptr, roffset, soffset, len, shift);
-	  else if (size == sizeof(double))
-	    copy_loop_double (rptr, sptr, roffset, soffset, len, shift);
-	  else if (size == sizeof(long double))
-	    copy_loop_ldouble (rptr, sptr, roffset, soffset, len, shift);
-	  else
+	  switch (whichloop)
 	    {
-	      char *dest = rptr;
-	      const char *src = &sptr[shift * soffset];
-
-	      for (n = 0; n < len - shift; n++)
-		{
-		  memcpy (dest, src, size);
-		  dest += roffset;
-		  src += soffset;
-		}
-	      for (src = sptr, n = 0; n < shift; n++)
-		{
-		  memcpy (dest, src, size);
-		  dest += roffset;
-		  src += soffset;
-		}
+	    case 0:
+	      {
+		char *dest = rptr;
+		const char *src = &sptr[shift * soffset];
+
+		for (n = 0; n < len - shift; n++)
+		  {
+		    memcpy (dest, src, size);
+		    dest += roffset;
+		    src += soffset;
+		  }
+		for (src = sptr, n = 0; n < shift; n++)
+		  {
+		    memcpy (dest, src, size);
+		    dest += roffset;
+		    src += soffset;
+		  }
+	      }
+	      break;
+
+	    case 1:
+	      copy_loop_int (rptr, sptr, roffset, soffset, len, shift);
+	      break;
+
+	    case 2:
+	      copy_loop_long (rptr, sptr, roffset, soffset, len, shift);
+	      break;
+
+	    case 3:
+	      copy_loop_double (rptr, sptr, roffset, soffset, len, shift);
+	      break;
+
+	    case 4:
+	      copy_loop_ldouble (rptr, sptr, roffset, soffset, len, shift);
+	      break;
+
+	    case 5:
+	      copy_loop_cfloat (rptr, sptr, roffset, soffset, len, shift);
+	      break;
+	      
+	    case 6:
+	      copy_loop_cdouble (rptr, sptr, roffset, soffset, len, shift);
+	      break;
+
+	    default:
+	      abort ();
 	    }
 	}