OSDN Git Service

2005-05-26 Thomas Koenig <Thomas.Koenig@online.de>
authortkoenig <tkoenig@138bc75d-0d04-0410-961f-82ee72b054a4>
Thu, 26 May 2005 06:26:17 +0000 (06:26 +0000)
committertkoenig <tkoenig@138bc75d-0d04-0410-961f-82ee72b054a4>
Thu, 26 May 2005 06:26:17 +0000 (06:26 +0000)
        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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@100189 138bc75d-0d04-0410-961f-82ee72b054a4

gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_unpack.f90
libgfortran/ChangeLog
libgfortran/intrinsics/unpack_generic.c

index 9f2f537..aaff962 100644 (file)
@@ -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
index 807aadf..88f09c3 100644 (file)
@@ -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/)))) &
index 94b9b84..8f2e25d 100644 (file)
@@ -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
index 57eb30c..a5c098b 100644 (file)
@@ -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)