diff options
| author | Tobias Schlüter <tobias.schlueter@physik.uni-muenchen.de> | 2004-10-04 21:27:29 +0200 |
|---|---|---|
| committer | Tobias Schlüter <tobi@gcc.gnu.org> | 2004-10-04 21:27:29 +0200 |
| commit | 58c5b409e89f4250bddf1ba114b3058d4dfab718 (patch) | |
| tree | f997c7996452c6a047a1c132b79457094d5ea30b /gcc/fortran/iresolve.c | |
| parent | 110aba1432fa485c5c0ca2ad499822b7bfafd208 (diff) | |
| download | gcc-58c5b409e89f4250bddf1ba114b3058d4dfab718.zip gcc-58c5b409e89f4250bddf1ba114b3058d4dfab718.tar.gz gcc-58c5b409e89f4250bddf1ba114b3058d4dfab718.tar.bz2 | |
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
Diffstat (limited to 'gcc/fortran/iresolve.c')
| -rw-r--r-- | gcc/fortran/iresolve.c | 24 |
1 files changed, 21 insertions, 3 deletions
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; + } } |