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.


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

1 files changed, 21 insertions, 3 deletions

diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index 201b3f962e2..36597fa6d84 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;
+    }
 }