[gcc r14-10291] Fortran: fix ALLOCATE with SOURCE=, zero-length character [PR83865]
https://gcc.gnu.org/g:c3e16edcf2c8429da2cb479d8941397f4300e0c4
commit r14-10291-gc3e16edcf2c8429da2cb479d8941397f4300e0c4
Author: Harald Anlauf
Date: Mon Jun 3 22:02:06 2024 +0200
Fortran: fix ALLOCATE with SOURCE=, zero-length character [PR83865]
gcc/fortran/ChangeLog:
PR fortran/83865
* trans-stmt.cc (gfc_trans_allocate): Restrict special case for
source-expression with zero-length character to rank 0, so that
the array shape is not discarded.
gcc/testsuite/ChangeLog:
PR fortran/83865
* gfortran.dg/allocate_with_source_32.f90: New test.
(cherry picked from commit 7f21aee0d4ef95eee7d9f7f42e9a056715836648)
Diff:
---
gcc/fortran/trans-stmt.cc | 3 +-
.../gfortran.dg/allocate_with_source_32.f90| 33 ++
2 files changed, 35 insertions(+), 1 deletion(-)
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index d355009fa5e..87dd833872a 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -6449,8 +6449,9 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist
*omp_allocate)
else
gfc_add_block_to_block (, );
- /* Special case when string in expr3 is zero. */
+ /* Special case when string in expr3 is scalar and has length zero. */
if (code->expr3->ts.type == BT_CHARACTER
+ && code->expr3->rank == 0
&& integer_zerop (se.string_length))
{
gfc_init_se (, NULL);
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_32.f90
b/gcc/testsuite/gfortran.dg/allocate_with_source_32.f90
new file mode 100644
index 000..4a9bd46da4d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_32.f90
@@ -0,0 +1,33 @@
+! { dg-do run }
+!
+! PR fortran/83865
+!
+! Test ALLOCATE with SOURCE= of deferred length character, where
+! the source-expression is an array of character with length 0.
+
+program p
+ implicit none
+ character(:), allocatable :: z(:)
+ character(1) :: cc(4) = ""
+ allocate (z, source=[''])
+ if (len (z) /= 0 .or. size (z) /= 1) stop 1
+ deallocate (z)
+ allocate (z, source=['',''])
+ if (len (z) /= 0 .or. size (z) /= 2) stop 2
+ deallocate (z)
+ allocate (z, source=[ character(0) :: 'a','b','c'])
+ if (len (z) /= 0 .or. size (z) /= 3) stop 3
+ deallocate (z)
+ allocate (z, source=[ character(0) :: cc ])
+ if (len (z) /= 0 .or. size (z) /= 4) stop 4
+ deallocate (z)
+ associate (x => f())
+if (len (x) /= 0 .or. size (x) /= 1) stop 5
+if (x(1) /= '') stop 6
+ end associate
+contains
+ function f() result(z)
+character(:), allocatable :: z(:)
+allocate (z, source=[''])
+ end function f
+end
[gcc r15-1018] Fortran: fix ALLOCATE with SOURCE=, zero-length character [PR83865]
https://gcc.gnu.org/g:7f21aee0d4ef95eee7d9f7f42e9a056715836648
commit r15-1018-g7f21aee0d4ef95eee7d9f7f42e9a056715836648
Author: Harald Anlauf
Date: Mon Jun 3 22:02:06 2024 +0200
Fortran: fix ALLOCATE with SOURCE=, zero-length character [PR83865]
gcc/fortran/ChangeLog:
PR fortran/83865
* trans-stmt.cc (gfc_trans_allocate): Restrict special case for
source-expression with zero-length character to rank 0, so that
the array shape is not discarded.
gcc/testsuite/ChangeLog:
PR fortran/83865
* gfortran.dg/allocate_with_source_32.f90: New test.
Diff:
---
gcc/fortran/trans-stmt.cc | 3 +-
.../gfortran.dg/allocate_with_source_32.f90| 33 ++
2 files changed, 35 insertions(+), 1 deletion(-)
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index 9b497d6bdc6..93b633e212e 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -6449,8 +6449,9 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist
*omp_allocate)
else
gfc_add_block_to_block (, );
- /* Special case when string in expr3 is zero. */
+ /* Special case when string in expr3 is scalar and has length zero. */
if (code->expr3->ts.type == BT_CHARACTER
+ && code->expr3->rank == 0
&& integer_zerop (se.string_length))
{
gfc_init_se (, NULL);
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_32.f90
b/gcc/testsuite/gfortran.dg/allocate_with_source_32.f90
new file mode 100644
index 000..4a9bd46da4d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_32.f90
@@ -0,0 +1,33 @@
+! { dg-do run }
+!
+! PR fortran/83865
+!
+! Test ALLOCATE with SOURCE= of deferred length character, where
+! the source-expression is an array of character with length 0.
+
+program p
+ implicit none
+ character(:), allocatable :: z(:)
+ character(1) :: cc(4) = ""
+ allocate (z, source=[''])
+ if (len (z) /= 0 .or. size (z) /= 1) stop 1
+ deallocate (z)
+ allocate (z, source=['',''])
+ if (len (z) /= 0 .or. size (z) /= 2) stop 2
+ deallocate (z)
+ allocate (z, source=[ character(0) :: 'a','b','c'])
+ if (len (z) /= 0 .or. size (z) /= 3) stop 3
+ deallocate (z)
+ allocate (z, source=[ character(0) :: cc ])
+ if (len (z) /= 0 .or. size (z) /= 4) stop 4
+ deallocate (z)
+ associate (x => f())
+if (len (x) /= 0 .or. size (x) /= 1) stop 5
+if (x(1) /= '') stop 6
+ end associate
+contains
+ function f() result(z)
+character(:), allocatable :: z(:)
+allocate (z, source=[''])
+ end function f
+end
[gcc r14-10244] Fortran: fix bounds check for assignment, class component [PR86100]
https://gcc.gnu.org/g:b0b21d5bdfbc7d417b70010a11354b44968bb184
commit r14-10244-gb0b21d5bdfbc7d417b70010a11354b44968bb184
Author: Harald Anlauf
Date: Mon May 13 22:06:33 2024 +0200
Fortran: fix bounds check for assignment, class component [PR86100]
gcc/fortran/ChangeLog:
PR fortran/86100
* trans-array.cc (gfc_conv_ss_startstride): Use abridged_ref_name
to generate a more user-friendly name for bounds-check messages.
* trans-expr.cc (gfc_copy_class_to_class): Fix bounds check for
rank>1 by looping over the dimensions.
gcc/testsuite/ChangeLog:
PR fortran/86100
* gfortran.dg/bounds_check_25.f90: New test.
(cherry picked from commit 93765736815a049e14d985b758a213cfe60c1e1c)
Diff:
---
gcc/fortran/trans-array.cc| 7 -
gcc/fortran/trans-expr.cc | 40 +++
gcc/testsuite/gfortran.dg/bounds_check_25.f90 | 32 +
3 files changed, 60 insertions(+), 19 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 7ec33fb1598..a15ff30e8f4 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -4911,6 +4911,7 @@ done:
gfc_expr *expr;
locus *expr_loc;
const char *expr_name;
+ char *ref_name = NULL;
ss_info = ss->info;
if (ss_info->type != GFC_SS_SECTION)
@@ -4922,7 +4923,10 @@ done:
expr = ss_info->expr;
expr_loc = >where;
- expr_name = expr->symtree->name;
+ if (expr->ref)
+ expr_name = ref_name = abridged_ref_name (expr, NULL);
+ else
+ expr_name = expr->symtree->name;
gfc_start_block ();
@@ -5134,6 +5138,7 @@ done:
gfc_add_expr_to_block (, tmp);
+ free (ref_name);
}
tmp = gfc_finish_block ();
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index bc8eb419cff..d5fd6e39996 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -1518,7 +1518,6 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems,
bool unlimited)
stmtblock_t body;
stmtblock_t ifbody;
gfc_loopinfo loop;
- tree orig_nelems = nelems; /* Needed for bounds check. */
gfc_init_block ();
tmp = fold_build2_loc (input_location, MINUS_EXPR,
@@ -1550,27 +1549,32 @@ gfc_copy_class_to_class (tree from, tree to, tree
nelems, bool unlimited)
/* Add bounds check. */
if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) > 0 && is_from_desc)
{
- char *msg;
const char *name = "<>";
- tree from_len;
+ int dim, rank;
if (DECL_P (to))
- name = (const char *)(DECL_NAME (to)->identifier.id.str);
-
- from_len = gfc_conv_descriptor_size (from_data, 1);
- from_len = fold_convert (TREE_TYPE (orig_nelems), from_len);
- tmp = fold_build2_loc (input_location, NE_EXPR,
- logical_type_node, from_len, orig_nelems);
- msg = xasprintf ("Array bound mismatch for dimension %d "
- "of array '%s' (%%ld/%%ld)",
- 1, name);
-
- gfc_trans_runtime_check (true, false, tmp, ,
- _current_locus, msg,
-fold_convert (long_integer_type_node, orig_nelems),
- fold_convert (long_integer_type_node, from_len));
+ name = IDENTIFIER_POINTER (DECL_NAME (to));
- free (msg);
+ rank = GFC_TYPE_ARRAY_RANK (TREE_TYPE (from_data));
+ for (dim = 1; dim <= rank; dim++)
+ {
+ tree from_len, to_len, cond;
+ char *msg;
+
+ from_len = gfc_conv_descriptor_size (from_data, dim);
+ from_len = fold_convert (long_integer_type_node, from_len);
+ to_len = gfc_conv_descriptor_size (to_data, dim);
+ to_len = fold_convert (long_integer_type_node, to_len);
+ msg = xasprintf ("Array bound mismatch for dimension %d "
+ "of array '%s' (%%ld/%%ld)",
+ dim, name);
+ cond = fold_build2_loc (input_location, NE_EXPR,
+ logical_type_node, from_len, to_len);
+ gfc_trans_runtime_check (true, false, cond, ,
+ _current_locus, msg,
+ to_len, from_len);
+ free (msg);
+ }
}
tmp = build_call_vec (fcn_type, fcn, args);
diff --git a/gcc/testsuite/gfortran.dg/bounds_check_25.f90
b/gcc/testsuite/gfortran.dg/bounds_check_25.f90
new file mode 100644
index 000..cc2247597f9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/bounds_check_25.f90
@@ -0,0 +1,32 @@
+! { dg-do run }
+! {
[gcc r15-828] Fortran: improve attribute conflict checking [PR93635]
https://gcc.gnu.org/g:9561cf550a66a89e7c8d31202a03c4fddf82a3f2
commit r15-828-g9561cf550a66a89e7c8d31202a03c4fddf82a3f2
Author: Harald Anlauf
Date: Thu May 23 21:13:00 2024 +0200
Fortran: improve attribute conflict checking [PR93635]
gcc/fortran/ChangeLog:
PR fortran/93635
* symbol.cc (conflict_std): Helper function for reporting attribute
conflicts depending on the Fortran standard version.
(conf_std): Helper macro for checking standard-dependent conflicts.
(gfc_check_conflict): Use it.
gcc/testsuite/ChangeLog:
PR fortran/93635
* gfortran.dg/c-interop/c1255-2.f90: Adjust pattern.
* gfortran.dg/pr87907.f90: Likewise.
* gfortran.dg/pr93635.f90: New test.
Co-authored-by: Steven G. Kargl
Diff:
---
gcc/fortran/symbol.cc | 63 +++--
gcc/testsuite/gfortran.dg/c-interop/c1255-2.f90 | 4 +-
gcc/testsuite/gfortran.dg/pr87907.f90 | 8 ++--
gcc/testsuite/gfortran.dg/pr93635.f90 | 19
4 files changed, 54 insertions(+), 40 deletions(-)
diff --git a/gcc/fortran/symbol.cc b/gcc/fortran/symbol.cc
index 0a1646def67..5db3c887127 100644
--- a/gcc/fortran/symbol.cc
+++ b/gcc/fortran/symbol.cc
@@ -407,18 +407,36 @@ gfc_check_function_type (gfc_namespace *ns)
/ Symbol attribute stuff */
+/* Older standards produced conflicts for some attributes that are allowed
+ in newer standards. Check for the conflict and issue an error depending
+ on the standard in play. */
+
+static bool
+conflict_std (int standard, const char *a1, const char *a2, const char *name,
+ locus *where)
+{
+ if (name == NULL)
+{
+ return gfc_notify_std (standard, "%s attribute conflicts "
+"with %s attribute at %L", a1, a2,
+where);
+}
+ else
+{
+ return gfc_notify_std (standard, "%s attribute conflicts "
+"with %s attribute in %qs at %L",
+a1, a2, name, where);
+}
+}
+
/* This is a generic conflict-checker. We do this to avoid having a
single conflict in two places. */
#define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
#define conf2(a) if (attr->a) { a2 = a; goto conflict; }
-#define conf_std(a, b, std) if (attr->a && attr->b)\
- {\
-a1 = a;\
-a2 = b;\
-standard = std;\
-goto conflict_std;\
- }
+#define conf_std(a, b, std) if (attr->a && attr->b \
+ && !conflict_std (std, a, b, name, where)) \
+ return false;
bool
gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where)
@@ -451,7 +469,6 @@ gfc_check_conflict (symbol_attribute *attr, const char
*name, locus *where)
"OACC DECLARE DEVICE_RESIDENT";
const char *a1, *a2;
- int standard;
if (attr->artificial)
return true;
@@ -460,20 +477,10 @@ gfc_check_conflict (symbol_attribute *attr, const char
*name, locus *where)
where = _current_locus;
if (attr->pointer && attr->intent != INTENT_UNKNOWN)
-{
- a1 = pointer;
- a2 = intent;
- standard = GFC_STD_F2003;
- goto conflict_std;
-}
+conf_std (pointer, intent, GFC_STD_F2003);
- if (attr->in_namelist && (attr->allocatable || attr->pointer))
-{
- a1 = in_namelist;
- a2 = attr->allocatable ? allocatable : pointer;
- standard = GFC_STD_F2003;
- goto conflict_std;
-}
+ conf_std (in_namelist, allocatable, GFC_STD_F2003);
+ conf_std (in_namelist, pointer, GFC_STD_F2003);
/* Check for attributes not allowed in a BLOCK DATA. */
if (gfc_current_state () == COMP_BLOCK_DATA)
@@ -922,20 +929,6 @@ conflict:
a1, a2, name, where);
return false;
-
-conflict_std:
- if (name == NULL)
-{
- return gfc_notify_std (standard, "%s attribute conflicts "
- "with %s attribute at %L", a1, a2,
- where);
-}
- else
-{
- return gfc_notify_std (standard, "%s attribute conflicts "
-"with %s attribute in %qs at %L",
- a1, a2, name, where);
-}
}
#undef conf
diff --git a/gcc/testsuite/gfortran.dg/c-interop/c1255-2.f90
b/gcc/testsuite/gfortran.dg/c-interop/c1255-2.f90
index 0e5505a0183..feed2e7645f 100644
--- a/gcc/testsuite/gfortran.dg/c-interop/c1255-2.f90
+++ b/gcc/testsuite/gfortran.dg/c-interop/c1255-2.f90
@@ -92,12 +92,12 @@ module m2
end function
! function result is a type that is not interoperable
-function g (x) bind (c) ! { dg-error
[gcc r15-827] Fortran: fix bounds check for assignment, class component [PR86100]
https://gcc.gnu.org/g:93765736815a049e14d985b758a213cfe60c1e1c
commit r15-827-g93765736815a049e14d985b758a213cfe60c1e1c
Author: Harald Anlauf
Date: Mon May 13 22:06:33 2024 +0200
Fortran: fix bounds check for assignment, class component [PR86100]
gcc/fortran/ChangeLog:
PR fortran/86100
* trans-array.cc (gfc_conv_ss_startstride): Use abridged_ref_name
to generate a more user-friendly name for bounds-check messages.
* trans-expr.cc (gfc_copy_class_to_class): Fix bounds check for
rank>1 by looping over the dimensions.
gcc/testsuite/ChangeLog:
PR fortran/86100
* gfortran.dg/bounds_check_25.f90: New test.
Diff:
---
gcc/fortran/trans-array.cc| 7 -
gcc/fortran/trans-expr.cc | 40 +++
gcc/testsuite/gfortran.dg/bounds_check_25.f90 | 32 +
3 files changed, 60 insertions(+), 19 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index c5b56f4e273..eec62c296ff 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -4911,6 +4911,7 @@ done:
gfc_expr *expr;
locus *expr_loc;
const char *expr_name;
+ char *ref_name = NULL;
ss_info = ss->info;
if (ss_info->type != GFC_SS_SECTION)
@@ -4922,7 +4923,10 @@ done:
expr = ss_info->expr;
expr_loc = >where;
- expr_name = expr->symtree->name;
+ if (expr->ref)
+ expr_name = ref_name = abridged_ref_name (expr, NULL);
+ else
+ expr_name = expr->symtree->name;
gfc_start_block ();
@@ -5134,6 +5138,7 @@ done:
gfc_add_expr_to_block (, tmp);
+ free (ref_name);
}
tmp = gfc_finish_block ();
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index e315e2d3370..dfc5b8e9b4a 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -1520,7 +1520,6 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems,
bool unlimited)
stmtblock_t body;
stmtblock_t ifbody;
gfc_loopinfo loop;
- tree orig_nelems = nelems; /* Needed for bounds check. */
gfc_init_block ();
tmp = fold_build2_loc (input_location, MINUS_EXPR,
@@ -1552,27 +1551,32 @@ gfc_copy_class_to_class (tree from, tree to, tree
nelems, bool unlimited)
/* Add bounds check. */
if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) > 0 && is_from_desc)
{
- char *msg;
const char *name = "<>";
- tree from_len;
+ int dim, rank;
if (DECL_P (to))
- name = (const char *)(DECL_NAME (to)->identifier.id.str);
-
- from_len = gfc_conv_descriptor_size (from_data, 1);
- from_len = fold_convert (TREE_TYPE (orig_nelems), from_len);
- tmp = fold_build2_loc (input_location, NE_EXPR,
- logical_type_node, from_len, orig_nelems);
- msg = xasprintf ("Array bound mismatch for dimension %d "
- "of array '%s' (%%ld/%%ld)",
- 1, name);
-
- gfc_trans_runtime_check (true, false, tmp, ,
- _current_locus, msg,
-fold_convert (long_integer_type_node, orig_nelems),
- fold_convert (long_integer_type_node, from_len));
+ name = IDENTIFIER_POINTER (DECL_NAME (to));
- free (msg);
+ rank = GFC_TYPE_ARRAY_RANK (TREE_TYPE (from_data));
+ for (dim = 1; dim <= rank; dim++)
+ {
+ tree from_len, to_len, cond;
+ char *msg;
+
+ from_len = gfc_conv_descriptor_size (from_data, dim);
+ from_len = fold_convert (long_integer_type_node, from_len);
+ to_len = gfc_conv_descriptor_size (to_data, dim);
+ to_len = fold_convert (long_integer_type_node, to_len);
+ msg = xasprintf ("Array bound mismatch for dimension %d "
+ "of array '%s' (%%ld/%%ld)",
+ dim, name);
+ cond = fold_build2_loc (input_location, NE_EXPR,
+ logical_type_node, from_len, to_len);
+ gfc_trans_runtime_check (true, false, cond, ,
+ _current_locus, msg,
+ to_len, from_len);
+ free (msg);
+ }
}
tmp = build_call_vec (fcn_type, fcn, args);
diff --git a/gcc/testsuite/gfortran.dg/bounds_check_25.f90
b/gcc/testsuite/gfortran.dg/bounds_check_25.f90
new file mode 100644
index 000..cc2247597f9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/bounds_check_25.f90
@@ -0,0 +1,32 @@
+! { dg-do run }
+! { dg-additional-options "-fcheck=bounds -fdump-tree-original" }
+!
+! PR fortran/86100 - bogus bounds
[gcc r13-8794] Fortran: fix issues with class(*) assignment [PR114827]
https://gcc.gnu.org/g:f0b88ec4ae829798cb533618f781ca467bab6b9b
commit r13-8794-gf0b88ec4ae829798cb533618f781ca467bab6b9b
Author: Harald Anlauf
Date: Mon Apr 29 19:52:52 2024 +0200
Fortran: fix issues with class(*) assignment [PR114827]
gcc/fortran/ChangeLog:
PR fortran/114827
* trans-array.cc (gfc_alloc_allocatable_for_assignment): Take into
account _len of unlimited polymorphic entities when calculating
the effective element size for allocation size and array span.
Set _len of lhs to _len of rhs.
* trans-expr.cc (trans_class_assignment): Take into account _len
of unlimited polymorphic entities for allocation size.
gcc/testsuite/ChangeLog:
PR fortran/114827
* gfortran.dg/asan/unlimited_polymorphic_34.f90: New test.
(cherry picked from commit 21e7aa5f3ea44ca2fef8deb8788edffc04901b5c)
Diff:
---
gcc/fortran/trans-array.cc | 16 +++
gcc/fortran/trans-expr.cc | 13 ++
.../gfortran.dg/asan/unlimited_polymorphic_34.f90 | 135 +
3 files changed, 164 insertions(+)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 5eef4b4ec87..f38e872f5d9 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -11008,6 +11008,19 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop,
gfc_add_modify (, linfo->delta[dim], tmp);
}
+ /* Take into account _len of unlimited polymorphic entities, so that span
+ for array descriptors and allocation sizes are computed correctly. */
+ if (UNLIMITED_POLY (expr2))
+{
+ tree len = gfc_class_len_get (TREE_OPERAND (desc2, 0));
+ len = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
+fold_convert (size_type_node, len),
+size_one_node);
+ elemsize2 = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, elemsize2,
+ fold_convert (gfc_array_index_type, len));
+}
+
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
gfc_conv_descriptor_span_set (, desc, elemsize2);
@@ -11054,6 +11067,9 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop,
gfc_add_modify (, tmp,
fold_convert (TREE_TYPE (tmp),
TYPE_SIZE_UNIT (type)));
+ else if (UNLIMITED_POLY (expr2))
+ gfc_add_modify (, tmp,
+ gfc_class_len_get (TREE_OPERAND (desc2, 0)));
else
gfc_add_modify (, tmp,
build_int_cst (TREE_TYPE (tmp), 0));
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 2b2dceb8d0f..5946aa81391 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -11668,6 +11668,19 @@ trans_class_assignment (stmtblock_t *block, gfc_expr
*lhs, gfc_expr *rhs,
old_vptr = build_int_cst (TREE_TYPE (vptr), 0);
size = gfc_vptr_size_get (rhs_vptr);
+
+ /* Take into account _len of unlimited polymorphic entities.
+TODO: handle class(*) allocatable function results on rhs. */
+ if (UNLIMITED_POLY (rhs) && rhs->expr_type == EXPR_VARIABLE)
+ {
+ tree len = trans_get_upoly_len (block, rhs);
+ len = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
+fold_convert (size_type_node, len),
+size_one_node);
+ size = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (size),
+ size, fold_convert (TREE_TYPE (size), len));
+ }
+
tmp = lse->expr;
class_han = GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
? gfc_class_data_get (tmp) : tmp;
diff --git a/gcc/testsuite/gfortran.dg/asan/unlimited_polymorphic_34.f90
b/gcc/testsuite/gfortran.dg/asan/unlimited_polymorphic_34.f90
new file mode 100644
index 000..c69158a1b55
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/asan/unlimited_polymorphic_34.f90
@@ -0,0 +1,135 @@
+! { dg-do run }
+! PR fortran/114827 - issues with class(*) assignment found by valgrind
+!
+! Contributed by Neil Carlson
+
+program main
+ implicit none
+ call run
+ call run1
+ call run2
+contains
+ ! Scalar tests
+ subroutine run ()
+character(*),parameter :: c = 'fubarfubarfubarfubarfubarfu'
+character(*,kind=4), parameter :: d = 4_"abcdef"
+complex, parameter :: z = (1.,2.)
+class(*), allocatable :: y
+
+call foo (c, y)
+select type (y)
+type is (character(*))
+! print *, y(5:6) ! ICE (-> pr114874)
+ if (y /= c) stop 1
+class default
+ stop 2
+end select
+
+call foo (z, y)
+select type (y)
+type is (complex)
+ if (y /= z) stop 3
+class default
+
[gcc r13-8793] Fortran: fix reallocation on assignment of polymorphic variables [PR110415]
https://gcc.gnu.org/g:2ebf3af1f84d54fbda172eff105a8842c685d11d
commit r13-8793-g2ebf3af1f84d54fbda172eff105a8842c685d11d
Author: Andrew Jenner
Date: Tue Nov 28 15:27:05 2023 +
Fortran: fix reallocation on assignment of polymorphic variables [PR110415]
This patch fixes two bugs related to polymorphic class assignment in the
Fortran front-end. One (described in PR110415) is an issue with the malloc
and realloc calls using the size from the old vptr rather than the new one.
The other is caused by the return value from the realloc call being ignored.
Testcases are added for these issues.
2023-11-28 Andrew Jenner
gcc/fortran/
PR fortran/110415
* trans-expr.cc (trans_class_vptr_len_assignment): Add
from_vptrp parameter. Populate it. Don't check for DECL_P
when deciding whether to create temporary.
(trans_class_pointer_fcn, gfc_trans_pointer_assignment): Add
NULL argument to trans_class_vptr_len_assignment calls.
(trans_class_assignment): Get rhs_vptr from
trans_class_vptr_len_assignment and use it for determining size
for allocation/reallocation. Use return value from realloc.
gcc/testsuite/
PR fortran/110415
* gfortran.dg/pr110415.f90: New test.
* gfortran.dg/asan/pr110415-2.f90: New test.
* gfortran.dg/asan/pr110415-3.f90: New test.
Co-Authored-By: Tobias Burnus
(cherry picked from commit b247e917ff13328298c1eecf8563b12edd7ade04)
Diff:
---
gcc/fortran/trans-expr.cc | 39 +
gcc/testsuite/gfortran.dg/asan/pr110415-2.f90 | 45
gcc/testsuite/gfortran.dg/asan/pr110415-3.f90 | 49 +++
gcc/testsuite/gfortran.dg/pr110415.f90| 20 +++
4 files changed, 139 insertions(+), 14 deletions(-)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index cfe03252582..2b2dceb8d0f 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -9748,7 +9748,8 @@ trans_get_upoly_len (stmtblock_t *block, gfc_expr *expr)
static tree
trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
gfc_expr * re, gfc_se *rse,
-tree * to_lenp, tree * from_lenp)
+tree * to_lenp, tree * from_lenp,
+tree * from_vptrp)
{
gfc_se se;
gfc_expr * vptr_expr;
@@ -9756,10 +9757,11 @@ trans_class_vptr_len_assignment (stmtblock_t *block,
gfc_expr * le,
bool set_vptr = false, temp_rhs = false;
stmtblock_t *pre = block;
tree class_expr = NULL_TREE;
+ tree from_vptr = NULL_TREE;
/* Create a temporary for complicated expressions. */
if (re->expr_type != EXPR_VARIABLE && re->expr_type != EXPR_NULL
- && rse->expr != NULL_TREE && !DECL_P (rse->expr))
+ && rse->expr != NULL_TREE)
{
if (re->ts.type == BT_CLASS && !GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
class_expr = gfc_get_class_from_expr (rse->expr);
@@ -9856,6 +9858,7 @@ trans_class_vptr_len_assignment (stmtblock_t *block,
gfc_expr * le,
tmp = rse->expr;
se.expr = gfc_class_vptr_get (tmp);
+ from_vptr = se.expr;
if (UNLIMITED_POLY (re))
from_len = gfc_class_len_get (tmp);
@@ -9877,6 +9880,7 @@ trans_class_vptr_len_assignment (stmtblock_t *block,
gfc_expr * le,
gfc_free_expr (vptr_expr);
gfc_add_block_to_block (block, );
gcc_assert (se.post.head == NULL_TREE);
+ from_vptr = se.expr;
}
gfc_add_modify (pre, lhs_vptr, fold_convert (TREE_TYPE (lhs_vptr),
se.expr));
@@ -9905,11 +9909,13 @@ trans_class_vptr_len_assignment (stmtblock_t *block,
gfc_expr * le,
}
}
- /* Return the _len trees only, when requested. */
+ /* Return the _len and _vptr trees only, when requested. */
if (to_lenp)
*to_lenp = to_len;
if (from_lenp)
*from_lenp = from_len;
+ if (from_vptrp)
+*from_vptrp = from_vptr;
return lhs_vptr;
}
@@ -9978,7 +9984,7 @@ trans_class_pointer_fcn (stmtblock_t *block, gfc_se *lse,
gfc_se *rse,
{
expr1_vptr = trans_class_vptr_len_assignment (block, expr1,
expr2, rse,
- NULL, NULL);
+ NULL, NULL, NULL);
gfc_add_block_to_block (block, >pre);
tmp = gfc_create_var (TREE_TYPE (rse->expr), "ptrtemp");
gfc_add_modify (>pre, tmp, rse->expr);
@@ -10054,7 +10060,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1,
gfc_expr * expr2)
if (non_proc_ptr_assign && expr1->ts.type == BT_CLASS)
{
trans_class_vptr_len_assignment (, expr1, expr2, ,
[gcc r13-8786] Fortran: fix dependency checks for inquiry refs [PR115039]
https://gcc.gnu.org/g:5ed32d00a7b408baa48d85e841740e73c8504d7a
commit r13-8786-g5ed32d00a7b408baa48d85e841740e73c8504d7a
Author: Harald Anlauf
Date: Fri May 10 21:18:03 2024 +0200
Fortran: fix dependency checks for inquiry refs [PR115039]
gcc/fortran/ChangeLog:
PR fortran/115039
* expr.cc (gfc_traverse_expr): An inquiry ref does not constitute
a dependency and cannot collide with a symbol.
gcc/testsuite/ChangeLog:
PR fortran/115039
* gfortran.dg/statement_function_5.f90: New test.
(cherry picked from commit d4974fd22730014e337fd7ec2471945ba8afb00e)
Diff:
---
gcc/fortran/expr.cc| 2 +-
gcc/testsuite/gfortran.dg/statement_function_5.f90 | 20
2 files changed, 21 insertions(+), 1 deletion(-)
diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc
index a6c4dccb125..4a9b29c7e9d 100644
--- a/gcc/fortran/expr.cc
+++ b/gcc/fortran/expr.cc
@@ -5483,7 +5483,7 @@ gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym,
break;
case REF_INQUIRY:
- return true;
+ return false;
default:
gcc_unreachable ();
diff --git a/gcc/testsuite/gfortran.dg/statement_function_5.f90
b/gcc/testsuite/gfortran.dg/statement_function_5.f90
new file mode 100644
index 000..bc5a5dba7a0
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/statement_function_5.f90
@@ -0,0 +1,20 @@
+! { dg-do compile }
+! PR fortran/115039
+!
+! Check that inquiry refs work with statement functions
+!
+! { dg-additional-options "-std=legacy -fdump-tree-optimized" }
+! { dg-prune-output " Obsolescent feature" }
+! { dg-final { scan-tree-dump-not "_gfortran_stop_numeric" "optimized" } }
+
+program testit
+ implicit none
+ complex :: x
+ real:: im
+ integer :: slen
+ character(5) :: s
+ im(x) = x%im + x%re + x%kind
+ slen(s) = s%len
+ if (im((1.0,3.0) + (2.0,4.0)) /= 14.) stop 1
+ if (slen('abcdef') /= 5) stop 2
+end program testit
[gcc r14-10225] Fortran: fix dependency checks for inquiry refs [PR115039]
https://gcc.gnu.org/g:edde60a53c7d4ee5a58c9835c8e1e1758ba636f7
commit r14-10225-gedde60a53c7d4ee5a58c9835c8e1e1758ba636f7
Author: Harald Anlauf
Date: Fri May 10 21:18:03 2024 +0200
Fortran: fix dependency checks for inquiry refs [PR115039]
gcc/fortran/ChangeLog:
PR fortran/115039
* expr.cc (gfc_traverse_expr): An inquiry ref does not constitute
a dependency and cannot collide with a symbol.
gcc/testsuite/ChangeLog:
PR fortran/115039
* gfortran.dg/statement_function_5.f90: New test.
(cherry picked from commit d4974fd22730014e337fd7ec2471945ba8afb00e)
Diff:
---
gcc/fortran/expr.cc| 2 +-
gcc/testsuite/gfortran.dg/statement_function_5.f90 | 20
2 files changed, 21 insertions(+), 1 deletion(-)
diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc
index 09d1ebd95d2..50e32a7a3b7 100644
--- a/gcc/fortran/expr.cc
+++ b/gcc/fortran/expr.cc
@@ -5491,7 +5491,7 @@ gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym,
break;
case REF_INQUIRY:
- return true;
+ return false;
default:
gcc_unreachable ();
diff --git a/gcc/testsuite/gfortran.dg/statement_function_5.f90
b/gcc/testsuite/gfortran.dg/statement_function_5.f90
new file mode 100644
index 000..bc5a5dba7a0
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/statement_function_5.f90
@@ -0,0 +1,20 @@
+! { dg-do compile }
+! PR fortran/115039
+!
+! Check that inquiry refs work with statement functions
+!
+! { dg-additional-options "-std=legacy -fdump-tree-optimized" }
+! { dg-prune-output " Obsolescent feature" }
+! { dg-final { scan-tree-dump-not "_gfortran_stop_numeric" "optimized" } }
+
+program testit
+ implicit none
+ complex :: x
+ real:: im
+ integer :: slen
+ character(5) :: s
+ im(x) = x%im + x%re + x%kind
+ slen(s) = s%len
+ if (im((1.0,3.0) + (2.0,4.0)) /= 14.) stop 1
+ if (slen('abcdef') /= 5) stop 2
+end program testit
[gcc r15-391] Fortran: fix frontend memleak
https://gcc.gnu.org/g:13b6ac4ebd04f0703d92828c9268b0b216890b0d commit r15-391-g13b6ac4ebd04f0703d92828c9268b0b216890b0d Author: Harald Anlauf Date: Sun May 12 21:48:03 2024 +0200 Fortran: fix frontend memleak gcc/fortran/ChangeLog: * primary.cc (gfc_match_varspec): Replace 'ref' argument to is_inquiry_ref() by NULL when the result is not needed to avoid a memleak. Diff: --- gcc/fortran/primary.cc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc index 606e84432be6..8e7833769a8f 100644 --- a/gcc/fortran/primary.cc +++ b/gcc/fortran/primary.cc @@ -2250,7 +2250,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, can be found. If this was an inquiry reference with the same name as a derived component and the associate-name type is not derived or class, this is fixed up in 'gfc_fixup_inferred_type_refs'. */ - if (mm == MATCH_YES && is_inquiry_ref (name, ) + if (mm == MATCH_YES && is_inquiry_ref (name, NULL) && !(sym->ts.type == BT_UNKNOWN && gfc_find_derived_types (sym, gfc_current_ns, name))) inquiry = true;
[gcc r15-385] Fortran: fix dependency checks for inquiry refs [PR115039]
https://gcc.gnu.org/g:d4974fd22730014e337fd7ec2471945ba8afb00e
commit r15-385-gd4974fd22730014e337fd7ec2471945ba8afb00e
Author: Harald Anlauf
Date: Fri May 10 21:18:03 2024 +0200
Fortran: fix dependency checks for inquiry refs [PR115039]
gcc/fortran/ChangeLog:
PR fortran/115039
* expr.cc (gfc_traverse_expr): An inquiry ref does not constitute
a dependency and cannot collide with a symbol.
gcc/testsuite/ChangeLog:
PR fortran/115039
* gfortran.dg/statement_function_5.f90: New test.
Diff:
---
gcc/fortran/expr.cc| 2 +-
gcc/testsuite/gfortran.dg/statement_function_5.f90 | 20
2 files changed, 21 insertions(+), 1 deletion(-)
diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc
index 66edad58278a..c883966646cb 100644
--- a/gcc/fortran/expr.cc
+++ b/gcc/fortran/expr.cc
@@ -5500,7 +5500,7 @@ gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym,
break;
case REF_INQUIRY:
- return true;
+ return false;
default:
gcc_unreachable ();
diff --git a/gcc/testsuite/gfortran.dg/statement_function_5.f90
b/gcc/testsuite/gfortran.dg/statement_function_5.f90
new file mode 100644
index ..bc5a5dba7a0f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/statement_function_5.f90
@@ -0,0 +1,20 @@
+! { dg-do compile }
+! PR fortran/115039
+!
+! Check that inquiry refs work with statement functions
+!
+! { dg-additional-options "-std=legacy -fdump-tree-optimized" }
+! { dg-prune-output " Obsolescent feature" }
+! { dg-final { scan-tree-dump-not "_gfortran_stop_numeric" "optimized" } }
+
+program testit
+ implicit none
+ complex :: x
+ real:: im
+ integer :: slen
+ character(5) :: s
+ im(x) = x%im + x%re + x%kind
+ slen(s) = s%len
+ if (im((1.0,3.0) + (2.0,4.0)) /= 14.) stop 1
+ if (slen('abcdef') /= 5) stop 2
+end program testit
[gcc r14-10191] Fortran: fix issues with class(*) assignment [PR114827]
https://gcc.gnu.org/g:a5046235509caa10a4dc309ca0a8e67892b27750
commit r14-10191-ga5046235509caa10a4dc309ca0a8e67892b27750
Author: Harald Anlauf
Date: Mon Apr 29 19:52:52 2024 +0200
Fortran: fix issues with class(*) assignment [PR114827]
gcc/fortran/ChangeLog:
PR fortran/114827
* trans-array.cc (gfc_alloc_allocatable_for_assignment): Take into
account _len of unlimited polymorphic entities when calculating
the effective element size for allocation size and array span.
Set _len of lhs to _len of rhs.
* trans-expr.cc (trans_class_assignment): Take into account _len
of unlimited polymorphic entities for allocation size.
gcc/testsuite/ChangeLog:
PR fortran/114827
* gfortran.dg/asan/unlimited_polymorphic_34.f90: New test.
(cherry picked from commit 21e7aa5f3ea44ca2fef8deb8788edffc04901b5c)
Diff:
---
gcc/fortran/trans-array.cc | 16 +++
gcc/fortran/trans-expr.cc | 13 ++
.../gfortran.dg/asan/unlimited_polymorphic_34.f90 | 135 +
3 files changed, 164 insertions(+)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 30b84762346d..7ec33fb15986 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -11278,6 +11278,19 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop,
gfc_add_modify (, linfo->delta[dim], tmp);
}
+ /* Take into account _len of unlimited polymorphic entities, so that span
+ for array descriptors and allocation sizes are computed correctly. */
+ if (UNLIMITED_POLY (expr2))
+{
+ tree len = gfc_class_len_get (TREE_OPERAND (desc2, 0));
+ len = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
+fold_convert (size_type_node, len),
+size_one_node);
+ elemsize2 = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, elemsize2,
+ fold_convert (gfc_array_index_type, len));
+}
+
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
gfc_conv_descriptor_span_set (, desc, elemsize2);
@@ -11324,6 +11337,9 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop,
gfc_add_modify (, tmp,
fold_convert (TREE_TYPE (tmp),
TYPE_SIZE_UNIT (type)));
+ else if (UNLIMITED_POLY (expr2))
+ gfc_add_modify (, tmp,
+ gfc_class_len_get (TREE_OPERAND (desc2, 0)));
else
gfc_add_modify (, tmp,
build_int_cst (TREE_TYPE (tmp), 0));
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 0280c441ced3..bc8eb419cffe 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -11991,6 +11991,19 @@ trans_class_assignment (stmtblock_t *block, gfc_expr
*lhs, gfc_expr *rhs,
old_vptr = build_int_cst (TREE_TYPE (vptr), 0);
size = gfc_vptr_size_get (rhs_vptr);
+
+ /* Take into account _len of unlimited polymorphic entities.
+TODO: handle class(*) allocatable function results on rhs. */
+ if (UNLIMITED_POLY (rhs) && rhs->expr_type == EXPR_VARIABLE)
+ {
+ tree len = trans_get_upoly_len (block, rhs);
+ len = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
+fold_convert (size_type_node, len),
+size_one_node);
+ size = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (size),
+ size, fold_convert (TREE_TYPE (size), len));
+ }
+
tmp = lse->expr;
class_han = GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
? gfc_class_data_get (tmp) : tmp;
diff --git a/gcc/testsuite/gfortran.dg/asan/unlimited_polymorphic_34.f90
b/gcc/testsuite/gfortran.dg/asan/unlimited_polymorphic_34.f90
new file mode 100644
index ..c69158a1b55f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/asan/unlimited_polymorphic_34.f90
@@ -0,0 +1,135 @@
+! { dg-do run }
+! PR fortran/114827 - issues with class(*) assignment found by valgrind
+!
+! Contributed by Neil Carlson
+
+program main
+ implicit none
+ call run
+ call run1
+ call run2
+contains
+ ! Scalar tests
+ subroutine run ()
+character(*),parameter :: c = 'fubarfubarfubarfubarfubarfu'
+character(*,kind=4), parameter :: d = 4_"abcdef"
+complex, parameter :: z = (1.,2.)
+class(*), allocatable :: y
+
+call foo (c, y)
+select type (y)
+type is (character(*))
+! print *, y(5:6) ! ICE (-> pr114874)
+ if (y /= c) stop 1
+class default
+ stop 2
+end select
+
+call foo (z, y)
+select type (y)
+type is (complex)
+ if (y /= z) stop 3
+class default
[gcc r15-168] Fortran: fix issues with class(*) assignment [PR114827]
https://gcc.gnu.org/g:21e7aa5f3ea44ca2fef8deb8788edffc04901b5c
commit r15-168-g21e7aa5f3ea44ca2fef8deb8788edffc04901b5c
Author: Harald Anlauf
Date: Mon Apr 29 19:52:52 2024 +0200
Fortran: fix issues with class(*) assignment [PR114827]
gcc/fortran/ChangeLog:
PR fortran/114827
* trans-array.cc (gfc_alloc_allocatable_for_assignment): Take into
account _len of unlimited polymorphic entities when calculating
the effective element size for allocation size and array span.
Set _len of lhs to _len of rhs.
* trans-expr.cc (trans_class_assignment): Take into account _len
of unlimited polymorphic entities for allocation size.
gcc/testsuite/ChangeLog:
PR fortran/114827
* gfortran.dg/asan/unlimited_polymorphic_34.f90: New test.
Diff:
---
gcc/fortran/trans-array.cc | 16 +++
gcc/fortran/trans-expr.cc | 13 ++
.../gfortran.dg/asan/unlimited_polymorphic_34.f90 | 135 +
3 files changed, 164 insertions(+)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 30b84762346..7ec33fb1598 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -11278,6 +11278,19 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop,
gfc_add_modify (, linfo->delta[dim], tmp);
}
+ /* Take into account _len of unlimited polymorphic entities, so that span
+ for array descriptors and allocation sizes are computed correctly. */
+ if (UNLIMITED_POLY (expr2))
+{
+ tree len = gfc_class_len_get (TREE_OPERAND (desc2, 0));
+ len = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
+fold_convert (size_type_node, len),
+size_one_node);
+ elemsize2 = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, elemsize2,
+ fold_convert (gfc_array_index_type, len));
+}
+
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
gfc_conv_descriptor_span_set (, desc, elemsize2);
@@ -11324,6 +11337,9 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop,
gfc_add_modify (, tmp,
fold_convert (TREE_TYPE (tmp),
TYPE_SIZE_UNIT (type)));
+ else if (UNLIMITED_POLY (expr2))
+ gfc_add_modify (, tmp,
+ gfc_class_len_get (TREE_OPERAND (desc2, 0)));
else
gfc_add_modify (, tmp,
build_int_cst (TREE_TYPE (tmp), 0));
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 0280c441ced..bc8eb419cff 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -11991,6 +11991,19 @@ trans_class_assignment (stmtblock_t *block, gfc_expr
*lhs, gfc_expr *rhs,
old_vptr = build_int_cst (TREE_TYPE (vptr), 0);
size = gfc_vptr_size_get (rhs_vptr);
+
+ /* Take into account _len of unlimited polymorphic entities.
+TODO: handle class(*) allocatable function results on rhs. */
+ if (UNLIMITED_POLY (rhs) && rhs->expr_type == EXPR_VARIABLE)
+ {
+ tree len = trans_get_upoly_len (block, rhs);
+ len = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
+fold_convert (size_type_node, len),
+size_one_node);
+ size = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (size),
+ size, fold_convert (TREE_TYPE (size), len));
+ }
+
tmp = lse->expr;
class_han = GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
? gfc_class_data_get (tmp) : tmp;
diff --git a/gcc/testsuite/gfortran.dg/asan/unlimited_polymorphic_34.f90
b/gcc/testsuite/gfortran.dg/asan/unlimited_polymorphic_34.f90
new file mode 100644
index 000..c69158a1b55
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/asan/unlimited_polymorphic_34.f90
@@ -0,0 +1,135 @@
+! { dg-do run }
+! PR fortran/114827 - issues with class(*) assignment found by valgrind
+!
+! Contributed by Neil Carlson
+
+program main
+ implicit none
+ call run
+ call run1
+ call run2
+contains
+ ! Scalar tests
+ subroutine run ()
+character(*),parameter :: c = 'fubarfubarfubarfubarfubarfu'
+character(*,kind=4), parameter :: d = 4_"abcdef"
+complex, parameter :: z = (1.,2.)
+class(*), allocatable :: y
+
+call foo (c, y)
+select type (y)
+type is (character(*))
+! print *, y(5:6) ! ICE (-> pr114874)
+ if (y /= c) stop 1
+class default
+ stop 2
+end select
+
+call foo (z, y)
+select type (y)
+type is (complex)
+ if (y /= z) stop 3
+class default
+ stop 4
+end select
+
+call foo (d, y)
+select type (y)
+type
[gcc r12-10398] Fortran: Fix assumed length chars and len inquiry [PR103716]
https://gcc.gnu.org/g:b482968801158116dd8ba3b15a4c29143b2a423a
commit r12-10398-gb482968801158116dd8ba3b15a4c29143b2a423a
Author: Paul Thomas
Date: Tue May 23 06:46:37 2023 +0100
Fortran: Fix assumed length chars and len inquiry [PR103716]
2023-05-23 Paul Thomas
gcc/fortran
PR fortran/103716
* resolve.cc (gfc_resolve_ref): Conversion of array_ref into an
element should be done for all characters without a len expr,
not just deferred lens, and for integer expressions.
* trans-expr.cc (conv_inquiry): For len and kind inquiry refs,
set the se string_length to NULL_TREE.
gcc/testsuite/
PR fortran/103716
* gfortran.dg/pr103716.f90 : New test.
(cherry picked from commit 842a432b02238361ecc601d301ac400a7f30f4fa)
Diff:
---
gcc/fortran/resolve.cc | 4 +++-
gcc/fortran/trans-expr.cc | 2 ++
gcc/testsuite/gfortran.dg/pr103716.f90 | 15 +++
3 files changed, 20 insertions(+), 1 deletion(-)
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 9264322f671..6a7325e15e7 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -5461,7 +5461,9 @@ gfc_resolve_ref (gfc_expr *expr)
case REF_INQUIRY:
/* Implement requirement in note 9.7 of F2018 that the result of the
LEN inquiry be a scalar. */
- if (ref->u.i == INQUIRY_LEN && array_ref && expr->ts.deferred)
+ if (ref->u.i == INQUIRY_LEN && array_ref
+ && ((expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->length)
+ || expr->ts.type == BT_INTEGER))
{
array_ref->u.ar.type = AR_ELEMENT;
expr->rank = 0;
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 11ee1931b8e..e78a01003c9 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -2854,11 +2854,13 @@ conv_inquiry (gfc_se * se, gfc_ref * ref, gfc_expr
*expr, gfc_typespec *ts)
case INQUIRY_KIND:
res = build_int_cst (gfc_typenode_for_spec (>ts),
ts->kind);
+ se->string_length = NULL_TREE;
break;
case INQUIRY_LEN:
res = fold_convert (gfc_typenode_for_spec (>ts),
se->string_length);
+ se->string_length = NULL_TREE;
break;
default:
diff --git a/gcc/testsuite/gfortran.dg/pr103716.f90
b/gcc/testsuite/gfortran.dg/pr103716.f90
new file mode 100644
index 000..4f78900839e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr103716.f90
@@ -0,0 +1,15 @@
+! { dg-do compile }
+!
+! The gimplifier used to throw a fit on thes two functions.
+!
+! Contributed by Gerhard Steinmetz
+!
+function f1(x)
+ character(*) :: x(*)
+ print *, g(x%len)
+end
+
+function f2(x)
+ character(*) :: x(3)
+ print *, g(x%len)
+end
[gcc r12-10396] gfortran: Allow ref'ing PDT's len() in parameter-initializer.
https://gcc.gnu.org/g:8ad460ca8824f7e29e38a63f9cb4a9a3b96d506f
commit r12-10396-g8ad460ca8824f7e29e38a63f9cb4a9a3b96d506f
Author: Andre Vehreschild
Date: Wed Jul 12 12:51:30 2023 +0200
gfortran: Allow ref'ing PDT's len() in parameter-initializer.
Fix declaring a parameter initialized using a pdt_len reference
not simplifying the reference to a constant.
2023-07-12 Andre Vehreschild
gcc/fortran/ChangeLog:
PR fortran/102003
* expr.cc (find_inquiry_ref): Replace len of pdt_string by
constant.
(simplify_ref_chain): Ensure input to find_inquiry_ref is
NULL.
(gfc_match_init_expr): Prevent PDT analysis for function calls.
(gfc_pdt_find_component_copy_initializer): Get the initializer
value for given component.
* gfortran.h (gfc_pdt_find_component_copy_initializer): New
function.
* simplify.cc (gfc_simplify_len): Replace len() of PDT with pdt
component ref or constant.
gcc/testsuite/ChangeLog:
* gfortran.dg/pdt_33.f03: New test.
(cherry picked from commit f9182da3213aa57c16dd0b52862126de4a259f6a)
Diff:
---
gcc/fortran/expr.cc | 31 ++--
gcc/fortran/gfortran.h | 1 +
gcc/fortran/simplify.cc | 57
gcc/testsuite/gfortran.dg/pdt_33.f03 | 21 +
4 files changed, 94 insertions(+), 16 deletions(-)
diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc
index c04403a2b89..5640d215925 100644
--- a/gcc/fortran/expr.cc
+++ b/gcc/fortran/expr.cc
@@ -1850,6 +1850,13 @@ find_inquiry_ref (gfc_expr *p, gfc_expr **newp)
else if (tmp->expr_type == EXPR_CONSTANT)
*newp = gfc_get_int_expr (gfc_default_integer_kind,
NULL, tmp->value.character.length);
+ else if (gfc_init_expr_flag
+ && tmp->ts.u.cl->length->symtree->n.sym->attr.pdt_len)
+ *newp = gfc_pdt_find_component_copy_initializer (tmp->symtree->n
+.sym,
+tmp->ts.u.cl
+->length->symtree
+->n.sym->name);
else
goto cleanup;
@@ -1890,7 +1897,9 @@ find_inquiry_ref (gfc_expr *p, gfc_expr **newp)
mpc_imagref (tmp->value.complex), GFC_RND_MODE);
break;
}
- tmp = gfc_copy_expr (*newp);
+ // TODO: Fix leaking expr tmp, when simplify is done twice.
+ if (inquiry->next)
+ gfc_replace_expr (tmp, *newp);
}
if (!(*newp))
@@ -2055,7 +2064,7 @@ static bool
simplify_ref_chain (gfc_ref *ref, int type, gfc_expr **p)
{
int n;
- gfc_expr *newp;
+ gfc_expr *newp = NULL;
for (; ref; ref = ref->next)
{
@@ -3217,7 +3226,7 @@ gfc_match_init_expr (gfc_expr **result)
return m;
}
- if (gfc_derived_parameter_expr (expr))
+ if (expr->expr_type != EXPR_FUNCTION && gfc_derived_parameter_expr (expr))
{
*result = expr;
gfc_init_expr_flag = false;
@@ -6530,3 +6539,19 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer,
bool alloc_obj,
return true;
}
+
+gfc_expr*
+gfc_pdt_find_component_copy_initializer (gfc_symbol *sym, const char *name)
+{
+ /* The actual length of a pdt is in its components. In the
+ initializer of the current ref is only the default value.
+ Therefore traverse the chain of components and pick the correct
+ one's initializer expressions. */
+ for (gfc_component *comp = sym->ts.u.derived->components; comp != NULL;
+ comp = comp->next)
+{
+ if (!strcmp (comp->name, name))
+ return gfc_copy_expr (comp->initializer);
+}
+ return NULL;
+}
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 98c0cd39503..0b0a8fe7118 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3667,6 +3667,7 @@ gfc_expr* gfc_find_stat_co (gfc_expr *);
gfc_expr* gfc_build_intrinsic_call (gfc_namespace *, gfc_isym_id, const char*,
locus, unsigned, ...);
bool gfc_check_vardef_context (gfc_expr*, bool, bool, bool, const char*);
+gfc_expr* gfc_pdt_find_component_copy_initializer (gfc_symbol *, const char *);
/* st.cc */
diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc
index 83b4e7d3493..a10f79c4a93 100644
--- a/gcc/fortran/simplify.cc
+++ b/gcc/fortran/simplify.cc
@@ -4525,19 +4525,50 @@ gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
return range_check (result, "LEN");
}
else if (e->expr_type == EXPR_VARIABLE && e->ts.type == BT_CHARACTER
- && e->symtree->n.sym
- && e->symtree->n.sym->ts.type != BT_DERIVED
- && e->symtree->n.sym->assoc &&
[gcc r13-8651] gfortran: Allow ref'ing PDT's len() in parameter-initializer.
https://gcc.gnu.org/g:e207b67fcde224f2be0c79bf2a24f7fc75b6f481
commit r13-8651-ge207b67fcde224f2be0c79bf2a24f7fc75b6f481
Author: Andre Vehreschild
Date: Wed Jul 12 12:51:30 2023 +0200
gfortran: Allow ref'ing PDT's len() in parameter-initializer.
Fix declaring a parameter initialized using a pdt_len reference
not simplifying the reference to a constant.
2023-07-12 Andre Vehreschild
gcc/fortran/ChangeLog:
PR fortran/102003
* expr.cc (find_inquiry_ref): Replace len of pdt_string by
constant.
(simplify_ref_chain): Ensure input to find_inquiry_ref is
NULL.
(gfc_match_init_expr): Prevent PDT analysis for function calls.
(gfc_pdt_find_component_copy_initializer): Get the initializer
value for given component.
* gfortran.h (gfc_pdt_find_component_copy_initializer): New
function.
* simplify.cc (gfc_simplify_len): Replace len() of PDT with pdt
component ref or constant.
gcc/testsuite/ChangeLog:
* gfortran.dg/pdt_33.f03: New test.
(cherry picked from commit f9182da3213aa57c16dd0b52862126de4a259f6a)
Diff:
---
gcc/fortran/expr.cc | 31 ++--
gcc/fortran/gfortran.h | 1 +
gcc/fortran/simplify.cc | 57
gcc/testsuite/gfortran.dg/pdt_33.f03 | 21 +
4 files changed, 94 insertions(+), 16 deletions(-)
diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc
index 8b9c93940c8..a6c4dccb125 100644
--- a/gcc/fortran/expr.cc
+++ b/gcc/fortran/expr.cc
@@ -1854,6 +1854,13 @@ find_inquiry_ref (gfc_expr *p, gfc_expr **newp)
else if (tmp->expr_type == EXPR_CONSTANT)
*newp = gfc_get_int_expr (gfc_default_integer_kind,
NULL, tmp->value.character.length);
+ else if (gfc_init_expr_flag
+ && tmp->ts.u.cl->length->symtree->n.sym->attr.pdt_len)
+ *newp = gfc_pdt_find_component_copy_initializer (tmp->symtree->n
+.sym,
+tmp->ts.u.cl
+->length->symtree
+->n.sym->name);
else
goto cleanup;
@@ -1894,7 +1901,9 @@ find_inquiry_ref (gfc_expr *p, gfc_expr **newp)
mpc_imagref (tmp->value.complex), GFC_RND_MODE);
break;
}
- tmp = gfc_copy_expr (*newp);
+ // TODO: Fix leaking expr tmp, when simplify is done twice.
+ if (inquiry->next)
+ gfc_replace_expr (tmp, *newp);
}
if (!(*newp))
@@ -2059,7 +2068,7 @@ static bool
simplify_ref_chain (gfc_ref *ref, int type, gfc_expr **p)
{
int n;
- gfc_expr *newp;
+ gfc_expr *newp = NULL;
for (; ref; ref = ref->next)
{
@@ -3221,7 +3230,7 @@ gfc_match_init_expr (gfc_expr **result)
return m;
}
- if (gfc_derived_parameter_expr (expr))
+ if (expr->expr_type != EXPR_FUNCTION && gfc_derived_parameter_expr (expr))
{
*result = expr;
gfc_init_expr_flag = false;
@@ -6533,3 +6542,19 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer,
bool alloc_obj,
return true;
}
+
+gfc_expr*
+gfc_pdt_find_component_copy_initializer (gfc_symbol *sym, const char *name)
+{
+ /* The actual length of a pdt is in its components. In the
+ initializer of the current ref is only the default value.
+ Therefore traverse the chain of components and pick the correct
+ one's initializer expressions. */
+ for (gfc_component *comp = sym->ts.u.derived->components; comp != NULL;
+ comp = comp->next)
+{
+ if (!strcmp (comp->name, name))
+ return gfc_copy_expr (comp->initializer);
+}
+ return NULL;
+}
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 47414f73254..c1430f7dfec 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3716,6 +3716,7 @@ gfc_expr* gfc_find_stat_co (gfc_expr *);
gfc_expr* gfc_build_intrinsic_call (gfc_namespace *, gfc_isym_id, const char*,
locus, unsigned, ...);
bool gfc_check_vardef_context (gfc_expr*, bool, bool, bool, const char*);
+gfc_expr* gfc_pdt_find_component_copy_initializer (gfc_symbol *, const char *);
/* st.cc */
diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc
index b65854c1021..fe700097b7b 100644
--- a/gcc/fortran/simplify.cc
+++ b/gcc/fortran/simplify.cc
@@ -4566,19 +4566,50 @@ gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
return range_check (result, "LEN");
}
else if (e->expr_type == EXPR_VARIABLE && e->ts.type == BT_CHARACTER
- && e->symtree->n.sym
- && e->symtree->n.sym->ts.type != BT_DERIVED
- && e->symtree->n.sym->assoc &&
[gcc r14-10097] Fortran: check C_SIZEOF on additions from TS29113/F2018 [PR103496]
https://gcc.gnu.org/g:0bf94da59feab2c72a02c91df310a36d33dfd1f7
commit r14-10097-g0bf94da59feab2c72a02c91df310a36d33dfd1f7
Author: Harald Anlauf
Date: Tue Apr 23 20:21:43 2024 +0200
Fortran: check C_SIZEOF on additions from TS29113/F2018 [PR103496]
gcc/testsuite/ChangeLog:
PR fortran/103496
* gfortran.dg/c_sizeof_8.f90: New test.
Diff:
---
gcc/testsuite/gfortran.dg/c_sizeof_8.f90 | 23 +++
1 file changed, 23 insertions(+)
diff --git a/gcc/testsuite/gfortran.dg/c_sizeof_8.f90
b/gcc/testsuite/gfortran.dg/c_sizeof_8.f90
new file mode 100644
index 000..0ae284436d0
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c_sizeof_8.f90
@@ -0,0 +1,23 @@
+! { dg-do run }
+!
+! PR fortran/103496
+!
+! Test that C_SIZEOF returns the expected results
+
+program pr103496
+ use iso_c_binding
+ implicit none
+ integer :: a(6)
+ integer, pointer :: p(:)
+
+ if (c_sizeof(a) /= 6*4) stop 1
+ if (c_sizeof(a(1))/= 4) stop 2
+ if (c_sizeof(a(:))/= 6*4) stop 3
+ if (c_sizeof(a(2::2)) /= 3*4) stop 4
+
+ allocate(p(5))
+ if (c_sizeof(p) /= 5*4) stop 5
+ if (c_sizeof(p(1))/= 4) stop 6
+ if (c_sizeof(p(:))/= 5*4) stop 7
+ if (c_sizeof(p(2::2)) /= 2*4) stop 8
+end
[gcc r14-9996] Fortran: ALLOCATE of fixed-length CHARACTER with SOURCE/MOLD [PR113793]
https://gcc.gnu.org/g:48024a99e3c2ae522d0026eedd591390506b68ca
commit r14-9996-g48024a99e3c2ae522d0026eedd591390506b68ca
Author: Harald Anlauf
Date: Sat Apr 13 19:09:24 2024 +0200
Fortran: ALLOCATE of fixed-length CHARACTER with SOURCE/MOLD [PR113793]
F2008 requires for ALLOCATE with SOURCE= or MOLD= specifier that the kind
type parameters of allocate-object and source-expr have the same values.
Add compile-time diagnostics for different character length and a runtime
check (under -fcheck=bounds). Use length from allocate-object to prevent
heap corruption and to allow string padding or truncation on assignment.
gcc/fortran/ChangeLog:
PR fortran/113793
* resolve.cc (resolve_allocate_expr): Reject ALLOCATE with SOURCE=
or MOLD= specifier for unequal length.
* trans-stmt.cc (gfc_trans_allocate): If an allocatable character
variable has fixed length, use it and do not use the source length.
With bounds-checking enabled, add a runtime check for same length.
gcc/testsuite/ChangeLog:
PR fortran/113793
* gfortran.dg/allocate_with_source_29.f90: New test.
* gfortran.dg/allocate_with_source_30.f90: New test.
* gfortran.dg/allocate_with_source_31.f90: New test.
Diff:
---
gcc/fortran/resolve.cc | 10 +
gcc/fortran/trans-stmt.cc | 36 +--
.../gfortran.dg/allocate_with_source_29.f90| 48
.../gfortran.dg/allocate_with_source_30.f90| 51 ++
.../gfortran.dg/allocate_with_source_31.f90| 38
5 files changed, 179 insertions(+), 4 deletions(-)
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 4cbf7186119..6b3e5ba4fcb 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -8278,6 +8278,16 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool
*array_alloc_wo_spec)
goto failure;
}
+ /* Check F2008:C639: "Corresponding kind type parameters of
+allocate-object and source-expr shall have the same values." */
+ if (e->ts.type == BT_CHARACTER
+ && !e->ts.deferred
+ && e->ts.u.cl->length
+ && code->expr3->ts.type == BT_CHARACTER
+ && !gfc_check_same_strlen (e, code->expr3, "ALLOCATE with "
+"SOURCE= or MOLD= specifier"))
+ goto failure;
+
/* Check TS18508, C702/C703. */
if (code->expr3->ts.type == BT_DERIVED
&& ((codimension && gfc_expr_attr (code->expr3).event_comp)
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index 7997c167bae..c34e0b4c0cd 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -6829,10 +6829,26 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist
*omp_allocate)
in the array is needed, which is the product of the len and
esize for char arrays. For unlimited polymorphics len can be
zero, therefore take the maximum of len and one. */
+ tree lhs_len;
+
+ /* If an allocatable character variable has fixed length, use it.
+Otherwise use source length. As different lengths are not
+allowed by the standard, generate a runtime check. */
+ if (expr->ts.type == BT_CHARACTER && !expr->ts.deferred)
+ {
+ gfc_trans_same_strlen_check ("ALLOCATE with SOURCE= or MOLD=",
+ >expr3->where,
+ se.string_length, expr3_len,
+ );
+ lhs_len = fold_convert (TREE_TYPE (expr3_len), se.string_length);
+ }
+ else
+ lhs_len = expr3_len;
+
tmp = fold_build2_loc (input_location, MAX_EXPR,
TREE_TYPE (expr3_len),
-expr3_len, fold_convert (TREE_TYPE (expr3_len),
- integer_one_node));
+lhs_len, fold_convert (TREE_TYPE (expr3_len),
+ integer_one_node));
tmp = fold_build2_loc (input_location, MULT_EXPR,
TREE_TYPE (expr3_esize), expr3_esize,
fold_convert (TREE_TYPE (expr3_esize), tmp));
@@ -6877,10 +6893,22 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist
*omp_allocate)
allocate.
expr3_len is set when expr3 is an unlimited polymorphic
-object or a deferred length string. */
+object or a deferred length string.
+
+If an allocatable character variable has fixed length, use it.
+Otherwise use source length. As different lengths are not
+allowed by the
[gcc r14-9893] Fortran: fix argument checking of intrinsics C_SIZEOF, C_F_POINTER [PR106500]
https://gcc.gnu.org/g:ded646c91d2c0fb908faf6fa8fe1df0d7df49d16
commit r14-9893-gded646c91d2c0fb908faf6fa8fe1df0d7df49d16
Author: Harald Anlauf
Date: Tue Apr 9 23:07:59 2024 +0200
Fortran: fix argument checking of intrinsics C_SIZEOF, C_F_POINTER
[PR106500]
The interpretation of the F2018 standard regarding valid arguments to the
intrinsic C_SIZEOF(X) was clarified in an edit to 18-007r1:
https://j3-fortran.org/doc/year/22/22-101r1.txt
loosening restrictions and giving examples. The F2023 text has:
! F2023:18.2.3.8 C_SIZEOF (X)
!
! X shall be a data entity with interoperable type and type parameters,
! and shall not be an assumed-size array, an assumed-rank array that
! is associated with an assumed-size array, an unallocated allocatable
! variable, or a pointer that is not associated.
where
! 3.41 data entity
! data object, result of the evaluation of an expression, or the
! result of the execution of a function reference
Update the checking code for interoperable arguments accordingly, and extend
to reject functions returning pointer as FPTR argument to C_F_POINTER.
gcc/fortran/ChangeLog:
PR fortran/106500
* check.cc (is_c_interoperable): Fix checks for C_SIZEOF.
(gfc_check_c_f_pointer): Reject function returning a pointer as
FPTR,
and improve an error message.
gcc/testsuite/ChangeLog:
PR fortran/106500
* gfortran.dg/c_sizeof_6.f90: Remove wrong dg-error.
* gfortran.dg/sizeof_2.f90: Adjust pattern.
* gfortran.dg/c_f_pointer_tests_9.f90: New test.
* gfortran.dg/c_sizeof_7.f90: New test.
Diff:
---
gcc/fortran/check.cc | 26 --
gcc/testsuite/gfortran.dg/c_f_pointer_tests_9.f90 | 37
gcc/testsuite/gfortran.dg/c_sizeof_6.f90 | 2 +-
gcc/testsuite/gfortran.dg/c_sizeof_7.f90 | 42 +++
gcc/testsuite/gfortran.dg/sizeof_2.f90| 2 +-
5 files changed, 96 insertions(+), 13 deletions(-)
diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index db74dcf3f40..2f50d84b876 100644
--- a/gcc/fortran/check.cc
+++ b/gcc/fortran/check.cc
@@ -5299,18 +5299,14 @@ is_c_interoperable (gfc_expr *expr, const char **msg,
bool c_loc, bool c_f_ptr)
return false;
}
- if (!c_loc && expr->rank > 0 && expr->expr_type != EXPR_ARRAY)
+ /* Checks for C_SIZEOF need to take into account edits to 18-007r1, see
+ https://j3-fortran.org/doc/year/22/22-101r1.txt . */
+ if (!c_loc && !c_f_ptr && expr->rank > 0 && expr->expr_type == EXPR_VARIABLE)
{
gfc_array_ref *ar = gfc_find_array_ref (expr);
- if (ar->type != AR_FULL)
+ if (ar->type == AR_FULL && ar->as->type == AS_ASSUMED_SIZE)
{
- *msg = "Only whole-arrays are interoperable";
- return false;
- }
- if (!c_f_ptr && ar->as->type != AS_EXPLICIT
- && ar->as->type != AS_ASSUMED_SIZE)
- {
- *msg = "Only explicit-size and assumed-size arrays are interoperable";
+ *msg = "Assumed-size arrays are not interoperable";
return false;
}
}
@@ -5475,9 +5471,17 @@ gfc_check_c_f_pointer (gfc_expr *cptr, gfc_expr *fptr,
gfc_expr *shape)
return false;
}
+ if (fptr->ts.type == BT_PROCEDURE && attr.function)
+{
+ gfc_error ("FPTR argument to C_F_POINTER at %L is a function "
+"returning a pointer", >where);
+ return false;
+}
+
if (fptr->rank > 0 && !is_c_interoperable (fptr, , false, true))
-return gfc_notify_std (GFC_STD_F2018, "Noninteroperable array FPTR "
- "at %L to C_F_POINTER: %s", >where, msg);
+return gfc_notify_std (GFC_STD_F2018,
+ "Noninteroperable array FPTR argument to "
+ "C_F_POINTER at %L: %s", >where, msg);
return true;
}
diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_tests_9.f90
b/gcc/testsuite/gfortran.dg/c_f_pointer_tests_9.f90
new file mode 100644
index 000..8c8b4a713a4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c_f_pointer_tests_9.f90
@@ -0,0 +1,37 @@
+! { dg-do compile }
+!
+! A function returning a pointer cannot be interoperable
+! and cannot be used as FPTR argument to C_F_POINTER.
+
+subroutine s ()
+ use, intrinsic :: iso_c_binding
+ implicit none
+ type(c_ptr) :: cPtr
+ call c_f_pointer (cPtr, p0)! { dg-error "function returning a
pointer" }
+ call c_f_pointer (cPtr, p1, shape=[2]) ! { dg-error "function returning a
pointer" }
+contains
+ function p0 ()
+integer, pointer :: p0
+nullify (p0)
+ end
+ function p1 ()
+integer, pointer :: p1(:)
+nullify (p1)
+ end
+ function fp0 ()
+integer, pointer :: fp0
+call c_f_pointer (cPtr, fp0)! valid here
+ end
+ function fp1
[gcc r11-11311] Fortran: fix DATA and derived types with pointer components [PR114474]
https://gcc.gnu.org/g:619fc13043c86d616ef57cb31f8ac5d29b059ade
commit r11-11311-g619fc13043c86d616ef57cb31f8ac5d29b059ade
Author: Harald Anlauf
Date: Wed Mar 27 21:18:04 2024 +0100
Fortran: fix DATA and derived types with pointer components [PR114474]
When matching actual arguments in match_actual_arg, these are initially
treated as a possible dummy procedure, assuming that the correct type is
determined later. This resolution could fail when the procedure is a
derived type constructor with a pointer component and appears in a DATA
statement, where the pointer shall be associated with an initial data
target. Check for those cases where the type obviously has not been
resolved yet, and which were missed because there was no component
reference.
gcc/fortran/ChangeLog:
PR fortran/114474
* primary.c (gfc_variable_attr): Catch variables used in structure
constructors within DATA statements that are still tagged with a
temporary type BT_PROCEDURE from match_actual_arg and which have the
target attribute, and fix their typespec.
gcc/testsuite/ChangeLog:
PR fortran/114474
* gfortran.dg/data_pointer_3.f90: New test.
(cherry picked from commit bbb7c513dddc5c9b2d5e9b78bc1c2f85a0cfe07e)
Diff:
---
gcc/fortran/primary.c| 12 +
gcc/testsuite/gfortran.dg/data_pointer_3.f90 | 77
2 files changed, 89 insertions(+)
diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index 5cad2d2682b..79a2201c812 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -2663,6 +2663,18 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
if (ts != NULL && expr->ts.type == BT_UNKNOWN)
*ts = sym->ts;
+ /* Catch left-overs from match_actual_arg, where an actual argument of a
+ procedure is given a temporary ts.type == BT_PROCEDURE. The fixup is
+ needed for structure constructors in DATA statements, where a pointer
+ is associated with a data target, and the argument has not been fully
+ resolved yet. Components references are dealt with further below. */
+ if (ts != NULL
+ && expr->ts.type == BT_PROCEDURE
+ && expr->ref == NULL
+ && attr.flavor != FL_PROCEDURE
+ && attr.target)
+*ts = sym->ts;
+
has_inquiry_part = false;
for (ref = expr->ref; ref; ref = ref->next)
if (ref->type == REF_INQUIRY)
diff --git a/gcc/testsuite/gfortran.dg/data_pointer_3.f90
b/gcc/testsuite/gfortran.dg/data_pointer_3.f90
new file mode 100644
index 000..49c288e93b9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/data_pointer_3.f90
@@ -0,0 +1,77 @@
+! { dg-do compile }
+! PR fortran/114474 - DATA and derived types with pointer components
+
+program pr114474
+ implicit none
+ integer, target :: ii = 42! initial data target
+
+ integer, target :: jj = 24
+ integer, pointer:: qq => jj
+ ! ii and jj resolve slightly differently when the data statement below
+ ! is reached, as jj is resolved outside the structure constructor first
+
+ type t
+ integer, pointer :: h
+ end type t
+
+ integer, target :: kk(7) = 23
+ integer, pointer:: ll(:) => kk
+
+ type t1
+ integer :: m(7)
+ end type t1
+
+ type(t) :: x1, x2, x3, x4, x5
+ type(t), parameter :: z1 = t(null())
+
+ type(t1), target:: tt = t1([1,2,3,4,5,6,7])
+ type(t1), parameter :: vv = t1(22)
+ type(t1):: w1, w2
+ integer, pointer :: p1(:) => tt% m
+
+ data x1 / t(null()) /
+ data x2 / t(ii) / ! ii is initial data target
+ data x3 / t(jj) / ! jj is resolved differently...
+ data x4 / t(tt%m(3)) / ! pointer association with 3rd element
+
+ data w1 / t1(12) /
+ data w2 / t1(vv%m) /
+
+ if ( associated (x1% h)) stop 1
+ if (.not. associated (x2% h)) stop 2
+ if (.not. associated (x3% h)) stop 3
+ if (.not. associated (x4% h)) stop 4
+ if (x2% h /= 42) stop 5
+ if (x3% h /= 24) stop 6
+ if (x4% h /= 3) stop 7
+
+ if (any (w1%m /= 12 )) stop 8
+ if (any (w2%m /= vv%m)) stop 9
+end
+
+
+subroutine sub
+ implicit none
+
+ interface
+ real function myfun (x)
+ real, intent(in) :: x
+ end function myfun
+ end interface
+
+ type u
+ procedure(myfun), pointer, nopass :: p
+ end type u
+
+ type(u):: u3 = u(null())
+ type(u), parameter :: u4 = u(null())
+ type(u):: u1, u2
+
+ data u1 / u(null()) /
+ data u2 / u(myfun) /
+end
+
+real function myfun (x)
+ real, intent(in) :: x
+ myfun = x
+end function myfun
[gcc r12-10314] Fortran: fix DATA and derived types with pointer components [PR114474]
https://gcc.gnu.org/g:88abe04de2f16f773126f3908632a27568330cc9
commit r12-10314-g88abe04de2f16f773126f3908632a27568330cc9
Author: Harald Anlauf
Date: Wed Mar 27 21:18:04 2024 +0100
Fortran: fix DATA and derived types with pointer components [PR114474]
When matching actual arguments in match_actual_arg, these are initially
treated as a possible dummy procedure, assuming that the correct type is
determined later. This resolution could fail when the procedure is a
derived type constructor with a pointer component and appears in a DATA
statement, where the pointer shall be associated with an initial data
target. Check for those cases where the type obviously has not been
resolved yet, and which were missed because there was no component
reference.
gcc/fortran/ChangeLog:
PR fortran/114474
* primary.cc (gfc_variable_attr): Catch variables used in structure
constructors within DATA statements that are still tagged with a
temporary type BT_PROCEDURE from match_actual_arg and which have the
target attribute, and fix their typespec.
gcc/testsuite/ChangeLog:
PR fortran/114474
* gfortran.dg/data_pointer_3.f90: New test.
(cherry picked from commit bbb7c513dddc5c9b2d5e9b78bc1c2f85a0cfe07e)
Diff:
---
gcc/fortran/primary.cc | 12 +
gcc/testsuite/gfortran.dg/data_pointer_3.f90 | 77
2 files changed, 89 insertions(+)
diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index 1ae6a12e0b7..78295c54b6c 100644
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
@@ -2664,6 +2664,18 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
if (ts != NULL && expr->ts.type == BT_UNKNOWN)
*ts = sym->ts;
+ /* Catch left-overs from match_actual_arg, where an actual argument of a
+ procedure is given a temporary ts.type == BT_PROCEDURE. The fixup is
+ needed for structure constructors in DATA statements, where a pointer
+ is associated with a data target, and the argument has not been fully
+ resolved yet. Components references are dealt with further below. */
+ if (ts != NULL
+ && expr->ts.type == BT_PROCEDURE
+ && expr->ref == NULL
+ && attr.flavor != FL_PROCEDURE
+ && attr.target)
+*ts = sym->ts;
+
has_inquiry_part = false;
for (ref = expr->ref; ref; ref = ref->next)
if (ref->type == REF_INQUIRY)
diff --git a/gcc/testsuite/gfortran.dg/data_pointer_3.f90
b/gcc/testsuite/gfortran.dg/data_pointer_3.f90
new file mode 100644
index 000..49c288e93b9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/data_pointer_3.f90
@@ -0,0 +1,77 @@
+! { dg-do compile }
+! PR fortran/114474 - DATA and derived types with pointer components
+
+program pr114474
+ implicit none
+ integer, target :: ii = 42! initial data target
+
+ integer, target :: jj = 24
+ integer, pointer:: qq => jj
+ ! ii and jj resolve slightly differently when the data statement below
+ ! is reached, as jj is resolved outside the structure constructor first
+
+ type t
+ integer, pointer :: h
+ end type t
+
+ integer, target :: kk(7) = 23
+ integer, pointer:: ll(:) => kk
+
+ type t1
+ integer :: m(7)
+ end type t1
+
+ type(t) :: x1, x2, x3, x4, x5
+ type(t), parameter :: z1 = t(null())
+
+ type(t1), target:: tt = t1([1,2,3,4,5,6,7])
+ type(t1), parameter :: vv = t1(22)
+ type(t1):: w1, w2
+ integer, pointer :: p1(:) => tt% m
+
+ data x1 / t(null()) /
+ data x2 / t(ii) / ! ii is initial data target
+ data x3 / t(jj) / ! jj is resolved differently...
+ data x4 / t(tt%m(3)) / ! pointer association with 3rd element
+
+ data w1 / t1(12) /
+ data w2 / t1(vv%m) /
+
+ if ( associated (x1% h)) stop 1
+ if (.not. associated (x2% h)) stop 2
+ if (.not. associated (x3% h)) stop 3
+ if (.not. associated (x4% h)) stop 4
+ if (x2% h /= 42) stop 5
+ if (x3% h /= 24) stop 6
+ if (x4% h /= 3) stop 7
+
+ if (any (w1%m /= 12 )) stop 8
+ if (any (w2%m /= vv%m)) stop 9
+end
+
+
+subroutine sub
+ implicit none
+
+ interface
+ real function myfun (x)
+ real, intent(in) :: x
+ end function myfun
+ end interface
+
+ type u
+ procedure(myfun), pointer, nopass :: p
+ end type u
+
+ type(u):: u3 = u(null())
+ type(u), parameter :: u4 = u(null())
+ type(u):: u1, u2
+
+ data u1 / u(null()) /
+ data u2 / u(myfun) /
+end
+
+real function myfun (x)
+ real, intent(in) :: x
+ myfun = x
+end function myfun
[gcc r13-8592] Fortran: fix DATA and derived types with pointer components [PR114474]
https://gcc.gnu.org/g:0d4862691d2b58f7bd2d58de0e78bc574c313d39
commit r13-8592-g0d4862691d2b58f7bd2d58de0e78bc574c313d39
Author: Harald Anlauf
Date: Wed Mar 27 21:18:04 2024 +0100
Fortran: fix DATA and derived types with pointer components [PR114474]
When matching actual arguments in match_actual_arg, these are initially
treated as a possible dummy procedure, assuming that the correct type is
determined later. This resolution could fail when the procedure is a
derived type constructor with a pointer component and appears in a DATA
statement, where the pointer shall be associated with an initial data
target. Check for those cases where the type obviously has not been
resolved yet, and which were missed because there was no component
reference.
gcc/fortran/ChangeLog:
PR fortran/114474
* primary.cc (gfc_variable_attr): Catch variables used in structure
constructors within DATA statements that are still tagged with a
temporary type BT_PROCEDURE from match_actual_arg and which have the
target attribute, and fix their typespec.
gcc/testsuite/ChangeLog:
PR fortran/114474
* gfortran.dg/data_pointer_3.f90: New test.
(cherry picked from commit bbb7c513dddc5c9b2d5e9b78bc1c2f85a0cfe07e)
Diff:
---
gcc/fortran/primary.cc | 12 +
gcc/testsuite/gfortran.dg/data_pointer_3.f90 | 77
2 files changed, 89 insertions(+)
diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index c6a119c73cb..edbd162ed13 100644
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
@@ -2672,6 +2672,18 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
if (ts != NULL && expr->ts.type == BT_UNKNOWN)
*ts = sym->ts;
+ /* Catch left-overs from match_actual_arg, where an actual argument of a
+ procedure is given a temporary ts.type == BT_PROCEDURE. The fixup is
+ needed for structure constructors in DATA statements, where a pointer
+ is associated with a data target, and the argument has not been fully
+ resolved yet. Components references are dealt with further below. */
+ if (ts != NULL
+ && expr->ts.type == BT_PROCEDURE
+ && expr->ref == NULL
+ && attr.flavor != FL_PROCEDURE
+ && attr.target)
+*ts = sym->ts;
+
has_inquiry_part = false;
for (ref = expr->ref; ref; ref = ref->next)
if (ref->type == REF_INQUIRY)
diff --git a/gcc/testsuite/gfortran.dg/data_pointer_3.f90
b/gcc/testsuite/gfortran.dg/data_pointer_3.f90
new file mode 100644
index 000..49c288e93b9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/data_pointer_3.f90
@@ -0,0 +1,77 @@
+! { dg-do compile }
+! PR fortran/114474 - DATA and derived types with pointer components
+
+program pr114474
+ implicit none
+ integer, target :: ii = 42! initial data target
+
+ integer, target :: jj = 24
+ integer, pointer:: qq => jj
+ ! ii and jj resolve slightly differently when the data statement below
+ ! is reached, as jj is resolved outside the structure constructor first
+
+ type t
+ integer, pointer :: h
+ end type t
+
+ integer, target :: kk(7) = 23
+ integer, pointer:: ll(:) => kk
+
+ type t1
+ integer :: m(7)
+ end type t1
+
+ type(t) :: x1, x2, x3, x4, x5
+ type(t), parameter :: z1 = t(null())
+
+ type(t1), target:: tt = t1([1,2,3,4,5,6,7])
+ type(t1), parameter :: vv = t1(22)
+ type(t1):: w1, w2
+ integer, pointer :: p1(:) => tt% m
+
+ data x1 / t(null()) /
+ data x2 / t(ii) / ! ii is initial data target
+ data x3 / t(jj) / ! jj is resolved differently...
+ data x4 / t(tt%m(3)) / ! pointer association with 3rd element
+
+ data w1 / t1(12) /
+ data w2 / t1(vv%m) /
+
+ if ( associated (x1% h)) stop 1
+ if (.not. associated (x2% h)) stop 2
+ if (.not. associated (x3% h)) stop 3
+ if (.not. associated (x4% h)) stop 4
+ if (x2% h /= 42) stop 5
+ if (x3% h /= 24) stop 6
+ if (x4% h /= 3) stop 7
+
+ if (any (w1%m /= 12 )) stop 8
+ if (any (w2%m /= vv%m)) stop 9
+end
+
+
+subroutine sub
+ implicit none
+
+ interface
+ real function myfun (x)
+ real, intent(in) :: x
+ end function myfun
+ end interface
+
+ type u
+ procedure(myfun), pointer, nopass :: p
+ end type u
+
+ type(u):: u3 = u(null())
+ type(u), parameter :: u4 = u(null())
+ type(u):: u1, u2
+
+ data u1 / u(null()) /
+ data u2 / u(myfun) /
+end
+
+real function myfun (x)
+ real, intent(in) :: x
+ myfun = x
+end function myfun
[gcc r11-11310] fortran: Fix setting of array lower bound for named arrays
https://gcc.gnu.org/g:b755a7af1f2ef1f5348d04db20f751e898abcd9d
commit r11-11310-gb755a7af1f2ef1f5348d04db20f751e898abcd9d
Author: Chung-Lin Tang
Date: Fri Dec 3 17:27:17 2021 +0800
fortran: Fix setting of array lower bound for named arrays
This patch fixes a case of setting array low-bounds, found for particular
uses
of SOURCE=/MOLD=. This adjusts the relevant part in gfc_trans_allocate() to
set e3_has_nodescriptor only for non-named arrays.
2021-12-03 Tobias Burnus
gcc/fortran/ChangeLog:
* trans-stmt.c (gfc_trans_allocate): Set e3_has_nodescriptor to true
only for non-named arrays.
gcc/testsuite/ChangeLog:
* gfortran.dg/allocate_with_source_26.f90: Adjust testcase.
* gfortran.dg/allocate_with_mold_4.f90: New testcase.
(cherry picked from commit 6262e3a22b3d86afc116480bc59a7bb30b0cfd40)
Diff:
---
gcc/fortran/trans-stmt.c | 17 +++
gcc/testsuite/gfortran.dg/allocate_with_mold_4.f90 | 24 ++
.../gfortran.dg/allocate_with_source_26.f90| 8
3 files changed, 35 insertions(+), 14 deletions(-)
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 0e387bbb4e6..0f920c496a0 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -6661,16 +6661,13 @@ gfc_trans_allocate (gfc_code * code)
else
e3rhs = gfc_copy_expr (code->expr3);
- // We need to propagate the bounds of the expr3 for source=/mold=;
- // however, for nondescriptor arrays, we use internally a lower bound
- // of zero instead of one, which needs to be corrected for the allocate
obj
- if (e3_is == E3_DESC)
- {
- symbol_attribute attr = gfc_expr_attr (code->expr3);
- if (code->expr3->expr_type == EXPR_ARRAY ||
- (!attr.allocatable && !attr.pointer))
- e3_has_nodescriptor = true;
- }
+ // We need to propagate the bounds of the expr3 for source=/mold=.
+ // However, for non-named arrays, the lbound has to be 1 and neither the
+ // bound used inside the called function even when returning an
+ // allocatable/pointer nor the zero used internally.
+ if (e3_is == E3_DESC
+ && code->expr3->expr_type != EXPR_VARIABLE)
+ e3_has_nodescriptor = true;
}
/* Loop over all objects to allocate. */
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_mold_4.f90
b/gcc/testsuite/gfortran.dg/allocate_with_mold_4.f90
new file mode 100644
index 000..d545fe1249f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_with_mold_4.f90
@@ -0,0 +1,24 @@
+program A_M
+ implicit none
+ real, parameter :: C(5:10) = 5.0
+ real, dimension (:), allocatable :: A, B
+ allocate (A(6))
+ call Init (A)
+contains
+ subroutine Init ( A )
+real, dimension ( -1 : ), intent ( in ) :: A
+integer, dimension ( 1 ) :: lb_B
+
+allocate (B, mold = A)
+if (any (lbound (B) /= lbound (A))) stop 1
+if (any (ubound (B) /= ubound (A))) stop 2
+if (any (shape (B) /= shape (A))) stop 3
+if (size (B) /= size (A)) stop 4
+deallocate (B)
+allocate (B, mold = C)
+if (any (lbound (B) /= lbound (C))) stop 5
+if (any (ubound (B) /= ubound (C))) stop 6
+if (any (shape (B) /= shape (C))) stop 7
+if (size (B) /= size (C)) stop 8
+end
+end
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_26.f90
b/gcc/testsuite/gfortran.dg/allocate_with_source_26.f90
index 28f24fc1e10..323c8a30b9e 100644
--- a/gcc/testsuite/gfortran.dg/allocate_with_source_26.f90
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_26.f90
@@ -34,23 +34,23 @@ program p
if (lbound(p1, 1) /= 3 .or. ubound(p1, 1) /= 4 &
.or. lbound(p2, 1) /= 3 .or. ubound(p2, 1) /= 4 &
.or. lbound(p3, 1) /= 1 .or. ubound(p3, 1) /= 2 &
- .or. lbound(p4, 1) /= 7 .or. ubound(p4, 1) /= 8 &
+ .or. lbound(p4, 1) /= 1 .or. ubound(p4, 1) /= 2 &
.or. p1(3)%i /= 43 .or. p1(4)%i /= 56 &
.or. p2(3)%i /= 43 .or. p2(4)%i /= 56 &
.or. p3(1)%i /= 43 .or. p3(2)%i /= 56 &
- .or. p4(7)%i /= 11 .or. p4(8)%i /= 12) then
+ .or. p4(1)%i /= 11 .or. p4(2)%i /= 12) then
call abort()
endif
!write(*,*) lbound(a,1), ubound(a,1) ! prints 1 3
!write(*,*) lbound(b,1), ubound(b,1) ! prints 1 3
- !write(*,*) lbound(c,1), ubound(c,1) ! prints 3 5
+ !write(*,*) lbound(c,1), ubound(c,1) ! prints 1 3
!write(*,*) lbound(d,1), ubound(d,1) ! prints 1 5
!write(*,*) lbound(e,1), ubound(e,1) ! prints 1 6
if (lbound(a,1) /= 1 .or. ubound(a,1) /= 3 &
.or. lbound(b,1) /= 1 .or. ubound(b,1) /= 3 &
- .or. lbound(c,1) /= 3 .or. ubound(c,1) /= 5 &
+ .or. lbound(c,1) /= 1 .or. ubound(c,1) /= 3 &
.or. lbound(d,1) /= 1 .or. ubound(d,1) /= 5 &
.or. lbound(e,1) /= 1 .or. ubound(e,1) /= 6) then
call abort()
[gcc r13-8559] Fortran: error recovery while simplifying expressions [PR103707, PR106987]
https://gcc.gnu.org/g:2808797fc4da7cc455803e2b69368b52db857b4c
commit r13-8559-g2808797fc4da7cc455803e2b69368b52db857b4c
Author: Harald Anlauf
Date: Tue Mar 5 21:54:26 2024 +0100
Fortran: error recovery while simplifying expressions [PR103707,PR106987]
When an exception is encountered during simplification of arithmetic
expressions, the result may depend on whether range-checking is active
(-frange-check) or not. However, the code path in the front-end should
stay the same for "soft" errors for which the exception is triggered by the
check, while "hard" errors should always terminate the simplification, so
that error recovery is independent of the flag. Separation of arithmetic
error codes into "hard" and "soft" errors shall be done consistently via
is_hard_arith_error().
PR fortran/103707
PR fortran/106987
gcc/fortran/ChangeLog:
* arith.cc (is_hard_arith_error): New helper function to determine
whether an arithmetic error is "hard" or not.
(check_result): Use it.
(gfc_arith_divide): Set "Division by zero" only for regular
numerators of real and complex divisions.
(reduce_unary): Use is_hard_arith_error to determine whether a hard
or (recoverable) soft error was encountered. Terminate immediately
on hard error, otherwise remember code of first soft error.
(reduce_binary_ac): Likewise.
(reduce_binary_ca): Likewise.
(reduce_binary_aa): Likewise.
gcc/testsuite/ChangeLog:
* gfortran.dg/arithmetic_overflow_3.f90: New test.
(cherry picked from commit 93e1d4d24ed014387da97e2ce11556d68fe98e66)
Diff:
---
gcc/fortran/arith.cc | 134 +++--
.../gfortran.dg/arithmetic_overflow_3.f90 | 48
2 files changed, 142 insertions(+), 40 deletions(-)
diff --git a/gcc/fortran/arith.cc b/gcc/fortran/arith.cc
index 5673c76823a..fade085450c 100644
--- a/gcc/fortran/arith.cc
+++ b/gcc/fortran/arith.cc
@@ -130,6 +130,30 @@ gfc_arith_error (arith code)
}
+/* Check if a certain arithmetic error code is severe enough to prevent
+ further simplification, as opposed to errors thrown by the range check
+ (e.g. overflow) or arithmetic exceptions that are tolerated with
+ -fno-range-check. */
+
+static bool
+is_hard_arith_error (arith code)
+{
+ switch (code)
+{
+case ARITH_OK:
+case ARITH_OVERFLOW:
+case ARITH_UNDERFLOW:
+case ARITH_NAN:
+case ARITH_DIV0:
+case ARITH_ASYMMETRIC:
+ return false;
+
+default:
+ return true;
+}
+}
+
+
/* Get things ready to do math. */
void
@@ -579,10 +603,10 @@ check_result (arith rc, gfc_expr *x, gfc_expr *r,
gfc_expr **rp)
val = ARITH_OK;
}
- if (val == ARITH_OK || val == ARITH_OVERFLOW)
-*rp = r;
- else
+ if (is_hard_arith_error (val))
gfc_free_expr (r);
+ else
+*rp = r;
return val;
}
@@ -792,23 +816,26 @@ gfc_arith_divide (gfc_expr *op1, gfc_expr *op2, gfc_expr
**resultp)
break;
case BT_REAL:
- if (mpfr_sgn (op2->value.real) == 0 && flag_range_check == 1)
- {
- rc = ARITH_DIV0;
- break;
- }
+ /* Set "Division by zero" only for regular numerator. */
+ if (flag_range_check == 1
+ && mpfr_zero_p (op2->value.real)
+ && mpfr_regular_p (op1->value.real))
+ rc = ARITH_DIV0;
mpfr_div (result->value.real, op1->value.real, op2->value.real,
GFC_RND_MODE);
break;
case BT_COMPLEX:
- if (mpc_cmp_si_si (op2->value.complex, 0, 0) == 0
- && flag_range_check == 1)
- {
- rc = ARITH_DIV0;
- break;
- }
+ /* Set "Division by zero" only for regular numerator. */
+ if (flag_range_check == 1
+ && mpfr_zero_p (mpc_realref (op2->value.complex))
+ && mpfr_zero_p (mpc_imagref (op2->value.complex))
+ && ((mpfr_regular_p (mpc_realref (op1->value.complex))
+ && mpfr_number_p (mpc_imagref (op1->value.complex)))
+ || (mpfr_regular_p (mpc_imagref (op1->value.complex))
+ && mpfr_number_p (mpc_realref (op1->value.complex)
+ rc = ARITH_DIV0;
gfc_set_model (mpc_realref (op1->value.complex));
if (mpc_cmp_si_si (op2->value.complex, 0, 0) == 0)
@@ -1323,7 +1350,6 @@ reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **),
gfc_expr *op,
gfc_constructor *c;
gfc_expr *r;
arith rc;
- bool ov = false;
if (op->expr_type == EXPR_CONSTANT)
return eval (op, result);
@@ -1335,19 +1361,22 @@ reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **),
gfc_expr *op,
head = gfc_constructor_copy (op->value.constructor);
for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
{
- rc = reduce_unary (eval, c->expr, );
+ arith rc_tmp =
[gcc r13-8558] Fortran: error recovery on arithmetic overflow on unary operations [PR113799]
https://gcc.gnu.org/g:ec8303dea72ed4f9ae9fdf3c996a0deef6809351
commit r13-8558-gec8303dea72ed4f9ae9fdf3c996a0deef6809351
Author: Harald Anlauf
Date: Thu Feb 8 21:51:38 2024 +0100
Fortran: error recovery on arithmetic overflow on unary operations
[PR113799]
PR fortran/113799
gcc/fortran/ChangeLog:
* arith.cc (reduce_unary): Remember any overflow encountered during
reduction of unary arithmetic operations on array constructors and
continue, and return error status, but terminate on serious errors.
gcc/testsuite/ChangeLog:
* gfortran.dg/arithmetic_overflow_2.f90: New test.
(cherry picked from commit b3d622d70ba209b63471fc1b0970870046e55745)
Diff:
---
gcc/fortran/arith.cc| 11 ---
gcc/testsuite/gfortran.dg/arithmetic_overflow_2.f90 | 12
2 files changed, 20 insertions(+), 3 deletions(-)
diff --git a/gcc/fortran/arith.cc b/gcc/fortran/arith.cc
index fcf37d48bfc..5673c76823a 100644
--- a/gcc/fortran/arith.cc
+++ b/gcc/fortran/arith.cc
@@ -1323,6 +1323,7 @@ reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **),
gfc_expr *op,
gfc_constructor *c;
gfc_expr *r;
arith rc;
+ bool ov = false;
if (op->expr_type == EXPR_CONSTANT)
return eval (op, result);
@@ -1336,13 +1337,17 @@ reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **),
gfc_expr *op,
{
rc = reduce_unary (eval, c->expr, );
- if (rc != ARITH_OK)
+ /* Remember any overflow encountered during reduction and continue,
+but terminate on serious errors. */
+ if (rc == ARITH_OVERFLOW)
+ ov = true;
+ else if (rc != ARITH_OK)
break;
gfc_replace_expr (c->expr, r);
}
- if (rc != ARITH_OK)
+ if (rc != ARITH_OK && rc != ARITH_OVERFLOW)
gfc_constructor_free (head);
else
{
@@ -1363,7 +1368,7 @@ reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **),
gfc_expr *op,
*result = r;
}
- return rc;
+ return ov ? ARITH_OVERFLOW : rc;
}
diff --git a/gcc/testsuite/gfortran.dg/arithmetic_overflow_2.f90
b/gcc/testsuite/gfortran.dg/arithmetic_overflow_2.f90
new file mode 100644
index 000..6ca27f74215
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/arithmetic_overflow_2.f90
@@ -0,0 +1,12 @@
+! { dg-do compile }
+! { dg-additional-options "-frange-check" }
+!
+! PR fortran/113799 - handle arithmetic overflow on unary minus
+
+program p
+ implicit none
+ real, parameter :: inf = real(z'7F80')
+ real, parameter :: someInf(*) = [inf, 0.]
+ print *, -someInf ! { dg-error "Arithmetic overflow" }
+ print *, minval(-someInf) ! { dg-error "Arithmetic overflow" }
+end
[gcc r13-8557] Fortran: set shape of initializers of zero-sized arrays [PR95374, PR104352]
https://gcc.gnu.org/g:0dd82c0fba660775ff76ae27077a67f2f1358920
commit r13-8557-g0dd82c0fba660775ff76ae27077a67f2f1358920
Author: Harald Anlauf
Date: Wed May 17 20:39:18 2023 +0200
Fortran: set shape of initializers of zero-sized arrays [PR95374,PR104352]
gcc/fortran/ChangeLog:
PR fortran/95374
PR fortran/104352
* decl.cc (add_init_expr_to_sym): Set shape of initializer also for
zero-sized arrays, so that bounds violations can be detected later.
gcc/testsuite/ChangeLog:
PR fortran/95374
PR fortran/104352
* gfortran.dg/zero_sized_13.f90: New test.
(cherry picked from commit 7bafe652dba9167b65e7b5ef24e77eceb49709ba)
Diff:
---
gcc/fortran/decl.cc | 3 +--
gcc/testsuite/gfortran.dg/zero_sized_13.f90 | 28
2 files changed, 29 insertions(+), 2 deletions(-)
diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index 03e993eb0ff..527e84ad763 100644
--- a/gcc/fortran/decl.cc
+++ b/gcc/fortran/decl.cc
@@ -2248,8 +2248,7 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp,
locus *var_locus)
&& gfc_is_constant_expr (init)
&& (init->expr_type == EXPR_CONSTANT
|| init->expr_type == EXPR_STRUCTURE)
- && spec_size (sym->as, )
- && mpz_cmp_si (size, 0) > 0)
+ && spec_size (sym->as, ))
{
array = gfc_get_array_expr (init->ts.type, init->ts.kind,
>where);
diff --git a/gcc/testsuite/gfortran.dg/zero_sized_13.f90
b/gcc/testsuite/gfortran.dg/zero_sized_13.f90
new file mode 100644
index 000..4035d458b32
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/zero_sized_13.f90
@@ -0,0 +1,28 @@
+! { dg-do compile }
+! { dg-options "-w" }
+!
+! PR fortran/95374
+! PR fortran/104352 - Various ICEs for bounds violation with zero-sized arrays
+!
+! Contributed by G. Steinmetz
+
+program p
+ implicit none
+ integer :: i
+ integer, parameter :: a(0)= 0
+ integer, parameter :: b(0:-5) = 0
+ integer, parameter :: c(*) = [(a(i:i), i=0,0)] ! { dg-error "out of bounds" }
+ integer, parameter :: d(*) = [(b(i:i), i=1,1)] ! { dg-error "out of bounds" }
+ integer, parameter :: e(1) = [(a(i) , i=1,1)] ! { dg-error "out of bounds" }
+ integer, parameter :: f(1) = [(a(i:i), i=1,1)] ! { dg-error "out of bounds" }
+ integer:: g(1) = [(a(i:i), i=0,0)] ! { dg-error "out of bounds" }
+ integer:: h(1) = [(a(i:i), i=1,1)] ! { dg-error "out of bounds" }
+ print *, [(a(i:i), i=0,0)] ! { dg-error "out of bounds" }
+ print *, [(a(i:i), i=1,1)] ! { dg-error "out of bounds" }
+ print *, any (a(1:1) == 1) ! { dg-error "out of bounds" }
+ print *, all (a(0:0) == 1) ! { dg-error "out of bounds" }
+ print *, sum (a(1:1)) ! { dg-error "out of bounds" }
+ print *, iall (a(0:0)) ! { dg-error "out of bounds" }
+ print *, minloc (a(0:0),1) ! { dg-error "out of bounds" }
+ print *, dot_product(a(1:1),a(1:1)) ! { dg-error "out of bounds" }
+end
[gcc r11-11299] Fortran: fix NULL pointer dereference on overlapping initialization [PR50410]
https://gcc.gnu.org/g:1611acc1f72cad30c7ecccb5c85246836c1d0299
commit r11-11299-g1611acc1f72cad30c7ecccb5c85246836c1d0299
Author: Harald Anlauf
Date: Thu Mar 28 22:34:40 2024 +0100
Fortran: fix NULL pointer dereference on overlapping initialization
[PR50410]
gcc/fortran/ChangeLog:
PR fortran/50410
* trans-expr.c (gfc_conv_structure): Check for NULL pointer.
gcc/testsuite/ChangeLog:
PR fortran/50410
* gfortran.dg/data_initialized_4.f90: New test.
(cherry picked from commit 6fb253a25dff13253d63553f02e0fe72c5e3ab4e)
Diff:
---
gcc/fortran/trans-expr.c | 2 +-
gcc/testsuite/gfortran.dg/data_initialized_4.f90 | 16
2 files changed, 17 insertions(+), 1 deletion(-)
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 5adee114157..37f16f37e12 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -8879,7 +8879,7 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int
init)
cm = expr->ts.u.derived->components;
for (c = gfc_constructor_first (expr->value.constructor);
- c; c = gfc_constructor_next (c), cm = cm->next)
+ c && cm; c = gfc_constructor_next (c), cm = cm->next)
{
/* Skip absent members in default initializers and allocatable
components. Although the latter have a default initializer
diff --git a/gcc/testsuite/gfortran.dg/data_initialized_4.f90
b/gcc/testsuite/gfortran.dg/data_initialized_4.f90
new file mode 100644
index 000..156b6607edf
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/data_initialized_4.f90
@@ -0,0 +1,16 @@
+! { dg-do compile }
+! { dg-additional-options "-std=legacy" }
+!
+! PR fortran/50410
+!
+! Silently allow overlapping initialization in legacy mode (used to ICE)
+
+program p
+ implicit none
+ type t
+ integer :: g = 1
+ end type t
+ type(t) :: u = t(2)
+ data u%g /3/
+ print *, u! this might print "2"
+end
[gcc r12-10299] Fortran: fix NULL pointer dereference on overlapping initialization [PR50410]
https://gcc.gnu.org/g:cb72fbd49e1f0c1cbdf8a9e97860063b19b1f95e
commit r12-10299-gcb72fbd49e1f0c1cbdf8a9e97860063b19b1f95e
Author: Harald Anlauf
Date: Thu Mar 28 22:34:40 2024 +0100
Fortran: fix NULL pointer dereference on overlapping initialization
[PR50410]
gcc/fortran/ChangeLog:
PR fortran/50410
* trans-expr.cc (gfc_conv_structure): Check for NULL pointer.
gcc/testsuite/ChangeLog:
PR fortran/50410
* gfortran.dg/data_initialized_4.f90: New test.
(cherry picked from commit 6fb253a25dff13253d63553f02e0fe72c5e3ab4e)
Diff:
---
gcc/fortran/trans-expr.cc| 2 +-
gcc/testsuite/gfortran.dg/data_initialized_4.f90 | 16
2 files changed, 17 insertions(+), 1 deletion(-)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 27b34984705..11ee1931b8e 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -9298,7 +9298,7 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int
init)
cm = expr->ts.u.derived->components;
for (c = gfc_constructor_first (expr->value.constructor);
- c; c = gfc_constructor_next (c), cm = cm->next)
+ c && cm; c = gfc_constructor_next (c), cm = cm->next)
{
/* Skip absent members in default initializers and allocatable
components. Although the latter have a default initializer
diff --git a/gcc/testsuite/gfortran.dg/data_initialized_4.f90
b/gcc/testsuite/gfortran.dg/data_initialized_4.f90
new file mode 100644
index 000..156b6607edf
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/data_initialized_4.f90
@@ -0,0 +1,16 @@
+! { dg-do compile }
+! { dg-additional-options "-std=legacy" }
+!
+! PR fortran/50410
+!
+! Silently allow overlapping initialization in legacy mode (used to ICE)
+
+program p
+ implicit none
+ type t
+ integer :: g = 1
+ end type t
+ type(t) :: u = t(2)
+ data u%g /3/
+ print *, u! this might print "2"
+end
[gcc r13-8506] Fortran: fix passing of optional dummies to bind(c) procedures [PR113866]
https://gcc.gnu.org/g:5f9144021615f24d038890dab7db2a0b9e84f6d3
commit r13-8506-g5f9144021615f24d038890dab7db2a0b9e84f6d3
Author: Harald Anlauf
Date: Tue Feb 13 20:19:10 2024 +0100
Fortran: fix passing of optional dummies to bind(c) procedures [PR113866]
PR fortran/113866
gcc/fortran/ChangeLog:
* trans-expr.cc (gfc_conv_procedure_call): When passing an optional
dummy argument to an optional dummy argument of a bind(c) procedure
and the dummy argument is passed via a CFI descriptor, no special
presence check and passing of a default NULL pointer is needed.
gcc/testsuite/ChangeLog:
* gfortran.dg/bind_c_optional-2.f90: New test.
(cherry picked from commit f4935df217ad89f884f908f39086b322e80123d0)
Diff:
---
gcc/fortran/trans-expr.cc | 6 +-
gcc/testsuite/gfortran.dg/bind_c_optional-2.f90 | 105
2 files changed, 109 insertions(+), 2 deletions(-)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index d9de93260a6..c3f02c83b3f 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -7052,8 +7052,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
with an interface indicating an optional argument. When we call
an intrinsic subroutine, however, fsym is NULL, but we might still
have an optional argument, so we proceed to the substitution
-just in case. */
- if (e && (fsym == NULL || fsym->attr.optional))
+just in case. Arguments passed to bind(c) procedures via CFI
+descriptors are handled elsewhere. */
+ if (e && (fsym == NULL || fsym->attr.optional)
+ && !(sym->attr.is_bind_c && is_CFI_desc (fsym, NULL)))
{
/* If an optional argument is itself an optional dummy argument,
check its presence and substitute a null if absent. This is
diff --git a/gcc/testsuite/gfortran.dg/bind_c_optional-2.f90
b/gcc/testsuite/gfortran.dg/bind_c_optional-2.f90
new file mode 100644
index 000..ceedef7f006
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/bind_c_optional-2.f90
@@ -0,0 +1,105 @@
+! { dg-do run }
+! PR fortran/113866
+!
+! Check interoperability of assumed-length character (optional and
+! non-optional) dummies between bind(c) and non-bind(c) procedures
+
+module bindcchar
+ implicit none
+ integer, parameter :: n = 100, l = 10
+contains
+ subroutine bindc_optional (c2, c4) bind(c)
+character(*), optional :: c2, c4(n)
+! print *, c2(1:3)
+! print *, c4(5)(1:3)
+if (.not. present (c2) .or. .not. present (c4)) stop 8
+if (len (c2) /= l .or. len (c4) /= l) stop 81
+if (c2(1:3)/= "a23") stop 1
+if (c4(5)(1:3) /= "bcd") stop 2
+ end
+
+ subroutine bindc (c2, c4) bind(c)
+character(*) :: c2, c4(n)
+if (len (c2) /= l .or. len (c4) /= l) stop 82
+if (c2(1:3)/= "a23") stop 3
+if (c4(5)(1:3) /= "bcd") stop 4
+call bindc_optional (c2, c4)
+ end
+
+ subroutine not_bindc_optional (c1, c3)
+character(*), optional :: c1, c3(n)
+if (.not. present (c1) .or. .not. present (c3)) stop 5
+if (len (c1) /= l .or. len (c3) /= l) stop 83
+call bindc_optional (c1, c3)
+call bindc (c1, c3)
+ end
+
+ subroutine not_bindc_optional_deferred (c5, c6)
+character(:), allocatable, optional :: c5, c6(:)
+if (.not. present (c5) .or. .not. present (c6)) stop 6
+if (len (c5) /= l .or. len (c6) /= l) stop 84
+call not_bindc_optional (c5, c6)
+call bindc_optional (c5, c6)
+call bindc (c5, c6)
+ end
+
+ subroutine not_bindc_optional2 (c7, c8)
+character(*), optional :: c7, c8(:)
+if (.not. present (c7) .or. .not. present (c8)) stop 7
+if (len (c7) /= l .or. len (c8) /= l) stop 85
+call bindc_optional (c7, c8)
+call bindc (c7, c8)
+ end
+
+ subroutine bindc_optional2 (c2, c4) bind(c)
+character(*), optional :: c2, c4(n)
+if (.not. present (c2) .or. .not. present (c4)) stop 8
+if (len (c2) /= l .or. len (c4) /= l) stop 86
+if (c2(1:3)/= "a23") stop 9
+if (c4(5)(1:3) /= "bcd") stop 10
+call bindc_optional (c2, c4)
+call not_bindc_optional (c2, c4)
+ end
+
+ subroutine bindc_optional_missing (c1, c2, c3, c4, c5) bind(c)
+character(*), optional :: c1, c2(n), c3(:), c4(..), c5(*)
+if (present (c1)) stop 11
+if (present (c2)) stop 12
+if (present (c3)) stop 13
+if (present (c4)) stop 14
+if (present (c5)) stop 15
+ end
+
+ subroutine non_bindc_optional_missing (c1, c2, c3, c4, c5)
+character(*), optional :: c1, c2(n), c3(:), c4(..), c5(*)
+if (present (c1)) stop 21
+if (present (c2)) stop 22
+if (present (c3)) stop 23
+if (present (c4)) stop 24
+if (present (c5)) stop 25
+ end
+end module
+
+program p
+ use bindcchar
+ implicit none
+ character(l) :: a, b(n)
+ character(:), allocatable :: d,
[gcc r13-8505] Fortran: fix NULL pointer dereference on overlapping initialization [PR50410]
https://gcc.gnu.org/g:250990298fb792635d9895e7642ccedbc2dd39d4
commit r13-8505-g250990298fb792635d9895e7642ccedbc2dd39d4
Author: Harald Anlauf
Date: Thu Mar 28 22:34:40 2024 +0100
Fortran: fix NULL pointer dereference on overlapping initialization
[PR50410]
gcc/fortran/ChangeLog:
PR fortran/50410
* trans-expr.cc (gfc_conv_structure): Check for NULL pointer.
gcc/testsuite/ChangeLog:
PR fortran/50410
* gfortran.dg/data_initialized_4.f90: New test.
(cherry picked from commit 6fb253a25dff13253d63553f02e0fe72c5e3ab4e)
Diff:
---
gcc/fortran/trans-expr.cc| 2 +-
gcc/testsuite/gfortran.dg/data_initialized_4.f90 | 16
2 files changed, 17 insertions(+), 1 deletion(-)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 3f3f0123dc3..d9de93260a6 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -9364,7 +9364,7 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int
init)
cm = expr->ts.u.derived->components;
for (c = gfc_constructor_first (expr->value.constructor);
- c; c = gfc_constructor_next (c), cm = cm->next)
+ c && cm; c = gfc_constructor_next (c), cm = cm->next)
{
/* Skip absent members in default initializers and allocatable
components. Although the latter have a default initializer
diff --git a/gcc/testsuite/gfortran.dg/data_initialized_4.f90
b/gcc/testsuite/gfortran.dg/data_initialized_4.f90
new file mode 100644
index 000..156b6607edf
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/data_initialized_4.f90
@@ -0,0 +1,16 @@
+! { dg-do compile }
+! { dg-additional-options "-std=legacy" }
+!
+! PR fortran/50410
+!
+! Silently allow overlapping initialization in legacy mode (used to ICE)
+
+program p
+ implicit none
+ type t
+ integer :: g = 1
+ end type t
+ type(t) :: u = t(2)
+ data u%g /3/
+ print *, u! this might print "2"
+end
[gcc r14-9720] Fortran: fix NULL pointer dereference on overlapping initialization [PR50410]
https://gcc.gnu.org/g:6fb253a25dff13253d63553f02e0fe72c5e3ab4e
commit r14-9720-g6fb253a25dff13253d63553f02e0fe72c5e3ab4e
Author: Harald Anlauf
Date: Thu Mar 28 22:34:40 2024 +0100
Fortran: fix NULL pointer dereference on overlapping initialization
[PR50410]
gcc/fortran/ChangeLog:
PR fortran/50410
* trans-expr.cc (gfc_conv_structure): Check for NULL pointer.
gcc/testsuite/ChangeLog:
PR fortran/50410
* gfortran.dg/data_initialized_4.f90: New test.
Diff:
---
gcc/fortran/trans-expr.cc| 2 +-
gcc/testsuite/gfortran.dg/data_initialized_4.f90 | 16
2 files changed, 17 insertions(+), 1 deletion(-)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 079ac93aa8a..d21e3956d6e 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -9650,7 +9650,7 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int
init)
cm = expr->ts.u.derived->components;
for (c = gfc_constructor_first (expr->value.constructor);
- c; c = gfc_constructor_next (c), cm = cm->next)
+ c && cm; c = gfc_constructor_next (c), cm = cm->next)
{
/* Skip absent members in default initializers and allocatable
components. Although the latter have a default initializer
diff --git a/gcc/testsuite/gfortran.dg/data_initialized_4.f90
b/gcc/testsuite/gfortran.dg/data_initialized_4.f90
new file mode 100644
index 000..156b6607edf
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/data_initialized_4.f90
@@ -0,0 +1,16 @@
+! { dg-do compile }
+! { dg-additional-options "-std=legacy" }
+!
+! PR fortran/50410
+!
+! Silently allow overlapping initialization in legacy mode (used to ICE)
+
+program p
+ implicit none
+ type t
+ integer :: g = 1
+ end type t
+ type(t) :: u = t(2)
+ data u%g /3/
+ print *, u! this might print "2"
+end
[gcc r14-9712] Fortran: fix DATA and derived types with pointer components [PR114474]
https://gcc.gnu.org/g:bbb7c513dddc5c9b2d5e9b78bc1c2f85a0cfe07e
commit r14-9712-gbbb7c513dddc5c9b2d5e9b78bc1c2f85a0cfe07e
Author: Harald Anlauf
Date: Wed Mar 27 21:18:04 2024 +0100
Fortran: fix DATA and derived types with pointer components [PR114474]
When matching actual arguments in match_actual_arg, these are initially
treated as a possible dummy procedure, assuming that the correct type is
determined later. This resolution could fail when the procedure is a
derived type constructor with a pointer component and appears in a DATA
statement, where the pointer shall be associated with an initial data
target. Check for those cases where the type obviously has not been
resolved yet, and which were missed because there was no component
reference.
gcc/fortran/ChangeLog:
PR fortran/114474
* primary.cc (gfc_variable_attr): Catch variables used in structure
constructors within DATA statements that are still tagged with a
temporary type BT_PROCEDURE from match_actual_arg and which have the
target attribute, and fix their typespec.
gcc/testsuite/ChangeLog:
PR fortran/114474
* gfortran.dg/data_pointer_3.f90: New test.
Diff:
---
gcc/fortran/primary.cc | 12 +
gcc/testsuite/gfortran.dg/data_pointer_3.f90 | 77
2 files changed, 89 insertions(+)
diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index 0ab69bb9dce..5dd6875a4a6 100644
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
@@ -2804,6 +2804,18 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
if (ts != NULL && expr->ts.type == BT_UNKNOWN)
*ts = sym->ts;
+ /* Catch left-overs from match_actual_arg, where an actual argument of a
+ procedure is given a temporary ts.type == BT_PROCEDURE. The fixup is
+ needed for structure constructors in DATA statements, where a pointer
+ is associated with a data target, and the argument has not been fully
+ resolved yet. Components references are dealt with further below. */
+ if (ts != NULL
+ && expr->ts.type == BT_PROCEDURE
+ && expr->ref == NULL
+ && attr.flavor != FL_PROCEDURE
+ && attr.target)
+*ts = sym->ts;
+
has_inquiry_part = false;
for (ref = expr->ref; ref; ref = ref->next)
if (ref->type == REF_INQUIRY)
diff --git a/gcc/testsuite/gfortran.dg/data_pointer_3.f90
b/gcc/testsuite/gfortran.dg/data_pointer_3.f90
new file mode 100644
index 000..49c288e93b9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/data_pointer_3.f90
@@ -0,0 +1,77 @@
+! { dg-do compile }
+! PR fortran/114474 - DATA and derived types with pointer components
+
+program pr114474
+ implicit none
+ integer, target :: ii = 42! initial data target
+
+ integer, target :: jj = 24
+ integer, pointer:: qq => jj
+ ! ii and jj resolve slightly differently when the data statement below
+ ! is reached, as jj is resolved outside the structure constructor first
+
+ type t
+ integer, pointer :: h
+ end type t
+
+ integer, target :: kk(7) = 23
+ integer, pointer:: ll(:) => kk
+
+ type t1
+ integer :: m(7)
+ end type t1
+
+ type(t) :: x1, x2, x3, x4, x5
+ type(t), parameter :: z1 = t(null())
+
+ type(t1), target:: tt = t1([1,2,3,4,5,6,7])
+ type(t1), parameter :: vv = t1(22)
+ type(t1):: w1, w2
+ integer, pointer :: p1(:) => tt% m
+
+ data x1 / t(null()) /
+ data x2 / t(ii) / ! ii is initial data target
+ data x3 / t(jj) / ! jj is resolved differently...
+ data x4 / t(tt%m(3)) / ! pointer association with 3rd element
+
+ data w1 / t1(12) /
+ data w2 / t1(vv%m) /
+
+ if ( associated (x1% h)) stop 1
+ if (.not. associated (x2% h)) stop 2
+ if (.not. associated (x3% h)) stop 3
+ if (.not. associated (x4% h)) stop 4
+ if (x2% h /= 42) stop 5
+ if (x3% h /= 24) stop 6
+ if (x4% h /= 3) stop 7
+
+ if (any (w1%m /= 12 )) stop 8
+ if (any (w2%m /= vv%m)) stop 9
+end
+
+
+subroutine sub
+ implicit none
+
+ interface
+ real function myfun (x)
+ real, intent(in) :: x
+ end function myfun
+ end interface
+
+ type u
+ procedure(myfun), pointer, nopass :: p
+ end type u
+
+ type(u):: u3 = u(null())
+ type(u), parameter :: u4 = u(null())
+ type(u):: u1, u2
+
+ data u1 / u(null()) /
+ data u2 / u(myfun) /
+end
+
+real function myfun (x)
+ real, intent(in) :: x
+ myfun = x
+end function myfun
[gcc r13-8492] Fortran: fix for absent array argument passed to optional dummy [PR101135]
https://gcc.gnu.org/g:344b60addb79278c95b7a5712aaf38721a27
commit r13-8492-g344b60addb79278c95b7a5712aaf38721a27
Author: Harald Anlauf
Date: Fri Mar 15 20:14:07 2024 +0100
Fortran: fix for absent array argument passed to optional dummy [PR101135]
gcc/fortran/ChangeLog:
PR fortran/101135
* trans-array.cc (gfc_get_dataptr_offset): Check for optional
arguments being present before dereferencing data pointer.
gcc/testsuite/ChangeLog:
PR fortran/101135
* gfortran.dg/missing_optional_dummy_6a.f90: Adjust diagnostic
pattern.
* gfortran.dg/ubsan/missing_optional_dummy_8.f90: New test.
Diff:
---
gcc/fortran/trans-array.cc | 11 +++
.../gfortran.dg/missing_optional_dummy_6a.f90 | 2 +-
.../gfortran.dg/ubsan/missing_optional_dummy_8.f90 | 108 +
3 files changed, 120 insertions(+), 1 deletion(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 074ea2f2384..5eef4b4ec87 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -7326,6 +7326,17 @@ gfc_get_dataptr_offset (stmtblock_t *block, tree parm,
tree desc, tree offset,
/* Set the target data pointer. */
offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
+
+ /* Check for optional dummy argument being present. Arguments of BIND(C)
+ procedures are excepted here since they are handled differently. */
+ if (expr->expr_type == EXPR_VARIABLE
+ && expr->symtree->n.sym->attr.dummy
+ && expr->symtree->n.sym->attr.optional
+ && !is_CFI_desc (NULL, expr))
+offset = build3_loc (input_location, COND_EXPR, TREE_TYPE (offset),
+gfc_conv_expr_present (expr->symtree->n.sym), offset,
+fold_convert (TREE_TYPE (offset),
gfc_index_zero_node));
+
gfc_conv_descriptor_data_set (block, parm, offset);
}
diff --git a/gcc/testsuite/gfortran.dg/missing_optional_dummy_6a.f90
b/gcc/testsuite/gfortran.dg/missing_optional_dummy_6a.f90
index c6a79059a91..b5e1726d74d 100644
--- a/gcc/testsuite/gfortran.dg/missing_optional_dummy_6a.f90
+++ b/gcc/testsuite/gfortran.dg/missing_optional_dummy_6a.f90
@@ -49,7 +49,7 @@ end program test
! { dg-final { scan-tree-dump-times "scalar2 \\(.* slr1" 1 "original" } }
-! { dg-final { scan-tree-dump-times "= es1 != 0B" 1 "original" } }
+! { dg-final { scan-tree-dump-times "= es1 != 0B" 2 "original" } }
! { dg-final { scan-tree-dump-times "assumed_shape2 \\(es1" 0 "original" } }
! { dg-final { scan-tree-dump-times "explicit_shape2 \\(es1" 1 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/ubsan/missing_optional_dummy_8.f90
b/gcc/testsuite/gfortran.dg/ubsan/missing_optional_dummy_8.f90
new file mode 100644
index 000..fd3914934aa
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/ubsan/missing_optional_dummy_8.f90
@@ -0,0 +1,108 @@
+! { dg-do run }
+! { dg-additional-options "-fdump-tree-original -fsanitize=undefined" }
+!
+! PR fortran/101135 - Load of null pointer when passing absent
+! assumed-shape array argument for an optional dummy argument
+!
+! Based on testcase by Marcel Jacobse
+
+program main
+ implicit none
+ character(len=3) :: a(6) = ['abc', 'def', 'ghi', 'jlm', 'nop', 'qrs']
+ call as ()
+ call as (a(::2))
+ call as_c ()
+ call as_c (a(2::2))
+ call test_wrapper
+ call test_wrapper_c
+ call test_ar_wrapper
+ call test_ar_wrapper_c
+contains
+ subroutine as (xx)
+character(len=*), optional, intent(in) :: xx(*)
+if (.not. present (xx)) return
+print *, xx(1:3)
+ end subroutine as
+
+ subroutine as_c (zz) bind(c)
+character(len=*), optional, intent(in) :: zz(*)
+if (.not. present (zz)) return
+print *, zz(1:3)
+ end subroutine as_c
+
+ subroutine test_wrapper (x)
+real, dimension(1), intent(out), optional :: x
+call test (x)
+call test1 (x)
+call test_c (x)
+call test1_c (x)
+ end subroutine test_wrapper
+
+ subroutine test_wrapper_c (w) bind(c)
+real, dimension(1), intent(out), optional :: w
+call test (w)
+call test1 (w)
+call test_c (w)
+call test1_c (w)
+ end subroutine test_wrapper_c
+
+ subroutine test (y)
+real, dimension(:), intent(out), optional :: y
+if (present (y)) y=0.
+ end subroutine test
+
+ subroutine test_c (y) bind(c)
+real, dimension(:), intent(out), optional :: y
+if (present (y)) y=0.
+ end subroutine test_c
+
+ subroutine test1 (y)
+real, dimension(1), intent(out), optional :: y
+if (present (y)) y=0.
+ end subroutine test1
+
+ subroutine test1_c (y) bind(c)
+real, dimension(1), intent(out), optional :: y
+if (present (y)) y=0.
+ end subroutine test1_c
+
+ subroutine test_ar_wrapper (p, q, r)
+real, intent(out), optional :: p
+real, dimension(1), intent(out), optional :: q
+real, dimension(:), intent(out), optional :: r
+call test_ar (p)
+
[gcc r13-8491] Fortran: no size check passing NULL() without MOLD argument [PR55978]
https://gcc.gnu.org/g:57062bc355aece623c6a38c5e813ed24f8b775f1
commit r13-8491-g57062bc355aece623c6a38c5e813ed24f8b775f1
Author: Harald Anlauf
Date: Fri Mar 22 18:17:15 2024 +0100
Fortran: no size check passing NULL() without MOLD argument [PR55978]
gcc/fortran/ChangeLog:
PR fortran/55978
* interface.cc (gfc_compare_actual_formal): Skip size check for
NULL() actual without MOLD argument.
gcc/testsuite/ChangeLog:
PR fortran/55978
* gfortran.dg/null_actual_5.f90: New test.
Diff:
---
gcc/fortran/interface.cc| 4 ++
gcc/testsuite/gfortran.dg/null_actual_5.f90 | 76 +
2 files changed, 80 insertions(+)
diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc
index 5cda94753d8..dc384ad9323 100644
--- a/gcc/fortran/interface.cc
+++ b/gcc/fortran/interface.cc
@@ -3392,6 +3392,10 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap,
gfc_formal_arglist *formal,
if (f->sym->ts.type == BT_CLASS)
goto skip_size_check;
+ /* Skip size check for NULL() actual without MOLD argument. */
+ if (a->expr->expr_type == EXPR_NULL && a->expr->ts.type == BT_UNKNOWN)
+ goto skip_size_check;
+
actual_size = get_expr_storage_size (a->expr);
formal_size = get_sym_storage_size (f->sym);
if (actual_size != 0 && actual_size < formal_size
diff --git a/gcc/testsuite/gfortran.dg/null_actual_5.f90
b/gcc/testsuite/gfortran.dg/null_actual_5.f90
new file mode 100644
index 000..1198715b7c8
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/null_actual_5.f90
@@ -0,0 +1,76 @@
+! { dg-do compile }
+! PR fortran/55978
+!
+! Passing of NULL() with and without MOLD as actual argument
+!
+! Testcase derived from pr55978 comment#16
+
+program pr55978_c16
+ implicit none
+
+ integer, pointer :: p(:)
+ integer, allocatable :: a(:)
+ character(10), pointer :: c
+ character(10), pointer :: cp(:)
+
+ type t
+integer, pointer :: p(:)
+integer, allocatable :: a(:)
+ end type
+
+ type(t) :: d
+
+ ! (1) pointer
+ p => null()
+ call sub (p)
+
+ ! (2) allocatable
+ call sub (a)
+ call sub (d%a)
+
+ ! (3) pointer component
+ d%p => null ()
+ call sub (d%p)
+
+ ! (4) NULL
+ call sub (null (a)) ! OK
+ call sub (null (p)) ! OK
+ call sub (null (d%a)) ! OK
+ call sub (null (d%p)) ! OK
+ call sub (null ())! was erroneously rejected with:
+ ! Actual argument contains too few elements for dummy argument 'x' (1/4)
+
+ call bla (null(c))
+ call bla (null()) ! was erroneously rejected with:
+ ! Actual argument contains too few elements for dummy argument 'x' (1/10)
+
+ call foo (null(cp))
+ call foo (null())
+
+ call bar (null(cp))
+ call bar (null()) ! was erroneously rejected with:
+ ! Actual argument contains too few elements for dummy argument 'x' (1/70)
+
+contains
+
+ subroutine sub(x)
+integer, intent(in), optional :: x(4)
+if (present (x)) stop 1
+ end
+
+ subroutine bla(x)
+character(len=10), intent(in), optional :: x
+if (present (x)) stop 2
+ end
+
+ subroutine foo(x)
+character(len=10), intent(in), optional :: x(:)
+if (present (x)) stop 3
+ end
+
+ subroutine bar(x)
+character(len=10), intent(in), optional :: x(7)
+if (present (x)) stop 4
+ end
+
+end
[gcc r13-8490] Fortran: fix FE memleak
https://gcc.gnu.org/g:c65c4c6af5b5321f1a517dd045ab1344e849135a commit r13-8490-gc65c4c6af5b5321f1a517dd045ab1344e849135a Author: Harald Anlauf Date: Wed Jan 3 20:21:00 2024 +0100 Fortran: fix FE memleak gcc/fortran/ChangeLog: * trans-types.cc (gfc_get_nodesc_array_type): Clear used gmp variables. Diff: --- gcc/fortran/trans-types.cc | 12 +++- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/gcc/fortran/trans-types.cc b/gcc/fortran/trans-types.cc index b514d8e5a57..b2a3000da1f 100644 --- a/gcc/fortran/trans-types.cc +++ b/gcc/fortran/trans-types.cc @@ -1791,7 +1791,7 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed, TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type)); } - return type; + goto array_type_done; } if (known_stride) @@ -1810,10 +1810,6 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed, layout_type (type); - mpz_clear (offset); - mpz_clear (stride); - mpz_clear (delta); - /* Represent packed arrays as multi-dimensional if they have rank > 1 and with proper bounds, instead of flat arrays. This makes for better debug info. */ @@ -1844,6 +1840,12 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed, GFC_ARRAY_TYPE_P (type) = 1; TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type)); } + +array_type_done: + mpz_clear (offset); + mpz_clear (stride); + mpz_clear (delta); + return type; }
[gcc r14-9631] Fortran: no size check passing NULL() without MOLD argument [PR55978]
https://gcc.gnu.org/g:c083a453dbe51853e26e02edd8b9346fb8618292
commit r14-9631-gc083a453dbe51853e26e02edd8b9346fb8618292
Author: Harald Anlauf
Date: Fri Mar 22 18:17:15 2024 +0100
Fortran: no size check passing NULL() without MOLD argument [PR55978]
gcc/fortran/ChangeLog:
PR fortran/55978
* interface.cc (gfc_compare_actual_formal): Skip size check for
NULL() actual without MOLD argument.
gcc/testsuite/ChangeLog:
PR fortran/55978
* gfortran.dg/null_actual_5.f90: New test.
Diff:
---
gcc/fortran/interface.cc| 4 ++
gcc/testsuite/gfortran.dg/null_actual_5.f90 | 76 +
2 files changed, 80 insertions(+)
diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc
index 64b90550be2..7b86a338bc1 100644
--- a/gcc/fortran/interface.cc
+++ b/gcc/fortran/interface.cc
@@ -3439,6 +3439,10 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap,
gfc_formal_arglist *formal,
if (f->sym->ts.type == BT_CLASS)
goto skip_size_check;
+ /* Skip size check for NULL() actual without MOLD argument. */
+ if (a->expr->expr_type == EXPR_NULL && a->expr->ts.type == BT_UNKNOWN)
+ goto skip_size_check;
+
actual_size = get_expr_storage_size (a->expr);
formal_size = get_sym_storage_size (f->sym);
if (actual_size != 0 && actual_size < formal_size
diff --git a/gcc/testsuite/gfortran.dg/null_actual_5.f90
b/gcc/testsuite/gfortran.dg/null_actual_5.f90
new file mode 100644
index 000..1198715b7c8
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/null_actual_5.f90
@@ -0,0 +1,76 @@
+! { dg-do compile }
+! PR fortran/55978
+!
+! Passing of NULL() with and without MOLD as actual argument
+!
+! Testcase derived from pr55978 comment#16
+
+program pr55978_c16
+ implicit none
+
+ integer, pointer :: p(:)
+ integer, allocatable :: a(:)
+ character(10), pointer :: c
+ character(10), pointer :: cp(:)
+
+ type t
+integer, pointer :: p(:)
+integer, allocatable :: a(:)
+ end type
+
+ type(t) :: d
+
+ ! (1) pointer
+ p => null()
+ call sub (p)
+
+ ! (2) allocatable
+ call sub (a)
+ call sub (d%a)
+
+ ! (3) pointer component
+ d%p => null ()
+ call sub (d%p)
+
+ ! (4) NULL
+ call sub (null (a)) ! OK
+ call sub (null (p)) ! OK
+ call sub (null (d%a)) ! OK
+ call sub (null (d%p)) ! OK
+ call sub (null ())! was erroneously rejected with:
+ ! Actual argument contains too few elements for dummy argument 'x' (1/4)
+
+ call bla (null(c))
+ call bla (null()) ! was erroneously rejected with:
+ ! Actual argument contains too few elements for dummy argument 'x' (1/10)
+
+ call foo (null(cp))
+ call foo (null())
+
+ call bar (null(cp))
+ call bar (null()) ! was erroneously rejected with:
+ ! Actual argument contains too few elements for dummy argument 'x' (1/70)
+
+contains
+
+ subroutine sub(x)
+integer, intent(in), optional :: x(4)
+if (present (x)) stop 1
+ end
+
+ subroutine bla(x)
+character(len=10), intent(in), optional :: x
+if (present (x)) stop 2
+ end
+
+ subroutine foo(x)
+character(len=10), intent(in), optional :: x(:)
+if (present (x)) stop 3
+ end
+
+ subroutine bar(x)
+character(len=10), intent(in), optional :: x(7)
+if (present (x)) stop 4
+ end
+
+end
[gcc r14-9597] Fortran: improve array component description in runtime error message [PR30802]
https://gcc.gnu.org/g:509352069d6f166d396f4b4a86e71ea521f2ca78
commit r14-9597-g509352069d6f166d396f4b4a86e71ea521f2ca78
Author: Harald Anlauf
Date: Wed Mar 20 20:59:24 2024 +0100
Fortran: improve array component description in runtime error message
[PR30802]
Runtime error messages for array bounds violation shall use the following
scheme for a coherent, abridged description of arrays or array components
of derived types:
(1) If x is an ordinary array variable, use "x"
(2) if z is a DT scalar and x an array component at level 1, use "z%x"
(3) if z is a DT scalar and x an array component at level > 1, or
if z is a DT array and x an array (at any level), use "z...%x"
Use a new helper function abridged_ref_name for construction of that name.
gcc/fortran/ChangeLog:
PR fortran/30802
* trans-array.cc (abridged_ref_name): New helper function.
(trans_array_bound_check): Use it.
(array_bound_check_elemental): Likewise.
(gfc_conv_array_ref): Likewise.
gcc/testsuite/ChangeLog:
PR fortran/30802
* gfortran.dg/bounds_check_17.f90: Adjust pattern.
* gfortran.dg/bounds_check_fail_8.f90: New test.
Diff:
---
gcc/fortran/trans-array.cc| 132 ++
gcc/testsuite/gfortran.dg/bounds_check_17.f90 | 2 +-
gcc/testsuite/gfortran.dg/bounds_check_fail_8.f90 | 56 +
3 files changed, 142 insertions(+), 48 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 0a453828bad..30b84762346 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -3485,6 +3485,78 @@ gfc_conv_array_ubound (tree descriptor, int dim)
}
+/* Generate abridged name of a part-ref for use in bounds-check message.
+ Cases:
+ (1) for an ordinary array variable x return "x"
+ (2) for z a DT scalar and array component x (at level 1) return "z%%x"
+ (3) for z a DT scalar and array component x (at level > 1) or
+ for z a DT array and array x (at any number of levels): "z...%%x"
+ */
+
+static char *
+abridged_ref_name (gfc_expr * expr, gfc_array_ref * ar)
+{
+ gfc_ref *ref;
+ gfc_symbol *sym;
+ char *ref_name = NULL;
+ const char *comp_name = NULL;
+ int len_sym, last_len = 0, level = 0;
+ bool sym_is_array;
+
+ gcc_assert (expr->expr_type == EXPR_VARIABLE && expr->ref != NULL);
+
+ sym = expr->symtree->n.sym;
+ sym_is_array = (sym->ts.type != BT_CLASS
+ ? sym->as != NULL
+ : IS_CLASS_ARRAY (sym));
+ len_sym = strlen (sym->name);
+
+ /* Scan ref chain to get name of the array component (when ar != NULL) or
+ array section, determine depth and remember its component name. */
+ for (ref = expr->ref; ref; ref = ref->next)
+{
+ if (ref->type == REF_COMPONENT
+ && strcmp (ref->u.c.component->name, "_data") != 0)
+ {
+ level++;
+ comp_name = ref->u.c.component->name;
+ continue;
+ }
+
+ if (ref->type != REF_ARRAY)
+ continue;
+
+ if (ar)
+ {
+ if (>u.ar == ar)
+ break;
+ }
+ else if (ref->u.ar.type == AR_SECTION)
+ break;
+}
+
+ if (level > 0)
+last_len = strlen (comp_name);
+
+ /* Provide a buffer sufficiently large to hold "x...%%z". */
+ ref_name = XNEWVEC (char, len_sym + last_len + 6);
+ strcpy (ref_name, sym->name);
+
+ if (level == 1 && !sym_is_array)
+{
+ strcat (ref_name, "%%");
+ strcat (ref_name, comp_name);
+}
+ else if (level > 0)
+{
+ strcat (ref_name, "...%%");
+ strcat (ref_name, comp_name);
+}
+
+ return ref_name;
+}
+
+
/* Generate code to perform an array index bound check. */
static tree
@@ -3496,7 +3568,9 @@ trans_array_bound_check (gfc_se * se, gfc_ss *ss, tree
index, int n,
tree tmp_lo, tmp_up;
tree descriptor;
char *msg;
+ char *ref_name = NULL;
const char * name = NULL;
+ gfc_expr *expr;
if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
return index;
@@ -3509,6 +3583,12 @@ trans_array_bound_check (gfc_se * se, gfc_ss *ss, tree
index, int n,
name = ss->info->expr->symtree->n.sym->name;
gcc_assert (name != NULL);
+ /* When we have a component ref, get name of the array section.
+ Note that there can only be one part ref. */
+ expr = ss->info->expr;
+ if (expr->ref && !compname)
+name = ref_name = abridged_ref_name (expr, NULL);
+
if (VAR_P (descriptor))
name = IDENTIFIER_POINTER (DECL_NAME (descriptor));
@@ -3562,6 +3642,7 @@ trans_array_bound_check (gfc_se * se, gfc_ss *ss, tree
index, int n,
free (msg);
}
+ free (ref_name);
return index;
}
@@ -3573,36 +3654,17 @@ array_bound_check_elemental (gfc_se * se, gfc_ss * ss,
gfc_expr * expr)
{
gfc_array_ref *ar;
gfc_ref *ref;
- gfc_symbol *sym;
char *var_name = NULL;
- size_t len;
int dim;
if
[gcc r11-11287] Fortran: error recovery in frontend optimization [PR103715]
https://gcc.gnu.org/g:7294f1a7aa457fe24d11270f06fd15c2b3ffd4ab
commit r11-11287-g7294f1a7aa457fe24d11270f06fd15c2b3ffd4ab
Author: Harald Anlauf
Date: Mon Mar 18 19:36:59 2024 +0100
Fortran: error recovery in frontend optimization [PR103715]
gcc/fortran/ChangeLog:
PR fortran/103715
* frontend-passes.c (check_externals_expr): Prevent invalid read
in case of mismatch of external subroutine with function.
gcc/testsuite/ChangeLog:
PR fortran/103715
* gfortran.dg/pr103715.f90: New test.
(cherry picked from commit 3be2b8f475f22c531d6cef1b041c0573b3ea5133)
Diff:
---
gcc/fortran/frontend-passes.c | 3 +++
gcc/testsuite/gfortran.dg/pr103715.f90 | 12
2 files changed, 15 insertions(+)
diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c
index ebc5a7f3699..439a311e4a5 100644
--- a/gcc/fortran/frontend-passes.c
+++ b/gcc/fortran/frontend-passes.c
@@ -5782,6 +5782,9 @@ check_externals_expr (gfc_expr **ep, int *walk_subtrees
ATTRIBUTE_UNUSED,
if (e->expr_type != EXPR_FUNCTION)
return 0;
+ if (e->symtree && e->symtree->n.sym->attr.subroutine)
+return 0;
+
sym = e->value.function.esym;
if (sym == NULL)
return 0;
diff --git a/gcc/testsuite/gfortran.dg/pr103715.f90
b/gcc/testsuite/gfortran.dg/pr103715.f90
new file mode 100644
index 000..72c5a31fb21
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr103715.f90
@@ -0,0 +1,12 @@
+! { dg-do compile }
+! PR fortran/103715 - ICE in gfc_find_gsymbol
+!
+! valgrind did report an invalid read in check_externals_procedure
+
+program p
+ select type (y => g()) ! { dg-error "Selector shall be polymorphic" }
+ end select
+ call g()
+end
+
+! { dg-prune-output "already being used as a FUNCTION" }
[gcc r12-10286] Fortran: error recovery in frontend optimization [PR103715]
https://gcc.gnu.org/g:811145b10ff30608bb5ea459ea277219ada4f13d
commit r12-10286-g811145b10ff30608bb5ea459ea277219ada4f13d
Author: Harald Anlauf
Date: Mon Mar 18 19:36:59 2024 +0100
Fortran: error recovery in frontend optimization [PR103715]
gcc/fortran/ChangeLog:
PR fortran/103715
* frontend-passes.cc (check_externals_expr): Prevent invalid read
in case of mismatch of external subroutine with function.
gcc/testsuite/ChangeLog:
PR fortran/103715
* gfortran.dg/pr103715.f90: New test.
(cherry picked from commit 3be2b8f475f22c531d6cef1b041c0573b3ea5133)
Diff:
---
gcc/fortran/frontend-passes.cc | 3 +++
gcc/testsuite/gfortran.dg/pr103715.f90 | 12
2 files changed, 15 insertions(+)
diff --git a/gcc/fortran/frontend-passes.cc b/gcc/fortran/frontend-passes.cc
index 53567307cec..de8cb5a2204 100644
--- a/gcc/fortran/frontend-passes.cc
+++ b/gcc/fortran/frontend-passes.cc
@@ -5794,6 +5794,9 @@ check_externals_expr (gfc_expr **ep, int *walk_subtrees
ATTRIBUTE_UNUSED,
if (e->expr_type != EXPR_FUNCTION)
return 0;
+ if (e->symtree && e->symtree->n.sym->attr.subroutine)
+return 0;
+
sym = e->value.function.esym;
if (sym == NULL)
return 0;
diff --git a/gcc/testsuite/gfortran.dg/pr103715.f90
b/gcc/testsuite/gfortran.dg/pr103715.f90
new file mode 100644
index 000..72c5a31fb21
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr103715.f90
@@ -0,0 +1,12 @@
+! { dg-do compile }
+! PR fortran/103715 - ICE in gfc_find_gsymbol
+!
+! valgrind did report an invalid read in check_externals_procedure
+
+program p
+ select type (y => g()) ! { dg-error "Selector shall be polymorphic" }
+ end select
+ call g()
+end
+
+! { dg-prune-output "already being used as a FUNCTION" }
[gcc r13-8468] Fortran: fix IS_CONTIGUOUS for polymorphic dummy arguments [PR114001]
https://gcc.gnu.org/g:5b928badac560ad48e0e9fc480096ff396d9d9c6
commit r13-8468-g5b928badac560ad48e0e9fc480096ff396d9d9c6
Author: Harald Anlauf
Date: Tue Mar 12 22:58:39 2024 +0100
Fortran: fix IS_CONTIGUOUS for polymorphic dummy arguments [PR114001]
gcc/fortran/ChangeLog:
PR fortran/114001
* expr.cc (gfc_is_simply_contiguous): Adjust logic so that CLASS
symbols are also handled.
gcc/testsuite/ChangeLog:
PR fortran/114001
* gfortran.dg/is_contiguous_4.f90: New test.
(cherry picked from commit 11caf47b599568c6c6f5a12cf8e21f50778176d3)
Diff:
---
gcc/fortran/expr.cc | 19 ---
gcc/testsuite/gfortran.dg/is_contiguous_4.f90 | 81 +++
2 files changed, 91 insertions(+), 9 deletions(-)
diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc
index 9fdbe7a84c5..8b9c93940c8 100644
--- a/gcc/fortran/expr.cc
+++ b/gcc/fortran/expr.cc
@@ -5994,15 +5994,16 @@ gfc_is_simply_contiguous (gfc_expr *expr, bool strict,
bool permit_element)
}
sym = expr->symtree->n.sym;
- if (expr->ts.type != BT_CLASS
- && ((part_ref
- && !part_ref->u.c.component->attr.contiguous
- && part_ref->u.c.component->attr.pointer)
- || (!part_ref
- && !sym->attr.contiguous
- && (sym->attr.pointer
- || (sym->as && sym->as->type == AS_ASSUMED_RANK)
- || (sym->as && sym->as->type == AS_ASSUMED_SHAPE)
+ if ((part_ref
+ && part_ref->u.c.component
+ && !part_ref->u.c.component->attr.contiguous
+ && IS_POINTER (part_ref->u.c.component))
+ || (!part_ref
+ && expr->ts.type != BT_CLASS
+ && !sym->attr.contiguous
+ && (sym->attr.pointer
+ || (sym->as && sym->as->type == AS_ASSUMED_RANK)
+ || (sym->as && sym->as->type == AS_ASSUMED_SHAPE
return false;
if (!ar || ar->type == AR_FULL)
diff --git a/gcc/testsuite/gfortran.dg/is_contiguous_4.f90
b/gcc/testsuite/gfortran.dg/is_contiguous_4.f90
new file mode 100644
index 000..cb066f8836b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/is_contiguous_4.f90
@@ -0,0 +1,81 @@
+! { dg-do run }
+! PR fortran/114001 - IS_CONTIGUOUS and polymorphic dummy
+
+program main
+ implicit none
+ integer :: i, cnt = 0
+ logical :: expect
+ integer, target :: m(10) = [(i,i=1,size(m))]
+ integer, pointer :: p(:)
+ type t
+ integer :: j
+ end type t
+ type(t), pointer :: tt(:), tp(:) ! Type pointer
+ class(t), pointer :: ct(:), cp(:) ! Class pointer
+
+ p => m(1:3)
+ expect = is_contiguous (p)
+ print *, "is_contiguous (p)=", expect
+ if (.not. expect) stop 91
+ call sub_star (p, expect)
+ p => m(1::3)
+ expect = is_contiguous (p)
+ print *, "is_contiguous (p)=", expect
+ if (expect) stop 92
+ call sub_star (p, expect)
+
+ allocate (tt(10))
+ tt(:)% j = m
+ tp => tt(4:6)
+ expect = is_contiguous (tp)
+ if (.not. expect) stop 96
+ print *, "is_contiguous (tp)=", expect
+ call sub_t (tp, expect)
+ tp => tt(4::3)
+ expect = is_contiguous (tp)
+ if (expect) stop 97
+ print *, "is_contiguous (tp)=", expect
+ call sub_t (tp, expect)
+
+ allocate (ct(10))
+ ct(:)% j = m
+ cp => ct(7:9)
+ expect = is_contiguous (cp)
+ print *, "is_contiguous (cp)=", expect
+ if (.not. expect) stop 98
+ call sub_t (cp, expect)
+ cp => ct(4::3)
+ expect = is_contiguous (cp)
+ print *, "is_contiguous (cp)=", expect
+ if (expect) stop 99
+ call sub_t (cp, expect)
+
+contains
+
+ subroutine sub_star (x, expect)
+class(*), intent(in) :: x(:)
+logical, intent(in) :: expect
+cnt = cnt + 10
+if (is_contiguous (x) .neqv. expect) then
+ print *, "sub_star(1): is_contiguous (x)=", is_contiguous (x), expect
+ stop (cnt + 1)
+end if
+select type (x)
+type is (integer)
+ if (is_contiguous (x) .neqv. expect) then
+ print *, "sub_star(2): is_contiguous (x)=", is_contiguous (x), expect
+ stop (cnt + 2)
+ end if
+end select
+ end
+
+ subroutine sub_t (x, expect)
+class(t), intent(in) :: x(:)
+logical, intent(in) :: expect
+cnt = cnt + 10
+if (is_contiguous (x) .neqv. expect) then
+ print *, "sub_t: is_contiguous (x)=", is_contiguous (x), expect
+ stop (cnt + 3)
+end if
+ end
+end
[gcc r13-8467] Fortran: error recovery in frontend optimization [PR103715]
https://gcc.gnu.org/g:9623e5dd70b0d8334ebe093459721d0d447ce4f2
commit r13-8467-g9623e5dd70b0d8334ebe093459721d0d447ce4f2
Author: Harald Anlauf
Date: Mon Mar 18 19:36:59 2024 +0100
Fortran: error recovery in frontend optimization [PR103715]
gcc/fortran/ChangeLog:
PR fortran/103715
* frontend-passes.cc (check_externals_expr): Prevent invalid read
in case of mismatch of external subroutine with function.
gcc/testsuite/ChangeLog:
PR fortran/103715
* gfortran.dg/pr103715.f90: New test.
(cherry picked from commit 3be2b8f475f22c531d6cef1b041c0573b3ea5133)
Diff:
---
gcc/fortran/frontend-passes.cc | 3 +++
gcc/testsuite/gfortran.dg/pr103715.f90 | 12
2 files changed, 15 insertions(+)
diff --git a/gcc/fortran/frontend-passes.cc b/gcc/fortran/frontend-passes.cc
index 85ebca56a69..349d26ec29a 100644
--- a/gcc/fortran/frontend-passes.cc
+++ b/gcc/fortran/frontend-passes.cc
@@ -5807,6 +5807,9 @@ check_externals_expr (gfc_expr **ep, int *walk_subtrees
ATTRIBUTE_UNUSED,
if (e->expr_type != EXPR_FUNCTION)
return 0;
+ if (e->symtree && e->symtree->n.sym->attr.subroutine)
+return 0;
+
sym = e->value.function.esym;
if (sym == NULL)
return 0;
diff --git a/gcc/testsuite/gfortran.dg/pr103715.f90
b/gcc/testsuite/gfortran.dg/pr103715.f90
new file mode 100644
index 000..72c5a31fb21
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr103715.f90
@@ -0,0 +1,12 @@
+! { dg-do compile }
+! PR fortran/103715 - ICE in gfc_find_gsymbol
+!
+! valgrind did report an invalid read in check_externals_procedure
+
+program p
+ select type (y => g()) ! { dg-error "Selector shall be polymorphic" }
+ end select
+ call g()
+end
+
+! { dg-prune-output "already being used as a FUNCTION" }
[gcc r14-9522] Fortran: error recovery in frontend optimization [PR103715]
https://gcc.gnu.org/g:3be2b8f475f22c531d6cef1b041c0573b3ea5133
commit r14-9522-g3be2b8f475f22c531d6cef1b041c0573b3ea5133
Author: Harald Anlauf
Date: Mon Mar 18 19:36:59 2024 +0100
Fortran: error recovery in frontend optimization [PR103715]
gcc/fortran/ChangeLog:
PR fortran/103715
* frontend-passes.cc (check_externals_expr): Prevent invalid read
in case of mismatch of external subroutine with function.
gcc/testsuite/ChangeLog:
PR fortran/103715
* gfortran.dg/pr103715.f90: New test.
Diff:
---
gcc/fortran/frontend-passes.cc | 3 +++
gcc/testsuite/gfortran.dg/pr103715.f90 | 12
2 files changed, 15 insertions(+)
diff --git a/gcc/fortran/frontend-passes.cc b/gcc/fortran/frontend-passes.cc
index 06dfa1a3232..3c06018fdbb 100644
--- a/gcc/fortran/frontend-passes.cc
+++ b/gcc/fortran/frontend-passes.cc
@@ -5807,6 +5807,9 @@ check_externals_expr (gfc_expr **ep, int *walk_subtrees
ATTRIBUTE_UNUSED,
if (e->expr_type != EXPR_FUNCTION)
return 0;
+ if (e->symtree && e->symtree->n.sym->attr.subroutine)
+return 0;
+
sym = e->value.function.esym;
if (sym == NULL)
return 0;
diff --git a/gcc/testsuite/gfortran.dg/pr103715.f90
b/gcc/testsuite/gfortran.dg/pr103715.f90
new file mode 100644
index 000..72c5a31fb21
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr103715.f90
@@ -0,0 +1,12 @@
+! { dg-do compile }
+! PR fortran/103715 - ICE in gfc_find_gsymbol
+!
+! valgrind did report an invalid read in check_externals_procedure
+
+program p
+ select type (y => g()) ! { dg-error "Selector shall be polymorphic" }
+ end select
+ call g()
+end
+
+! { dg-prune-output "already being used as a FUNCTION" }
[gcc r14-9509] Fortran: fix for absent array argument passed to optional dummy [PR101135]
https://gcc.gnu.org/g:3f3f0b7ee8022776d69ecaed1375e1559716f226
commit r14-9509-g3f3f0b7ee8022776d69ecaed1375e1559716f226
Author: Harald Anlauf
Date: Fri Mar 15 20:14:07 2024 +0100
Fortran: fix for absent array argument passed to optional dummy [PR101135]
gcc/fortran/ChangeLog:
PR fortran/101135
* trans-array.cc (gfc_get_dataptr_offset): Check for optional
arguments being present before dereferencing data pointer.
gcc/testsuite/ChangeLog:
PR fortran/101135
* gfortran.dg/missing_optional_dummy_6a.f90: Adjust diagnostic
pattern.
* gfortran.dg/ubsan/missing_optional_dummy_8.f90: New test.
Diff:
---
gcc/fortran/trans-array.cc | 11 +++
.../gfortran.dg/missing_optional_dummy_6a.f90 | 2 +-
.../gfortran.dg/ubsan/missing_optional_dummy_8.f90 | 108 +
3 files changed, 120 insertions(+), 1 deletion(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 3673fa40720..a7717a8107e 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -7526,6 +7526,17 @@ gfc_get_dataptr_offset (stmtblock_t *block, tree parm,
tree desc, tree offset,
/* Set the target data pointer. */
offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
+
+ /* Check for optional dummy argument being present. Arguments of BIND(C)
+ procedures are excepted here since they are handled differently. */
+ if (expr->expr_type == EXPR_VARIABLE
+ && expr->symtree->n.sym->attr.dummy
+ && expr->symtree->n.sym->attr.optional
+ && !is_CFI_desc (NULL, expr))
+offset = build3_loc (input_location, COND_EXPR, TREE_TYPE (offset),
+gfc_conv_expr_present (expr->symtree->n.sym), offset,
+fold_convert (TREE_TYPE (offset),
gfc_index_zero_node));
+
gfc_conv_descriptor_data_set (block, parm, offset);
}
diff --git a/gcc/testsuite/gfortran.dg/missing_optional_dummy_6a.f90
b/gcc/testsuite/gfortran.dg/missing_optional_dummy_6a.f90
index c6a79059a91..b5e1726d74d 100644
--- a/gcc/testsuite/gfortran.dg/missing_optional_dummy_6a.f90
+++ b/gcc/testsuite/gfortran.dg/missing_optional_dummy_6a.f90
@@ -49,7 +49,7 @@ end program test
! { dg-final { scan-tree-dump-times "scalar2 \\(.* slr1" 1 "original" } }
-! { dg-final { scan-tree-dump-times "= es1 != 0B" 1 "original" } }
+! { dg-final { scan-tree-dump-times "= es1 != 0B" 2 "original" } }
! { dg-final { scan-tree-dump-times "assumed_shape2 \\(es1" 0 "original" } }
! { dg-final { scan-tree-dump-times "explicit_shape2 \\(es1" 1 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/ubsan/missing_optional_dummy_8.f90
b/gcc/testsuite/gfortran.dg/ubsan/missing_optional_dummy_8.f90
new file mode 100644
index 000..fd3914934aa
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/ubsan/missing_optional_dummy_8.f90
@@ -0,0 +1,108 @@
+! { dg-do run }
+! { dg-additional-options "-fdump-tree-original -fsanitize=undefined" }
+!
+! PR fortran/101135 - Load of null pointer when passing absent
+! assumed-shape array argument for an optional dummy argument
+!
+! Based on testcase by Marcel Jacobse
+
+program main
+ implicit none
+ character(len=3) :: a(6) = ['abc', 'def', 'ghi', 'jlm', 'nop', 'qrs']
+ call as ()
+ call as (a(::2))
+ call as_c ()
+ call as_c (a(2::2))
+ call test_wrapper
+ call test_wrapper_c
+ call test_ar_wrapper
+ call test_ar_wrapper_c
+contains
+ subroutine as (xx)
+character(len=*), optional, intent(in) :: xx(*)
+if (.not. present (xx)) return
+print *, xx(1:3)
+ end subroutine as
+
+ subroutine as_c (zz) bind(c)
+character(len=*), optional, intent(in) :: zz(*)
+if (.not. present (zz)) return
+print *, zz(1:3)
+ end subroutine as_c
+
+ subroutine test_wrapper (x)
+real, dimension(1), intent(out), optional :: x
+call test (x)
+call test1 (x)
+call test_c (x)
+call test1_c (x)
+ end subroutine test_wrapper
+
+ subroutine test_wrapper_c (w) bind(c)
+real, dimension(1), intent(out), optional :: w
+call test (w)
+call test1 (w)
+call test_c (w)
+call test1_c (w)
+ end subroutine test_wrapper_c
+
+ subroutine test (y)
+real, dimension(:), intent(out), optional :: y
+if (present (y)) y=0.
+ end subroutine test
+
+ subroutine test_c (y) bind(c)
+real, dimension(:), intent(out), optional :: y
+if (present (y)) y=0.
+ end subroutine test_c
+
+ subroutine test1 (y)
+real, dimension(1), intent(out), optional :: y
+if (present (y)) y=0.
+ end subroutine test1
+
+ subroutine test1_c (y) bind(c)
+real, dimension(1), intent(out), optional :: y
+if (present (y)) y=0.
+ end subroutine test1_c
+
+ subroutine test_ar_wrapper (p, q, r)
+real, intent(out), optional :: p
+real, dimension(1), intent(out), optional :: q
+real, dimension(:), intent(out), optional :: r
+call test_ar (p)
+
[gcc r13-8443] Fortran: improve checks of NULL without MOLD as actual argument [PR104819]
https://gcc.gnu.org/g:90442fb421823153c4f762a2d26a0d700af2e6c3
commit r13-8443-g90442fb421823153c4f762a2d26a0d700af2e6c3
Author: Harald Anlauf
Date: Fri Mar 1 19:21:27 2024 +0100
Fortran: improve checks of NULL without MOLD as actual argument [PR104819]
gcc/fortran/ChangeLog:
PR fortran/104819
* check.cc (gfc_check_null): Handle nested NULL()s.
(is_c_interoperable): Check for MOLD argument of NULL() as part of
the interoperability check.
* interface.cc (gfc_compare_actual_formal): Extend checks for NULL()
actual arguments for presence of MOLD argument when required by
Interp J3/22-146.
gcc/testsuite/ChangeLog:
PR fortran/104819
* gfortran.dg/assumed_rank_9.f90: Adjust testcase use of NULL().
* gfortran.dg/pr101329.f90: Adjust testcase to conform to interp.
* gfortran.dg/null_actual_4.f90: New test.
(cherry picked from commit db0b6746be075e43c8142585968483e125bb52d0)
Diff:
---
gcc/fortran/check.cc | 5 +++-
gcc/fortran/interface.cc | 30
gcc/testsuite/gfortran.dg/assumed_rank_9.f90 | 13 +++
gcc/testsuite/gfortran.dg/null_actual_4.f90 | 35
gcc/testsuite/gfortran.dg/pr101329.f90 | 4 ++--
5 files changed, 79 insertions(+), 8 deletions(-)
diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index 8c1ae8c2f00..f39a7610073 100644
--- a/gcc/fortran/check.cc
+++ b/gcc/fortran/check.cc
@@ -4357,6 +4357,9 @@ gfc_check_null (gfc_expr *mold)
if (mold == NULL)
return true;
+ if (mold->expr_type == EXPR_NULL)
+return true;
+
if (!variable_check (mold, 0, true))
return false;
@@ -5187,7 +5190,7 @@ is_c_interoperable (gfc_expr *expr, const char **msg,
bool c_loc, bool c_f_ptr)
{
*msg = NULL;
- if (expr->expr_type == EXPR_NULL)
+ if (expr->expr_type == EXPR_NULL && expr->ts.type == BT_UNKNOWN)
{
*msg = "NULL() is not interoperable";
return false;
diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc
index e9843e9549c..5cda94753d8 100644
--- a/gcc/fortran/interface.cc
+++ b/gcc/fortran/interface.cc
@@ -3259,6 +3259,36 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap,
gfc_formal_arglist *formal,
&& a->expr->ts.type != BT_ASSUMED)
gfc_find_vtab (>expr->ts);
+ /* Interp J3/22-146:
+"If the context of the reference to NULL is an
+corresponding to an dummy argument, MOLD shall be
+present." */
+ if (a->expr->expr_type == EXPR_NULL
+ && a->expr->ts.type == BT_UNKNOWN
+ && f->sym->as
+ && f->sym->as->type == AS_ASSUMED_RANK)
+ {
+ gfc_error ("Intrinsic % without % argument at %L "
+"passed to assumed-rank dummy %qs",
+>expr->where, f->sym->name);
+ ok = false;
+ goto match;
+ }
+
+ if (a->expr->expr_type == EXPR_NULL
+ && a->expr->ts.type == BT_UNKNOWN
+ && f->sym->ts.type == BT_CHARACTER
+ && !f->sym->ts.deferred
+ && f->sym->ts.u.cl
+ && f->sym->ts.u.cl->length == NULL)
+ {
+ gfc_error ("Intrinsic % without % argument at %L "
+"passed to assumed-length dummy %qs",
+>expr->where, f->sym->name);
+ ok = false;
+ goto match;
+ }
+
if (a->expr->expr_type == EXPR_NULL
&& ((f->sym->ts.type != BT_CLASS && !f->sym->attr.pointer
&& (f->sym->attr.allocatable || !f->sym->attr.optional
diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_9.f90
b/gcc/testsuite/gfortran.dg/assumed_rank_9.f90
index 1296d068959..5e59ec136c9 100644
--- a/gcc/testsuite/gfortran.dg/assumed_rank_9.f90
+++ b/gcc/testsuite/gfortran.dg/assumed_rank_9.f90
@@ -26,19 +26,20 @@ program main
type(t), target :: y
class(t), allocatable, target :: yac
-
+ type(t), pointer :: ypt
+
y%i = 489
allocate (yac)
yac%i = 489
j = 0
call fc()
- call fc(null())
+ call fc(null(yac))
call fc(y)
call fc(yac)
if (j /= 2) STOP 1
j = 0
- call gc(null())
+! call gc(null(yac)) ! ICE
call gc(y)
call gc(yac)
deallocate (yac)
@@ -54,13 +55,14 @@ program main
j = 0
call ft()
- call ft(null())
+ call ft(null(yac))
call ft(y)
call ft(yac)
if (j /= 2) STOP 4
j = 0
- call gt(null())
+ call gt(null(ypt))
+! call gt(null(yac)) ! ICE
call gt(y)
call gt(yac)
deallocate (yac)
@@ -73,6 +75,7 @@ program main
yac%i = 489
call ht(yac)
if (j /= 1) STOP 6
+ deallocate (yac)
contains
diff --git a/gcc/testsuite/gfortran.dg/null_actual_4.f90
b/gcc/testsuite/gfortran.dg/null_actual_4.f90
new file mode 100644
index 000..e03d5c8f7de
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/null_actual_4.f90
@@ -0,0 +1,35 @@
+! { dg-do
[gcc r13-8445] Fortran: handle procedure pointer component in DT array [PR110826]
https://gcc.gnu.org/g:4e9f475cdc8617f94c903656faaf28910c21c29b
commit r13-8445-g4e9f475cdc8617f94c903656faaf28910c21c29b
Author: Harald Anlauf
Date: Mon Mar 11 22:05:51 2024 +0100
Fortran: handle procedure pointer component in DT array [PR110826]
gcc/fortran/ChangeLog:
PR fortran/110826
* array.cc (gfc_array_dimen_size): When walking the ref chain of an
array and the ultimate component is a procedure pointer, do not try
to figure out its dimension even if it is a array-valued function.
gcc/testsuite/ChangeLog:
PR fortran/110826
* gfortran.dg/proc_ptr_comp_53.f90: New test.
(cherry picked from commit 81ee1298b47d3f3b3712ef3f3b2929ca26c4bcd2)
Diff:
---
gcc/fortran/array.cc | 7 +
gcc/testsuite/gfortran.dg/proc_ptr_comp_53.f90 | 43 ++
2 files changed, 50 insertions(+)
diff --git a/gcc/fortran/array.cc b/gcc/fortran/array.cc
index be5eb8b6a0f..936f774353e 100644
--- a/gcc/fortran/array.cc
+++ b/gcc/fortran/array.cc
@@ -2600,6 +2600,13 @@ gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t
*result)
case EXPR_FUNCTION:
for (ref = array->ref; ref; ref = ref->next)
{
+ /* Ultimate component is a procedure pointer. */
+ if (ref->type == REF_COMPONENT
+ && !ref->next
+ && ref->u.c.component->attr.function
+ && IS_PROC_POINTER (ref->u.c.component))
+ return false;
+
if (ref->type != REF_ARRAY)
continue;
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_53.f90
b/gcc/testsuite/gfortran.dg/proc_ptr_comp_53.f90
new file mode 100644
index 000..affb5922235
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_53.f90
@@ -0,0 +1,43 @@
+! { dg-do compile }
+! PR fortran/110826 - procedure pointer component in DT array
+
+module m
+ implicit none
+
+ type pp
+procedure(func_template), pointer, nopass :: f =>null()
+ end type pp
+
+ abstract interface
+ function func_template(state) result(dstate)
+ implicit none
+ real, dimension(:,:), intent(in) :: state
+ real, dimension(size(state,1), size(state,2)) :: dstate
+ end function
+ end interface
+
+contains
+
+ function zero_state(state) result(dstate)
+real, dimension(:,:), intent(in) :: state
+real, dimension(size(state,1), size(state,2)) :: dstate
+dstate = 0.
+ end function zero_state
+
+end module m
+
+program test_func_array
+ use m
+ implicit none
+
+ real, dimension(4,6) :: state
+ type(pp) :: func_scalar
+ type(pp) :: func_array(4)
+
+ func_scalar %f => zero_state
+ func_array(1)%f => zero_state
+ print *, func_scalar %f(state)
+ print *, func_array(1)%f(state)
+ if (.not. all (shape (func_scalar %f(state)) == shape (state))) stop 1
+ if (.not. all (shape (func_array(1)%f(state)) == shape (state))) stop 2
+end program test_func_array
[gcc r13-8444] Fortran: allow RESTRICT qualifier also for optional arguments [PR100988]
https://gcc.gnu.org/g:337dc58139595bd9ab4101b988078c5d54d8506a
commit r13-8444-g337dc58139595bd9ab4101b988078c5d54d8506a
Author: Harald Anlauf
Date: Mon Dec 4 22:44:53 2023 +0100
Fortran: allow RESTRICT qualifier also for optional arguments [PR100988]
gcc/fortran/ChangeLog:
PR fortran/100988
* gfortran.h (IS_PROC_POINTER): New macro.
* trans-types.cc (gfc_sym_type): Use macro in determination if the
restrict qualifier can be used for a dummy variable. Fix logic to
allow the restrict qualifier also for optional arguments, and to
not apply it to pointer or proc_pointer arguments.
gcc/testsuite/ChangeLog:
PR fortran/100988
* gfortran.dg/coarray_poly_6.f90: Adjust pattern.
* gfortran.dg/coarray_poly_7.f90: Likewise.
* gfortran.dg/coarray_poly_8.f90: Likewise.
* gfortran.dg/missing_optional_dummy_6a.f90: Likewise.
* gfortran.dg/pr100988.f90: New test.
Co-authored-by: Tobias Burnus
(cherry picked from commit 9c3a880feecf81c310b4ade210fbd7004c9aece7)
Diff:
---
gcc/fortran/gfortran.h | 3 ++
gcc/fortran/trans-types.cc | 13 +++--
gcc/testsuite/gfortran.dg/coarray_poly_6.f90 | 2 +-
gcc/testsuite/gfortran.dg/coarray_poly_7.f90 | 2 +-
gcc/testsuite/gfortran.dg/coarray_poly_8.f90 | 2 +-
.../gfortran.dg/missing_optional_dummy_6a.f90 | 2 +-
gcc/testsuite/gfortran.dg/pr100988.f90 | 61 ++
7 files changed, 74 insertions(+), 11 deletions(-)
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index aba16cf998b..e6939056a7c 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3951,6 +3951,9 @@ bool gfc_may_be_finalized (gfc_typespec);
#define IS_POINTER(sym) \
(sym->ts.type == BT_CLASS && sym->attr.class_ok && CLASS_DATA (sym) \
? CLASS_DATA (sym)->attr.class_pointer : sym->attr.pointer)
+#define IS_PROC_POINTER(sym) \
+ (sym->ts.type == BT_CLASS && sym->attr.class_ok && CLASS_DATA (sym) \
+? CLASS_DATA (sym)->attr.proc_pointer : sym->attr.proc_pointer)
/* frontend-passes.cc */
diff --git a/gcc/fortran/trans-types.cc b/gcc/fortran/trans-types.cc
index fc5c221a301..b514d8e5a57 100644
--- a/gcc/fortran/trans-types.cc
+++ b/gcc/fortran/trans-types.cc
@@ -2324,8 +2324,8 @@ gfc_sym_type (gfc_symbol * sym, bool is_bind_c)
else
byref = 0;
- restricted = !sym->attr.target && !sym->attr.pointer
- && !sym->attr.proc_pointer && !sym->attr.cray_pointee;
+ restricted = (!sym->attr.target && !IS_POINTER (sym)
+ && !IS_PROC_POINTER (sym) && !sym->attr.cray_pointee);
if (!restricted)
type = gfc_nonrestricted_type (type);
@@ -2381,11 +2381,10 @@ gfc_sym_type (gfc_symbol * sym, bool is_bind_c)
|| (sym->ns->proc_name && sym->ns->proc_name->attr.entry_master))
type = build_pointer_type (type);
else
- {
- type = build_reference_type (type);
- if (restricted)
- type = build_qualified_type (type, TYPE_QUAL_RESTRICT);
- }
+ type = build_reference_type (type);
+
+ if (restricted)
+ type = build_qualified_type (type, TYPE_QUAL_RESTRICT);
}
return (type);
diff --git a/gcc/testsuite/gfortran.dg/coarray_poly_6.f90
b/gcc/testsuite/gfortran.dg/coarray_poly_6.f90
index 53b80e442d3..344e12b4eff 100644
--- a/gcc/testsuite/gfortran.dg/coarray_poly_6.f90
+++ b/gcc/testsuite/gfortran.dg/coarray_poly_6.f90
@@ -16,6 +16,6 @@ contains
end subroutine foo
end
! { dg-final { scan-tree-dump-times "foo \\(struct __class_MAIN___T_0_1t &
restrict x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\)
caf_offset..\\)" 1 "original" } }
-! { dg-final { scan-tree-dump-times "bar \\(struct __class_MAIN___T_0_1t \\*
x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\) caf_offset..\\)" 1
"original" } }
+! { dg-final { scan-tree-dump-times "bar \\(struct __class_MAIN___T_0_1t \\*
restrict x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\)
caf_offset..\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "bar \\(0B, 0B, 0\\);" 1 "original" } }
! { dg-final { scan-tree-dump-times "foo \\(, y._data.token,
\\(integer\\(kind=\[48\]\\)\\) class..._data.data -
\\(integer\\(kind=\[48\]\\)\\) y._data.data\\);" 1 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/coarray_poly_7.f90
b/gcc/testsuite/gfortran.dg/coarray_poly_7.f90
index 44f98e16e09..d8d83aea39b 100644
--- a/gcc/testsuite/gfortran.dg/coarray_poly_7.f90
+++ b/gcc/testsuite/gfortran.dg/coarray_poly_7.f90
@@ -16,6 +16,6 @@ contains
end subroutine foo
end
! { dg-final { scan-tree-dump-times "foo \\(struct __class_MAIN___T_1_1t &
restrict x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\)
caf_offset..\\)" 1 "original" } }
-! { dg-final { scan-tree-dump-times "bar
[gcc r13-8442] testsuite: fortran: fix invalid testcases (missing MOLD argument to NULL)
https://gcc.gnu.org/g:ba4b4b3864d426835ea10e900a4e1dd466d06e51 commit r13-8442-gba4b4b3864d426835ea10e900a4e1dd466d06e51 Author: Harald Anlauf Date: Wed Nov 22 21:45:46 2023 +0100 testsuite: fortran: fix invalid testcases (missing MOLD argument to NULL) The Fortran standard requires that NULL() passed to an assumed-rank dummy argument has a MOLD argument. gcc/testsuite/ChangeLog: PR fortran/104819 * gfortran.dg/assumed_rank_10.f90: Add MOLD argument to NULL(). * gfortran.dg/assumed_rank_8.f90: Likewise. (cherry picked from commit 7646b5d88056cf269ff555afe95bc361dcf5e5c0) Diff: --- gcc/testsuite/gfortran.dg/assumed_rank_10.f90 | 6 +++--- gcc/testsuite/gfortran.dg/assumed_rank_8.f90 | 4 ++-- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_10.f90 b/gcc/testsuite/gfortran.dg/assumed_rank_10.f90 index 6a3cc94483e..f22d43ab955 100644 --- a/gcc/testsuite/gfortran.dg/assumed_rank_10.f90 +++ b/gcc/testsuite/gfortran.dg/assumed_rank_10.f90 @@ -50,9 +50,9 @@ program test is_present = .false. - call fpa(null(), null()) ! No copy back - call fpi(null(), null()) ! No copy back - call fno(null(), null()) ! No copy back + call fpa(null(iip), null(jjp)) ! No copy back + call fpi(null(iip), null(jjp)) ! No copy back + call fno(null(iip), null(jjp)) ! No copy back call fno() ! No copy back diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_8.f90 b/gcc/testsuite/gfortran.dg/assumed_rank_8.f90 index 5873296a7a5..34ff42c0be2 100644 --- a/gcc/testsuite/gfortran.dg/assumed_rank_8.f90 +++ b/gcc/testsuite/gfortran.dg/assumed_rank_8.f90 @@ -22,13 +22,13 @@ program main call f (ii) call f (489) call f () - call f (null()) + call f (null(kk)) call f (kk) if (j /= 2) STOP 1 j = 0 nullify (ll) - call g (null()) + call g (null(ll)) call g (ll) call g (ii) if (j /= 1) STOP 2
[gcc r14-9454] Fortran: fix IS_CONTIGUOUS for polymorphic dummy arguments [PR114001]
https://gcc.gnu.org/g:11caf47b599568c6c6f5a12cf8e21f50778176d3
commit r14-9454-g11caf47b599568c6c6f5a12cf8e21f50778176d3
Author: Harald Anlauf
Date: Tue Mar 12 22:58:39 2024 +0100
Fortran: fix IS_CONTIGUOUS for polymorphic dummy arguments [PR114001]
gcc/fortran/ChangeLog:
PR fortran/114001
* expr.cc (gfc_is_simply_contiguous): Adjust logic so that CLASS
symbols are also handled.
gcc/testsuite/ChangeLog:
PR fortran/114001
* gfortran.dg/is_contiguous_4.f90: New test.
Diff:
---
gcc/fortran/expr.cc | 19 ---
gcc/testsuite/gfortran.dg/is_contiguous_4.f90 | 81 +++
2 files changed, 91 insertions(+), 9 deletions(-)
diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc
index 37ea95d0185..82a642b01f7 100644
--- a/gcc/fortran/expr.cc
+++ b/gcc/fortran/expr.cc
@@ -6025,15 +6025,16 @@ gfc_is_simply_contiguous (gfc_expr *expr, bool strict,
bool permit_element)
}
sym = expr->symtree->n.sym;
- if (expr->ts.type != BT_CLASS
- && ((part_ref
- && !part_ref->u.c.component->attr.contiguous
- && part_ref->u.c.component->attr.pointer)
- || (!part_ref
- && !sym->attr.contiguous
- && (sym->attr.pointer
- || (sym->as && sym->as->type == AS_ASSUMED_RANK)
- || (sym->as && sym->as->type == AS_ASSUMED_SHAPE)
+ if ((part_ref
+ && part_ref->u.c.component
+ && !part_ref->u.c.component->attr.contiguous
+ && IS_POINTER (part_ref->u.c.component))
+ || (!part_ref
+ && expr->ts.type != BT_CLASS
+ && !sym->attr.contiguous
+ && (sym->attr.pointer
+ || (sym->as && sym->as->type == AS_ASSUMED_RANK)
+ || (sym->as && sym->as->type == AS_ASSUMED_SHAPE
return false;
if (!ar || ar->type == AR_FULL)
diff --git a/gcc/testsuite/gfortran.dg/is_contiguous_4.f90
b/gcc/testsuite/gfortran.dg/is_contiguous_4.f90
new file mode 100644
index 000..cb066f8836b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/is_contiguous_4.f90
@@ -0,0 +1,81 @@
+! { dg-do run }
+! PR fortran/114001 - IS_CONTIGUOUS and polymorphic dummy
+
+program main
+ implicit none
+ integer :: i, cnt = 0
+ logical :: expect
+ integer, target :: m(10) = [(i,i=1,size(m))]
+ integer, pointer :: p(:)
+ type t
+ integer :: j
+ end type t
+ type(t), pointer :: tt(:), tp(:) ! Type pointer
+ class(t), pointer :: ct(:), cp(:) ! Class pointer
+
+ p => m(1:3)
+ expect = is_contiguous (p)
+ print *, "is_contiguous (p)=", expect
+ if (.not. expect) stop 91
+ call sub_star (p, expect)
+ p => m(1::3)
+ expect = is_contiguous (p)
+ print *, "is_contiguous (p)=", expect
+ if (expect) stop 92
+ call sub_star (p, expect)
+
+ allocate (tt(10))
+ tt(:)% j = m
+ tp => tt(4:6)
+ expect = is_contiguous (tp)
+ if (.not. expect) stop 96
+ print *, "is_contiguous (tp)=", expect
+ call sub_t (tp, expect)
+ tp => tt(4::3)
+ expect = is_contiguous (tp)
+ if (expect) stop 97
+ print *, "is_contiguous (tp)=", expect
+ call sub_t (tp, expect)
+
+ allocate (ct(10))
+ ct(:)% j = m
+ cp => ct(7:9)
+ expect = is_contiguous (cp)
+ print *, "is_contiguous (cp)=", expect
+ if (.not. expect) stop 98
+ call sub_t (cp, expect)
+ cp => ct(4::3)
+ expect = is_contiguous (cp)
+ print *, "is_contiguous (cp)=", expect
+ if (expect) stop 99
+ call sub_t (cp, expect)
+
+contains
+
+ subroutine sub_star (x, expect)
+class(*), intent(in) :: x(:)
+logical, intent(in) :: expect
+cnt = cnt + 10
+if (is_contiguous (x) .neqv. expect) then
+ print *, "sub_star(1): is_contiguous (x)=", is_contiguous (x), expect
+ stop (cnt + 1)
+end if
+select type (x)
+type is (integer)
+ if (is_contiguous (x) .neqv. expect) then
+ print *, "sub_star(2): is_contiguous (x)=", is_contiguous (x), expect
+ stop (cnt + 2)
+ end if
+end select
+ end
+
+ subroutine sub_t (x, expect)
+class(t), intent(in) :: x(:)
+logical, intent(in) :: expect
+cnt = cnt + 10
+if (is_contiguous (x) .neqv. expect) then
+ print *, "sub_t: is_contiguous (x)=", is_contiguous (x), expect
+ stop (cnt + 3)
+end if
+ end
+end
[gcc r14-9442] Fortran: handle procedure pointer component in DT array [PR110826]
https://gcc.gnu.org/g:81ee1298b47d3f3b3712ef3f3b2929ca26c4bcd2
commit r14-9442-g81ee1298b47d3f3b3712ef3f3b2929ca26c4bcd2
Author: Harald Anlauf
Date: Mon Mar 11 22:05:51 2024 +0100
Fortran: handle procedure pointer component in DT array [PR110826]
gcc/fortran/ChangeLog:
PR fortran/110826
* array.cc (gfc_array_dimen_size): When walking the ref chain of an
array and the ultimate component is a procedure pointer, do not try
to figure out its dimension even if it is a array-valued function.
gcc/testsuite/ChangeLog:
PR fortran/110826
* gfortran.dg/proc_ptr_comp_53.f90: New test.
Diff:
---
gcc/fortran/array.cc | 7 +
gcc/testsuite/gfortran.dg/proc_ptr_comp_53.f90 | 43 ++
2 files changed, 50 insertions(+)
diff --git a/gcc/fortran/array.cc b/gcc/fortran/array.cc
index 3a6e3a7c95b..e9934f1491b 100644
--- a/gcc/fortran/array.cc
+++ b/gcc/fortran/array.cc
@@ -2597,6 +2597,13 @@ gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t
*result)
case EXPR_FUNCTION:
for (ref = array->ref; ref; ref = ref->next)
{
+ /* Ultimate component is a procedure pointer. */
+ if (ref->type == REF_COMPONENT
+ && !ref->next
+ && ref->u.c.component->attr.function
+ && IS_PROC_POINTER (ref->u.c.component))
+ return false;
+
if (ref->type != REF_ARRAY)
continue;
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_53.f90
b/gcc/testsuite/gfortran.dg/proc_ptr_comp_53.f90
new file mode 100644
index 000..affb5922235
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_53.f90
@@ -0,0 +1,43 @@
+! { dg-do compile }
+! PR fortran/110826 - procedure pointer component in DT array
+
+module m
+ implicit none
+
+ type pp
+procedure(func_template), pointer, nopass :: f =>null()
+ end type pp
+
+ abstract interface
+ function func_template(state) result(dstate)
+ implicit none
+ real, dimension(:,:), intent(in) :: state
+ real, dimension(size(state,1), size(state,2)) :: dstate
+ end function
+ end interface
+
+contains
+
+ function zero_state(state) result(dstate)
+real, dimension(:,:), intent(in) :: state
+real, dimension(size(state,1), size(state,2)) :: dstate
+dstate = 0.
+ end function zero_state
+
+end module m
+
+program test_func_array
+ use m
+ implicit none
+
+ real, dimension(4,6) :: state
+ type(pp) :: func_scalar
+ type(pp) :: func_array(4)
+
+ func_scalar %f => zero_state
+ func_array(1)%f => zero_state
+ print *, func_scalar %f(state)
+ print *, func_array(1)%f(state)
+ if (.not. all (shape (func_scalar %f(state)) == shape (state))) stop 1
+ if (.not. all (shape (func_array(1)%f(state)) == shape (state))) stop 2
+end program test_func_array
[gcc r13-8407] Fortran: do not evaluate polymorphic functions twice in assignment [PR114012]
https://gcc.gnu.org/g:1f5787e4b803a4294eeb80e048f56ccdb99c1b3b
commit r13-8407-g1f5787e4b803a4294eeb80e048f56ccdb99c1b3b
Author: Harald Anlauf
Date: Sun Feb 25 21:18:23 2024 +0100
Fortran: do not evaluate polymorphic functions twice in assignment
[PR114012]
PR fortran/114012
gcc/fortran/ChangeLog:
* trans-expr.cc (gfc_conv_procedure_call): Evaluate non-trivial
arguments just once before assigning to an unlimited polymorphic
dummy variable.
gcc/testsuite/ChangeLog:
* gfortran.dg/pr114012.f90: New test.
(cherry picked from commit 2f71e801ad0bb1f620334aadbd7c99cc4efe6309)
Diff:
---
gcc/fortran/trans-expr.cc | 4 ++
gcc/testsuite/gfortran.dg/pr114012.f90 | 81 ++
2 files changed, 85 insertions(+)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 48af30740fe..316ad684a64 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -6518,6 +6518,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
{
tree efield;
+ /* Evaluate arguments just once. */
+ if (e->expr_type != EXPR_VARIABLE)
+ parmse.expr = save_expr (parmse.expr);
+
/* Set the _data field. */
tmp = gfc_class_data_get (var);
efield = fold_convert (TREE_TYPE (tmp),
diff --git a/gcc/testsuite/gfortran.dg/pr114012.f90
b/gcc/testsuite/gfortran.dg/pr114012.f90
new file mode 100644
index 000..9dbb031c664
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr114012.f90
@@ -0,0 +1,81 @@
+! { dg-do run }
+! PR fortran/114012
+!
+! Polymorphic functions were evaluated twice in assignment
+
+program test
+ implicit none
+
+ type :: custom_int
+ integer :: val = 2
+ end type
+
+ interface assignment(=)
+ procedure assign
+ end interface
+ interface operator(-)
+ procedure neg
+ end interface
+
+ type(custom_int) :: i
+ integer :: count_assign, count_neg
+
+ count_assign = 0
+ count_neg= 0
+
+ i = 1
+ if (count_assign /= 1 .or. count_neg /= 0) stop 1
+
+ i = -i
+ if (count_assign /= 2 .or. count_neg /= 1) stop 2
+ if (i% val /= -1) stop 3
+
+ i = neg(i)
+ if (count_assign /= 3 .or. count_neg /= 2) stop 4
+ if (i% val /= 1) stop 5
+
+ i = (neg(i))
+ if (count_assign /= 4 .or. count_neg /= 3) stop 6
+ if (i% val /= -1) stop 7
+
+ i = - neg(i)
+ if (count_assign /= 5 .or. count_neg /= 5) stop 8
+ if (i% val /= -1) stop 9
+
+contains
+
+ subroutine assign (field, val)
+type(custom_int), intent(out) :: field
+class(*), intent(in) :: val
+
+count_assign = count_assign + 1
+
+select type (val)
+type is (integer)
+! print *, " in assign(integer)", field%val, val
+ field%val = val
+type is (custom_int)
+! print *, " in assign(custom)", field%val, val%val
+ field%val = val%val
+class default
+ error stop
+end select
+
+ end subroutine assign
+
+ function neg (input_field) result(output_field)
+type(custom_int), intent(in), target :: input_field
+class(custom_int), allocatable :: output_field
+allocate (custom_int :: output_field)
+
+count_neg = count_neg + 1
+
+select type (output_field)
+type is (custom_int)
+! print *, " in neg", output_field%val, input_field%val
+ output_field%val = -input_field%val
+class default
+ error stop
+end select
+ end function neg
+end program test
[gcc r13-8406] Fortran: ALLOCATE statement, SOURCE/MOLD expressions with subrefs [PR114024]
https://gcc.gnu.org/g:77cf842869ddda8cfcdbb7db6e65ecfb9ac432fc
commit r13-8406-g77cf842869ddda8cfcdbb7db6e65ecfb9ac432fc
Author: Steve Kargl
Date: Fri Feb 23 22:05:04 2024 +0100
Fortran: ALLOCATE statement, SOURCE/MOLD expressions with subrefs [PR114024]
PR fortran/114024
gcc/fortran/ChangeLog:
* trans-stmt.cc (gfc_trans_allocate): When a source expression has
substring references, part-refs, or %re/%im inquiries, wrap the
entity in parentheses to force evaluation of the expression.
gcc/testsuite/ChangeLog:
* gfortran.dg/allocate_with_source_27.f90: New test.
* gfortran.dg/allocate_with_source_28.f90: New test.
Co-Authored-By: Harald Anlauf
(cherry picked from commit 80d126ba99f4b9bc64d4861b3c4bae666497f2d4)
Diff:
---
gcc/fortran/trans-stmt.cc | 10 ++-
.../gfortran.dg/allocate_with_source_27.f90| 20 +
.../gfortran.dg/allocate_with_source_28.f90| 90 ++
3 files changed, 118 insertions(+), 2 deletions(-)
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index 776f98d08d9..35eb1880539 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -6318,8 +6318,14 @@ gfc_trans_allocate (gfc_code * code)
vtab_needed = (al->expr->ts.type == BT_CLASS);
gfc_init_se (, NULL);
- /* When expr3 is a variable, i.e., a very simple expression,
-then convert it once here. */
+ /* When expr3 is a variable, i.e., a very simple expression, then
+convert it once here. If one has a source expression that has
+substring references, part-refs, or %re/%im inquiries, wrap the
+entity in parentheses to force evaluation of the expression. */
+ if (code->expr3->expr_type == EXPR_VARIABLE
+ && is_subref_array (code->expr3))
+ code->expr3 = gfc_get_parentheses (code->expr3);
+
if (code->expr3->expr_type == EXPR_VARIABLE
|| code->expr3->expr_type == EXPR_ARRAY
|| code->expr3->expr_type == EXPR_CONSTANT)
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_27.f90
b/gcc/testsuite/gfortran.dg/allocate_with_source_27.f90
new file mode 100644
index 000..d0f0f3c4a84
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_27.f90
@@ -0,0 +1,20 @@
+!
+! { dg-do run }
+!
+! fortran/PR114024
+! https://github.com/fujitsu/compiler-test-suite
+! Modified from Fortran/0093/0093_0130.f90
+!
+program foo
+ implicit none
+ complex :: cmp(3)
+ real, allocatable :: xx(:), yy(:), zz(:)
+ cmp = (3., 6.78)
+ allocate(xx, source = cmp%re) ! This caused an ICE.
+ allocate(yy, source = cmp(1:3)%re) ! This caused an ICE.
+ allocate(zz, source = (cmp%re))
+ if (any(xx /= [3., 3., 3.])) stop 1
+ if (any(yy /= [3., 3., 3.])) stop 2
+ if (any(zz /= [3., 3., 3.])) stop 3
+end program foo
+
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_28.f90
b/gcc/testsuite/gfortran.dg/allocate_with_source_28.f90
new file mode 100644
index 000..8548ccb34e2
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_28.f90
@@ -0,0 +1,90 @@
+! { dg-do run }
+!
+! PR fortran/114024
+
+program foo
+ implicit none
+ complex :: cmp(3) = (3.,4.)
+ type ci ! pseudo "complex integer" type
+ integer :: re
+ integer :: im
+ end type ci
+ type cr ! pseudo "complex" type
+ real :: re
+ real :: im
+ end type cr
+ type u
+ type(ci) :: ii(3)
+ type(cr) :: rr(3)
+ end type u
+ type(u) :: cc
+
+ cc% ii% re = nint (cmp% re)
+ cc% ii% im = nint (cmp% im)
+ cc% rr% re = cmp% re
+ cc% rr% im = cmp% im
+
+ call test_substring ()
+ call test_int_real ()
+ call test_poly ()
+
+contains
+
+ subroutine test_substring ()
+character(4) :: str(3) = ["abcd","efgh","ijkl"]
+character(:), allocatable :: ac(:)
+allocate (ac, source=str(1::2)(2:4))
+if (size (ac) /= 2 .or. len (ac) /= 3) stop 11
+if (ac(2) /= "jkl")stop 12
+deallocate (ac)
+allocate (ac, mold=str(1::2)(2:4))
+if (size (ac) /= 2 .or. len (ac) /= 3) stop 13
+deallocate (ac)
+ end
+
+ subroutine test_int_real ()
+integer, allocatable :: aa(:)
+real, pointer :: pp(:)
+allocate (aa, source = cc% ii% im)
+if (size (aa) /= 3) stop 21
+if (any (aa /= cmp% im)) stop 22
+allocate (pp, source = cc% rr% re)
+if (size (pp) /= 3) stop 23
+if (any (pp /= cmp% re)) stop 24
+deallocate (aa, pp)
+ end
+
+ subroutine test_poly ()
+class(*), allocatable :: uu(:), vv(:)
+allocate (uu, source = cc% ii% im)
+allocate (vv, source = cc% rr% re)
+if (size (uu) /= 3) stop 31
+if (size (vv) /= 3) stop 32
+call check (uu)
+call check (vv)
+deallocate (uu, vv)
+allocate (uu, mold = cc% ii% im)
+allocate (vv, mold = cc% rr% re)
+if
[gcc r14-9340] Fortran: error recovery while simplifying expressions [PR103707, PR106987]
https://gcc.gnu.org/g:93e1d4d24ed014387da97e2ce11556d68fe98e66
commit r14-9340-g93e1d4d24ed014387da97e2ce11556d68fe98e66
Author: Harald Anlauf
Date: Tue Mar 5 21:54:26 2024 +0100
Fortran: error recovery while simplifying expressions [PR103707,PR106987]
When an exception is encountered during simplification of arithmetic
expressions, the result may depend on whether range-checking is active
(-frange-check) or not. However, the code path in the front-end should
stay the same for "soft" errors for which the exception is triggered by the
check, while "hard" errors should always terminate the simplification, so
that error recovery is independent of the flag. Separation of arithmetic
error codes into "hard" and "soft" errors shall be done consistently via
is_hard_arith_error().
PR fortran/103707
PR fortran/106987
gcc/fortran/ChangeLog:
* arith.cc (is_hard_arith_error): New helper function to determine
whether an arithmetic error is "hard" or not.
(check_result): Use it.
(gfc_arith_divide): Set "Division by zero" only for regular
numerators of real and complex divisions.
(reduce_unary): Use is_hard_arith_error to determine whether a hard
or (recoverable) soft error was encountered. Terminate immediately
on hard error, otherwise remember code of first soft error.
(reduce_binary_ac): Likewise.
(reduce_binary_ca): Likewise.
(reduce_binary_aa): Likewise.
gcc/testsuite/ChangeLog:
* gfortran.dg/pr99350.f90:
* gfortran.dg/arithmetic_overflow_3.f90: New test.
Diff:
---
gcc/fortran/arith.cc | 134 +++--
.../gfortran.dg/arithmetic_overflow_3.f90 | 48
gcc/testsuite/gfortran.dg/pr99350.f90 | 2 +-
3 files changed, 143 insertions(+), 41 deletions(-)
diff --git a/gcc/fortran/arith.cc b/gcc/fortran/arith.cc
index d17d1aaa1d9..b373c25e5e1 100644
--- a/gcc/fortran/arith.cc
+++ b/gcc/fortran/arith.cc
@@ -130,6 +130,30 @@ gfc_arith_error (arith code)
}
+/* Check if a certain arithmetic error code is severe enough to prevent
+ further simplification, as opposed to errors thrown by the range check
+ (e.g. overflow) or arithmetic exceptions that are tolerated with
+ -fno-range-check. */
+
+static bool
+is_hard_arith_error (arith code)
+{
+ switch (code)
+{
+case ARITH_OK:
+case ARITH_OVERFLOW:
+case ARITH_UNDERFLOW:
+case ARITH_NAN:
+case ARITH_DIV0:
+case ARITH_ASYMMETRIC:
+ return false;
+
+default:
+ return true;
+}
+}
+
+
/* Get things ready to do math. */
void
@@ -579,10 +603,10 @@ check_result (arith rc, gfc_expr *x, gfc_expr *r,
gfc_expr **rp)
val = ARITH_OK;
}
- if (val == ARITH_OK || val == ARITH_OVERFLOW)
-*rp = r;
- else
+ if (is_hard_arith_error (val))
gfc_free_expr (r);
+ else
+*rp = r;
return val;
}
@@ -792,23 +816,26 @@ gfc_arith_divide (gfc_expr *op1, gfc_expr *op2, gfc_expr
**resultp)
break;
case BT_REAL:
- if (mpfr_sgn (op2->value.real) == 0 && flag_range_check == 1)
- {
- rc = ARITH_DIV0;
- break;
- }
+ /* Set "Division by zero" only for regular numerator. */
+ if (flag_range_check == 1
+ && mpfr_zero_p (op2->value.real)
+ && mpfr_regular_p (op1->value.real))
+ rc = ARITH_DIV0;
mpfr_div (result->value.real, op1->value.real, op2->value.real,
GFC_RND_MODE);
break;
case BT_COMPLEX:
- if (mpc_cmp_si_si (op2->value.complex, 0, 0) == 0
- && flag_range_check == 1)
- {
- rc = ARITH_DIV0;
- break;
- }
+ /* Set "Division by zero" only for regular numerator. */
+ if (flag_range_check == 1
+ && mpfr_zero_p (mpc_realref (op2->value.complex))
+ && mpfr_zero_p (mpc_imagref (op2->value.complex))
+ && ((mpfr_regular_p (mpc_realref (op1->value.complex))
+ && mpfr_number_p (mpc_imagref (op1->value.complex)))
+ || (mpfr_regular_p (mpc_imagref (op1->value.complex))
+ && mpfr_number_p (mpc_realref (op1->value.complex)
+ rc = ARITH_DIV0;
gfc_set_model (mpc_realref (op1->value.complex));
if (mpc_cmp_si_si (op2->value.complex, 0, 0) == 0)
@@ -1323,7 +1350,6 @@ reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **),
gfc_expr *op,
gfc_constructor *c;
gfc_expr *r;
arith rc;
- bool ov = false;
if (op->expr_type == EXPR_CONSTANT)
return eval (op, result);
@@ -1335,19 +1361,22 @@ reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **),
gfc_expr *op,
head = gfc_constructor_copy (op->value.constructor);
for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
{
- rc = reduce_unary (eval, c->expr, );
+
