re PR fortran/17283 (UNPACK issues)

PR fortran/17283
fortran/
* iresolve.c (gfc_resolve_pack): Choose function depending if mask is
scalar.
libgfortran/
* intrinsics/pack_generic.c (__pack): Allocate memory for return array
if not done by caller.
(__pack_s): New function.
* runtime/memory.c (internal_malloc, internal_malloc64): Allow
allocating zero memory.
testsuite/
* gfortran.fortran-torture/execute/intrinsic_pack.f90: Add more tests.

From-SVN: r88526

4 files changed, 46 insertions, 4 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index d1bc71d..204e8eb 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+2004-10-04  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/17283
+	* iresolve.c (gfc_resolve_pack): Choose function depending if mask
+	is scalar.
+
 2004-10-04  Erik Schnetter  <schnetter@aei.mpg.de>
 
 	* scanner.c (preprocessor_line): Accept preprocessor lines without
diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index 201b3f9..36597fa 100644
--- a/gcc/fortran/iresolve.c
+++ b/gcc/fortran/iresolve.c
@@ -1022,15 +1022,33 @@ gfc_resolve_not (gfc_expr * f, gfc_expr * i)
 void
 gfc_resolve_pack (gfc_expr * f,
                   gfc_expr * array ATTRIBUTE_UNUSED,
-		  gfc_expr * mask ATTRIBUTE_UNUSED,
+		  gfc_expr * mask,
 		  gfc_expr * vector ATTRIBUTE_UNUSED)
 {
-  static char pack[] = "__pack";
+  static char pack[] = "__pack",
+    pack_s[] = "__pack_s";
 
   f->ts = array->ts;
   f->rank = 1;
 
-  f->value.function.name = pack;
+  if (mask->rank != 0)
+    f->value.function.name = pack;
+  else
+    {
+      /* We convert mask to default logical only in the scalar case.
+	 In the array case we can simply read the array as if it were
+	 of type default logical.  */
+      if (mask->ts.kind != gfc_default_logical_kind)
+	{
+	  gfc_typespec ts;
+
+	  ts.type = BT_LOGICAL;
+	  ts.kind = gfc_default_logical_kind;
+	  gfc_convert_type (mask, &ts, 2);
+	}
+
+      f->value.function.name = pack_s;
+    }
 }
 
 
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 9949fea..0587e7f 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2004-10-04  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/17283
+	* gfortran.fortran-torture/execute/intrinsic_pack.f90: Add more tests.
+
 2004-10-04  Chao-ying Fu  <fu@mips.com>
 
 	* gcc.dg/vect/pr16105.c: Enable for mipsisa64*-*-*.
diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_pack.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_pack.f90
index 565446e..427fe55 100644
--- a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_pack.f90
+++ b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_pack.f90
@@ -1,12 +1,25 @@
 ! Program to test the PACK intrinsic
 program intrinsic_pack
+   integer, parameter :: val(9) = (/0,0,0,0,9,0,0,0,7/)
    integer, dimension(3, 3) :: a
    integer, dimension(6) :: b
 
-   a = reshape ((/0, 0, 0, 0, 9, 0, 0, 0, 7/), (/3, 3/))
+   a = reshape (val, (/3, 3/))
    b = 0
    b(1:6:3) = pack (a, a .ne. 0);
    if (any (b(1:6:3) .ne. (/9, 7/))) call abort
    b = pack (a(2:3, 2:3), a(2:3, 2:3) .ne. 0, (/1, 2, 3, 4, 5, 6/));
    if (any (b .ne. (/9, 7, 3, 4, 5, 6/))) call abort
+
+! this is waiting for PR 17756 to be fixed
+!   call tests_with_temp()
+contains
+  subroutine tests_with_temp
+    ! A few tests which involve a temporary
+    if (any (pack(a, a.ne.0) .ne. (/9, 7/))) call abort
+    if (any (pack(a, .true.) .ne. val)) call abort
+    if (size(pack (a, .false.)) .ne. 0) call abort
+    if (any (pack(a, .false., (/1,2,3/)).ne. (/1,2,3/))) call abort
+
+  end subroutine tests_with_temp
 end program