aboutsummaryrefslogtreecommitdiff
path: root/libgfortran
diff options
context:
space:
mode:
Diffstat (limited to 'libgfortran')
-rw-r--r--libgfortran/ChangeLog31
-rw-r--r--libgfortran/acinclude.m44
-rwxr-xr-xlibgfortran/configure8
-rw-r--r--libgfortran/intrinsics/reduce.c77
-rw-r--r--libgfortran/io/close.c13
-rw-r--r--libgfortran/io/open.c10
6 files changed, 109 insertions, 34 deletions
diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog
index 03eab2e..956b43d 100644
--- a/libgfortran/ChangeLog
+++ b/libgfortran/ChangeLog
@@ -1,3 +1,34 @@
+2025-04-13 Jerry DeLisle <jvdelisle@gcc.gnu.org>
+
+ PR libfortran/119502
+ * io/close.c (st_close): Issue an error and avoid
+ calling close_share when there is no stream assigned.
+ * io/open.c (st_open): If there is no stream assigned
+ to the unit, unlock the unit and issue an error.
+
+2025-04-09 Paul Thomas <pault@gcc.gnu.org>
+ and Harald Anlauf <anlauf@gcc.gnu.org>
+
+ PR libfortran/119460
+ * intrinsics/reduce.c (reduce): Correct error message about
+ mismatch between dim and the rank of array. Output the values
+ of both. Correct the evaluation of the result stride and
+ extent.
+ (reduce_scalar): The front end treats the result as an
+ allocatable so eliminate memcpy and free. Return the base-addr
+ of the local descriptor.
+ (reduce_c): Correct the type of the string lengths.
+ (reduce_scalar_c): Correct the type of the string lengths.Test
+ to see if 'res' is allocated. If not then return the base_addr
+ of the local descriptor.
+
+2025-04-07 Lulu Cheng <chenglulu@loongson.cn>
+
+ PR target/119408
+ * acinclude.m4: When checking for __float128 support, determine
+ whether the current architecture is LoongArch. If so, return false.
+ * configure: Regenerate.
+
2025-03-22 Hans-Peter Nilsson <hp@axis.com>
* intrinsics/reduce.c (reduce_scalar_c): Correct type of parameter DIM.
diff --git a/libgfortran/acinclude.m4 b/libgfortran/acinclude.m4
index a73207e..23fd621 100644
--- a/libgfortran/acinclude.m4
+++ b/libgfortran/acinclude.m4
@@ -274,6 +274,10 @@ AC_DEFUN([LIBGFOR_CHECK_FLOAT128], [
AC_CACHE_CHECK([whether we have a usable _Float128 type],
libgfor_cv_have_float128, [
GCC_TRY_COMPILE_OR_LINK([
+ #ifdef __loongarch__
+ #error On LoongArch we should use long double instead; __float128 is only for porting existing code easier.
+ #endif
+
_Float128 foo (_Float128 x)
{
_Complex _Float128 z1, z2;
diff --git a/libgfortran/configure b/libgfortran/configure
index 11a1bc5..9898a94 100755
--- a/libgfortran/configure
+++ b/libgfortran/configure
@@ -30283,6 +30283,10 @@ else
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
+ #ifdef __loongarch__
+ #error On LoongArch we should use long double instead; __float128 is only for porting existing code easier.
+ #endif
+
_Float128 foo (_Float128 x)
{
_Complex _Float128 z1, z2;
@@ -30336,6 +30340,10 @@ fi
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
+ #ifdef __loongarch__
+ #error On LoongArch we should use long double instead; __float128 is only for porting existing code easier.
+ #endif
+
_Float128 foo (_Float128 x)
{
_Complex _Float128 z1, z2;
diff --git a/libgfortran/intrinsics/reduce.c b/libgfortran/intrinsics/reduce.c
index c8950e4..256394f 100644
--- a/libgfortran/intrinsics/reduce.c
+++ b/libgfortran/intrinsics/reduce.c
@@ -52,14 +52,14 @@ reduce (parray *ret,
index_type ext0, ext1, ext2;
index_type str0, str1, str2;
index_type idx0, idx1, idx2;
- index_type dimen, dimen_m1, ldx;
+ index_type dimen, dimen_m1, ldx, ext, str;
bool started;
bool masked = false;
bool dim_present = dim != NULL;
bool mask_present = mask != NULL;
bool identity_present = identity != NULL;
bool scalar_result;
- int i;
+ int i, j;
int array_rank = (int)GFC_DESCRIPTOR_RANK (array);
size_t elem_len = GFC_DESCRIPTOR_SIZE (array);
@@ -83,8 +83,8 @@ reduce (parray *ret,
if (dim_present)
{
if ((*dim < 1) || (*dim > (GFC_INTEGER_4)array_rank))
- runtime_error ("DIM in REDUCE intrinsic is less than 0 or greater than "
- "the rank of ARRAY");
+ runtime_error ("Mismatch between DIM and the rank of ARRAY in the "
+ "REDUCE intrinsic (%d/%d)", (int)*dim, array_rank);
dimen = (index_type) *dim;
}
else
@@ -99,33 +99,39 @@ reduce (parray *ret,
scalar_result = (!dim_present && array_rank > 1) || array_rank == 1;
+ j = 0;
for (i = 0; i < array_rank; i++)
{
/* Obtain the shape of the reshaped ARRAY. */
- index_type ext = GFC_DESCRIPTOR_EXTENT (array,i);
- index_type str = GFC_DESCRIPTOR_STRIDE (array,i);
+ ext = GFC_DESCRIPTOR_EXTENT (array,i);
+ str = GFC_DESCRIPTOR_STRIDE (array,i);
if (masked && (ext != GFC_DESCRIPTOR_EXTENT (mask, i)))
- runtime_error ("shape mismatch between ARRAY and MASK in REDUCE "
- "intrinsic");
+ {
+ int mext = (int)GFC_DESCRIPTOR_EXTENT (mask, i);
+ runtime_error ("shape mismatch between ARRAY and MASK in the REDUCE "
+ "intrinsic (%zd/%d)", ext, mext);
+ }
if (scalar_result)
{
ext1 *= ext;
continue;
}
- else if (i < dimen_m1)
+ else if (i < (int)dimen_m1)
ext0 *= ext;
- else if (i == dimen_m1)
+ else if (i == (int)dimen_m1)
ext1 = ext;
else
ext2 *= ext;
/* The dimensions of the return array. */
- if (i < (int)(dimen - 1))
- GFC_DIMENSION_SET (ret->dim[i], 0, ext - 1, str);
- else if (i < array_rank - 1)
- GFC_DIMENSION_SET (ret->dim[i], 0, ext - 1, str);
+ if (i != (int)dimen_m1)
+ {
+ str = GFC_DESCRIPTOR_STRIDE (array, j);
+ GFC_DIMENSION_SET (ret->dim[j], 0, ext - 1, str);
+ j++;
+ }
}
if (!scalar_result)
@@ -214,14 +220,13 @@ reduce (parray *ret,
}
-extern void reduce_scalar (void *, parray *,
+extern void * reduce_scalar (parray *,
void (*operation) (void *, void *, void *),
GFC_INTEGER_4 *, gfc_array_l4 *, void *, void *);
export_proto (reduce_scalar);
-void
-reduce_scalar (void *res,
- parray *array,
+void *
+reduce_scalar (parray *array,
void (*operation) (void *, void *, void *),
GFC_INTEGER_4 *dim,
gfc_array_l4 *mask,
@@ -232,55 +237,63 @@ reduce_scalar (void *res,
ret.base_addr = NULL;
ret.dtype.rank = 0;
reduce (&ret, array, operation, dim, mask, identity, ordered);
- memcpy (res, ret.base_addr, GFC_DESCRIPTOR_SIZE (array));
- if (ret.base_addr) free (ret.base_addr);
+ return (void *)ret.base_addr;
}
-extern void reduce_c (parray *, index_type, parray *,
+extern void reduce_c (parray *, gfc_charlen_type, parray *,
void (*operation) (void *, void *, void *),
GFC_INTEGER_4 *, gfc_array_l4 *, void *, void *,
- index_type, index_type);
+ gfc_charlen_type, gfc_charlen_type);
export_proto (reduce_c);
void
reduce_c (parray *ret,
- index_type ret_strlen __attribute__ ((unused)),
+ gfc_charlen_type ret_strlen __attribute__ ((unused)),
parray *array,
void (*operation) (void *, void *, void *),
GFC_INTEGER_4 *dim,
gfc_array_l4 *mask,
void *identity,
void *ordered,
- index_type array_strlen __attribute__ ((unused)),
- index_type identity_strlen __attribute__ ((unused)))
+ gfc_charlen_type array_strlen __attribute__ ((unused)),
+ gfc_charlen_type identity_strlen __attribute__ ((unused)))
{
+ /* The frontend constraints make string length checking redundant. Also, the
+ scalar symbol is flagged to be allocatable in trans-intrinsic.cc so that
+ gfc_conv_procedure_call does the necessary allocation/deallocation. */
reduce (ret, array, operation, dim, mask, identity, ordered);
}
-extern void reduce_scalar_c (void *, index_type, parray *,
+extern void reduce_scalar_c (void *, gfc_charlen_type, parray *,
void (*operation) (void *, void *, void *),
GFC_INTEGER_4 *, gfc_array_l4 *, void *, void *,
- index_type, index_type);
+ gfc_charlen_type, gfc_charlen_type);
export_proto (reduce_scalar_c);
void
reduce_scalar_c (void *res,
- index_type res_strlen __attribute__ ((unused)),
+ gfc_charlen_type res_strlen __attribute__ ((unused)),
parray *array,
void (*operation) (void *, void *, void *),
GFC_INTEGER_4 *dim,
gfc_array_l4 *mask,
void *identity,
void *ordered,
- index_type array_strlen __attribute__ ((unused)),
- index_type identity_strlen __attribute__ ((unused)))
+ gfc_charlen_type array_strlen __attribute__ ((unused)),
+ gfc_charlen_type identity_strlen __attribute__ ((unused)))
{
parray ret;
ret.base_addr = NULL;
ret.dtype.rank = 0;
+ /* The frontend constraints make string length checking redundant. */
reduce (&ret, array, operation, dim, mask, identity, ordered);
- memcpy (res, ret.base_addr, GFC_DESCRIPTOR_SIZE (array));
- if (ret.base_addr) free (ret.base_addr);
+ if (res)
+ {
+ memcpy (res, ret.base_addr, GFC_DESCRIPTOR_SIZE (array));
+ if (ret.base_addr) free (ret.base_addr);
+ }
+ else
+ res = ret.base_addr;
}
diff --git a/libgfortran/io/close.c b/libgfortran/io/close.c
index 8122311..41d278c 100644
--- a/libgfortran/io/close.c
+++ b/libgfortran/io/close.c
@@ -84,8 +84,17 @@ st_close (st_parameter_close *clp)
if (u != NULL)
{
- if (close_share (u) < 0)
- generate_error (&clp->common, LIBERROR_OS, "Problem in CLOSE");
+ if (u->s == NULL)
+ {
+ if (u->unit_number < 0)
+ generate_error (&clp->common, LIBERROR_BAD_UNIT,
+ "Unit number is negative with no associated file");
+ library_end ();
+ return;
+ }
+ else
+ if (close_share (u) < 0)
+ generate_error (&clp->common, LIBERROR_OS, "Problem in CLOSE");
if (u->flags.status == STATUS_SCRATCH)
{
if (status == CLOSE_KEEP)
diff --git a/libgfortran/io/open.c b/libgfortran/io/open.c
index 06ddf7f..e9fb0a7 100644
--- a/libgfortran/io/open.c
+++ b/libgfortran/io/open.c
@@ -912,6 +912,16 @@ st_open (st_parameter_open *opp)
library_end ();
return;
}
+
+ if (u->s == NULL)
+ {
+ unlock_unit (u);
+ generate_error (&opp->common, LIBERROR_BAD_OPTION,
+ "Unit number is negative and unit was not already "
+ "opened with OPEN(NEWUNIT=...)");
+ library_end ();
+ return;
+ }
}
if (u == NULL)
generated by cgit v1.1 at 2025-04-14 13:26:31 +0000