re PR fortran/17283 (UNPACK issues)

2005-05-26  Thomas Koenig  <Thomas.Koenig@online.de>

        PR libfortran/17283
        * gfortran.fortran-torture/execute/intrinsic_unpack.f90:
        Test callee-allocated memory with write statements.

2005-05-26  Thomas Koenig  <Thomas.Koenig@online.de>

        PR libfortran/17283
        * intrinsics/unpack_generic.c:  Fix name of routine
        on top.  Update copyright years.
        (unpack1):  Remove const from return array descriptor.
        rs:  New variable, for calculating return sizes.
        Populate return array descriptor if ret->data is NULL.

From-SVN: r100189

4 files changed, 57 insertions, 13 deletions

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 9f2f537..aaff962 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2005-05-26  Thomas Koenig  <Thomas.Koenig@online.de>
+
+	PR libfortran/17283
+	* gfortran.fortran-torture/execute/intrinsic_unpack.f90:
+	Test callee-allocated memory with write statements.
+
 2005-05-25  Roger Sayle  <roger@eyesopen.com>
 
 	PR middle-end/21709
diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_unpack.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_unpack.f90
index 807aadf..88f09c3 100644
--- a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_unpack.f90
+++ b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_unpack.f90
@@ -2,6 +2,7 @@
 program intrinsic_unpack
    integer, dimension(3, 3) :: a, b
    logical, dimension(3, 3) :: mask;
+   character(len=50) line1, line2
    integer i
 
    mask = reshape ((/.false.,.true.,.false.,.true.,.false.,.false.,&
@@ -10,6 +11,9 @@ program intrinsic_unpack
    b = unpack ((/2, 3, 4/), mask, a)
    if (any (b .ne. reshape ((/1, 2, 0, 3, 1, 0, 0, 0, 4/), (/3, 3/)))) &
       call abort
+   write (line1,'(10I4)') b
+   write (line2,'(10I4)') unpack((/2, 3, 4/), mask, a)
+   if (line1 .ne. line2) call abort
    b = -1
    b = unpack ((/2, 3, 4/), mask, 0)
    if (any (b .ne. reshape ((/0, 2, 0, 3, 0, 0, 0, 0, 4/), (/3, 3/)))) &
diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog
index 94b9b84..8f2e25d 100644
--- a/libgfortran/ChangeLog
+++ b/libgfortran/ChangeLog
@@ -1,3 +1,12 @@
+2005-05-26  Thomas Koenig  <Thomas.Koenig@online.de>
+
+	PR libfortran/17283
+	* intrinsics/unpack_generic.c:  Fix name of routine
+	on top.  Update copyright years.
+	(unpack1):  Remove const from return array descriptor.
+	rs:  New variable, for calculating return sizes.
+	Populate return array descriptor if ret->data is NULL.
+
 2005-05-22  Peter Wainwright  <prw@ceiriog1.demon.co.uk>
 
 	PR libfortran/21376
diff --git a/libgfortran/intrinsics/unpack_generic.c b/libgfortran/intrinsics/unpack_generic.c
index 57eb30c..a5c098b 100644
--- a/libgfortran/intrinsics/unpack_generic.c
+++ b/libgfortran/intrinsics/unpack_generic.c
@@ -1,5 +1,5 @@
-/* Generic implementation of the RESHAPE intrinsic
-   Copyright 2002 Free Software Foundation, Inc.
+/* Generic implementation of the UNPACK intrinsic
+   Copyright 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
    Contributed by Paul Brook <paul@nowt.org>
 
 This file is part of the GNU Fortran 95 runtime library (libgfortran).
@@ -34,17 +34,18 @@ Boston, MA 02111-1307, USA.  */
 #include <string.h>
 #include "libgfortran.h"
 
-extern void unpack1 (const gfc_array_char *, const gfc_array_char *,
+extern void unpack1 (gfc_array_char *, const gfc_array_char *,
 		     const gfc_array_l4 *, const gfc_array_char *);
 iexport_proto(unpack1);
 
 void
-unpack1 (const gfc_array_char *ret, const gfc_array_char *vector,
+unpack1 (gfc_array_char *ret, const gfc_array_char *vector,
 	 const gfc_array_l4 *mask, const gfc_array_char *field)
 {
   /* r.* indicates the return array.  */
   index_type rstride[GFC_MAX_DIMENSIONS];
   index_type rstride0;
+  index_type rs;
   char *rptr;
   /* v.* indicates the vector array.  */
   index_type vstride0;
@@ -68,17 +69,41 @@ unpack1 (const gfc_array_char *ret, const gfc_array_char *vector,
   size = GFC_DESCRIPTOR_SIZE (ret);
   /* A field element size of 0 actually means this is a scalar.  */
   fsize = GFC_DESCRIPTOR_SIZE (field);
-  dim = GFC_DESCRIPTOR_RANK (ret);
-  for (n = 0; n < dim; n++)
+  if (ret->data == NULL)
     {
-      count[n] = 0;
-      extent[n] = ret->dim[n].ubound + 1 - ret->dim[n].lbound;
-      rstride[n] = ret->dim[n].stride * size;
-      fstride[n] = field->dim[n].stride * fsize;
-      mstride[n] = mask->dim[n].stride;
+      /* The front end has signalled that we need to populate the
+	 return array descriptor.  */
+      dim = GFC_DESCRIPTOR_RANK (mask);
+      rs = 1;
+      for (n = 0; n < dim; n++)
+	{
+	  count[n] = 0;
+	  ret->dim[n].stride = rs;
+	  ret->dim[n].lbound = 0;
+	  ret->dim[n].ubound = mask->dim[n].ubound - mask->dim[n].lbound;
+	  extent[n] = ret->dim[n].ubound + 1;
+	  rstride[n] = ret->dim[n].stride * size;
+	  fstride[n] = field->dim[n].stride * fsize;
+	  mstride[n] = mask->dim[n].stride;
+	  rs *= extent[n];
+	}
+      ret->base = 0;
+      ret->data = internal_malloc_size (rs * size);
+    }
+  else
+    {
+      dim = GFC_DESCRIPTOR_RANK (ret);
+      for (n = 0; n < dim; n++)
+	{
+	  count[n] = 0;
+	  extent[n] = ret->dim[n].ubound + 1 - ret->dim[n].lbound;
+	  rstride[n] = ret->dim[n].stride * size;
+	  fstride[n] = field->dim[n].stride * fsize;
+	  mstride[n] = mask->dim[n].stride;
+	}
+      if (rstride[0] == 0)
+	rstride[0] = size;
     }
-  if (rstride[0] == 0)
-    rstride[0] = size;
   if (fstride[0] == 0)
     fstride[0] = fsize;
   if (mstride[0] == 0)