[gcc r13-8689] Fortran: Fix ICE and clear incorrect error messages [PR114739]
https://gcc.gnu.org/g:094f8a36dffea52fe6a64596203b82648a3f6121
commit r13-8689-g094f8a36dffea52fe6a64596203b82648a3f6121
Author: Paul Thomas
Date: Mon May 6 08:21:14 2024 +0100
Fortran: Fix ICE and clear incorrect error messages [PR114739]
2024-05-06 Paul Thomas
gcc/fortran
PR fortran/114739
* primary.cc (gfc_match_varspec): Check for default type before
checking for derived types with the right component name.
gcc/testsuite/
PR fortran/114739
* gfortran.dg/pr114739.f90: New test.
* gfortran.dg/derived_comp_array_ref_8.f90: Add 'implicit none'
for consistency with expected error message.
* gfortran.dg/nullify_4.f90: ditto
* gfortran.dg/pointer_init_6.f90: ditto
* gfortran.dg/pr107397.f90: ditto
* gfortran.dg/pr88138.f90: ditto
Diff:
---
gcc/fortran/primary.cc | 9 +
gcc/testsuite/gfortran.dg/derived_comp_array_ref_8.f90 | 1 +
gcc/testsuite/gfortran.dg/nullify_4.f90| 1 +
gcc/testsuite/gfortran.dg/pointer_init_6.f90 | 2 +-
gcc/testsuite/gfortran.dg/pr107397.f90 | 1 +
gcc/testsuite/gfortran.dg/pr114739.f90 | 11 +++
gcc/testsuite/gfortran.dg/pr88138.f90 | 1 +
7 files changed, 25 insertions(+), 1 deletion(-)
diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index edbd162ed13..a1b6b74765a 100644
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
@@ -2199,6 +2199,15 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag,
bool sub_flag,
match mm;
old_loc = gfc_current_locus;
mm = gfc_match_name (name);
+
+ /* Check to see if this has a default type. */
+ if (sym->ts.type == BT_UNKNOWN && tgt_expr == NULL
+ && gfc_get_default_type (sym->name, sym->ns)->type != BT_UNKNOWN)
+ {
+ gfc_set_default_type (sym, 0, sym->ns);
+ primary->ts = sym->ts;
+ }
+
if (mm == MATCH_YES && is_inquiry_ref (name, &tmp))
inquiry = true;
gfc_current_locus = old_loc;
diff --git a/gcc/testsuite/gfortran.dg/derived_comp_array_ref_8.f90
b/gcc/testsuite/gfortran.dg/derived_comp_array_ref_8.f90
index 739f4adfb78..22dfdc668a6 100644
--- a/gcc/testsuite/gfortran.dg/derived_comp_array_ref_8.f90
+++ b/gcc/testsuite/gfortran.dg/derived_comp_array_ref_8.f90
@@ -2,6 +2,7 @@
!
! PR fortran/52325
!
+implicit none
real :: f
cc%a = 5 ! { dg-error "Symbol 'cc' at .1. has no IMPLICIT type" }
f%a = 5 ! { dg-error "Unexpected '%' for nonderived-type variable 'f' at" }
diff --git a/gcc/testsuite/gfortran.dg/nullify_4.f90
b/gcc/testsuite/gfortran.dg/nullify_4.f90
index 0fd5056ee07..240110fabf8 100644
--- a/gcc/testsuite/gfortran.dg/nullify_4.f90
+++ b/gcc/testsuite/gfortran.dg/nullify_4.f90
@@ -3,6 +3,7 @@
!
! Check error recovery; was crashing before.
!
+implicit none
real, pointer :: ptr
nullify(ptr, mesh%coarser) ! { dg-error "Symbol 'mesh' at .1. has no IMPLICIT
type" }
end
diff --git a/gcc/testsuite/gfortran.dg/pointer_init_6.f90
b/gcc/testsuite/gfortran.dg/pointer_init_6.f90
index 3abad4ae179..477626e66bb 100644
--- a/gcc/testsuite/gfortran.dg/pointer_init_6.f90
+++ b/gcc/testsuite/gfortran.dg/pointer_init_6.f90
@@ -21,7 +21,7 @@ end module m1
module m2
-
+ implicit none
type :: t
procedure(s), pointer, nopass :: ppc
end type
diff --git a/gcc/testsuite/gfortran.dg/pr107397.f90
b/gcc/testsuite/gfortran.dg/pr107397.f90
index fd59bf16007..f77b4b00d00 100644
--- a/gcc/testsuite/gfortran.dg/pr107397.f90
+++ b/gcc/testsuite/gfortran.dg/pr107397.f90
@@ -1,6 +1,7 @@
!{ dg-do compile }
!
program p
+ implicit none
type t
real :: a = 1.0
end type
diff --git a/gcc/testsuite/gfortran.dg/pr114739.f90
b/gcc/testsuite/gfortran.dg/pr114739.f90
new file mode 100644
index 000..eb82cb3f65b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr114739.f90
@@ -0,0 +1,11 @@
+! { dg-do compile }
+! The fix here was triggered by an ICE prior to r14-9489-g3fd46d859cda10
+! Before that gfortran gave an incorrect "no implicit type" error for all
+! three statements.
+program main
+ implicit complex(z)
+ implicit character(c)
+ z2%re = 1.
+ z2%im = 2.
+ print *, z2, c%kind
+end
diff --git a/gcc/testsuite/gfortran.dg/pr88138.f90
b/gcc/testsuite/gfortran.dg/pr88138.f90
index c4019a6ca2e..f1130cf2bab 100644
--- a/gcc/testsuite/gfortran.dg/pr88138.f90
+++ b/gcc/testsuite/gfortran.dg/pr88138.f90
@@ -1,5 +1,6 @@
! { dg-do compile }
program p
+ implicit none
type t
character :: c = 'c'
end type
[gcc r12-10415] Fortran: Fix ICE and clear incorrect error messages [PR114739]
https://gcc.gnu.org/g:3a5acd2583056e8cd0e5fda83e7c34be65415c62
commit r12-10415-g3a5acd2583056e8cd0e5fda83e7c34be65415c62
Author: Paul Thomas
Date: Mon May 6 08:21:14 2024 +0100
Fortran: Fix ICE and clear incorrect error messages [PR114739]
2024-05-06 Paul Thomas
gcc/fortran
PR fortran/114739
* primary.cc (gfc_match_varspec): Check for default type before
checking for derived types with the right component name.
gcc/testsuite/
PR fortran/114739
* gfortran.dg/pr114739.f90: New test.
* gfortran.dg/derived_comp_array_ref_8.f90: Add 'implicit none'
for consistency with expected error message.
* gfortran.dg/nullify_4.f90: ditto
* gfortran.dg/pointer_init_6.f90: ditto
* gfortran.dg/pr107397.f90: ditto
* gfortran.dg/pr88138.f90: ditto
(cherry picked from commit 094f8a36dffea52fe6a64596203b82648a3f6121)
Diff:
---
gcc/fortran/primary.cc | 9 +
gcc/testsuite/gfortran.dg/derived_comp_array_ref_8.f90 | 1 +
gcc/testsuite/gfortran.dg/nullify_4.f90| 1 +
gcc/testsuite/gfortran.dg/pointer_init_6.f90 | 2 +-
gcc/testsuite/gfortran.dg/pr107397.f90 | 1 +
gcc/testsuite/gfortran.dg/pr114739.f90 | 11 +++
gcc/testsuite/gfortran.dg/pr88138.f90 | 1 +
7 files changed, 25 insertions(+), 1 deletion(-)
diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index 78295c54b6c..4f8bd129ee9 100644
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
@@ -2207,6 +2207,15 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag,
bool sub_flag,
match mm;
old_loc = gfc_current_locus;
mm = gfc_match_name (name);
+
+ /* Check to see if this has a default type. */
+ if (sym->ts.type == BT_UNKNOWN && tgt_expr == NULL
+ && gfc_get_default_type (sym->name, sym->ns)->type != BT_UNKNOWN)
+ {
+ gfc_set_default_type (sym, 0, sym->ns);
+ primary->ts = sym->ts;
+ }
+
if (mm == MATCH_YES && is_inquiry_ref (name, &tmp))
inquiry = true;
gfc_current_locus = old_loc;
diff --git a/gcc/testsuite/gfortran.dg/derived_comp_array_ref_8.f90
b/gcc/testsuite/gfortran.dg/derived_comp_array_ref_8.f90
index 739f4adfb78..22dfdc668a6 100644
--- a/gcc/testsuite/gfortran.dg/derived_comp_array_ref_8.f90
+++ b/gcc/testsuite/gfortran.dg/derived_comp_array_ref_8.f90
@@ -2,6 +2,7 @@
!
! PR fortran/52325
!
+implicit none
real :: f
cc%a = 5 ! { dg-error "Symbol 'cc' at .1. has no IMPLICIT type" }
f%a = 5 ! { dg-error "Unexpected '%' for nonderived-type variable 'f' at" }
diff --git a/gcc/testsuite/gfortran.dg/nullify_4.f90
b/gcc/testsuite/gfortran.dg/nullify_4.f90
index 0fd5056ee07..240110fabf8 100644
--- a/gcc/testsuite/gfortran.dg/nullify_4.f90
+++ b/gcc/testsuite/gfortran.dg/nullify_4.f90
@@ -3,6 +3,7 @@
!
! Check error recovery; was crashing before.
!
+implicit none
real, pointer :: ptr
nullify(ptr, mesh%coarser) ! { dg-error "Symbol 'mesh' at .1. has no IMPLICIT
type" }
end
diff --git a/gcc/testsuite/gfortran.dg/pointer_init_6.f90
b/gcc/testsuite/gfortran.dg/pointer_init_6.f90
index 3abad4ae179..477626e66bb 100644
--- a/gcc/testsuite/gfortran.dg/pointer_init_6.f90
+++ b/gcc/testsuite/gfortran.dg/pointer_init_6.f90
@@ -21,7 +21,7 @@ end module m1
module m2
-
+ implicit none
type :: t
procedure(s), pointer, nopass :: ppc
end type
diff --git a/gcc/testsuite/gfortran.dg/pr107397.f90
b/gcc/testsuite/gfortran.dg/pr107397.f90
index fd59bf16007..f77b4b00d00 100644
--- a/gcc/testsuite/gfortran.dg/pr107397.f90
+++ b/gcc/testsuite/gfortran.dg/pr107397.f90
@@ -1,6 +1,7 @@
!{ dg-do compile }
!
program p
+ implicit none
type t
real :: a = 1.0
end type
diff --git a/gcc/testsuite/gfortran.dg/pr114739.f90
b/gcc/testsuite/gfortran.dg/pr114739.f90
new file mode 100644
index 000..eb82cb3f65b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr114739.f90
@@ -0,0 +1,11 @@
+! { dg-do compile }
+! The fix here was triggered by an ICE prior to r14-9489-g3fd46d859cda10
+! Before that gfortran gave an incorrect "no implicit type" error for all
+! three statements.
+program main
+ implicit complex(z)
+ implicit character(c)
+ z2%re = 1.
+ z2%im = 2.
+ print *, z2, c%kind
+end
diff --git a/gcc/testsuite/gfortran.dg/pr88138.f90
b/gcc/testsuite/gfortran.dg/pr88138.f90
index c4019a6ca2e..f1130cf2bab 100644
--- a/gcc/testsuite/gfortran.dg/pr88138.f90
+++ b/gcc/testsuite/gfortran.dg/pr88138.f90
@@ -1,5 +1,6 @@
! { dg-do compile }
program p
+ implicit none
type t
character :: c = 'c'
end type
[gcc r13-8690] Fortran: Fix a gimplifier ICE/wrong result with finalization [PR36337]
https://gcc.gnu.org/g:9f204cc695d27d0b8eb69d9a4d266261171185ae
commit r13-8690-g9f204cc695d27d0b8eb69d9a4d266261171185ae
Author: Paul Thomas
Date: Fri Mar 29 07:23:19 2024 +
Fortran: Fix a gimplifier ICE/wrong result with finalization [PR36337]
2024-03-29 Paul Thomas
gcc/fortran
PR fortran/36337
PR fortran/110987
PR fortran/113885
* trans-expr.cc (gfc_trans_assignment_1): Place finalization
block before rhs post block for elemental rhs.
* trans.cc (gfc_finalize_tree_expr): Check directly if a type
has no components, rather than the zero components attribute.
Treat elemental zero component expressions in the same way as
scalars.
gcc/testsuite/
PR fortran/113885
* gfortran.dg/finalize_54.f90: New test.
* gfortran.dg/finalize_55.f90: New test.
gcc/testsuite/
PR fortran/110987
* gfortran.dg/finalize_56.f90: New test.
(cherry picked from commit 3c793f0361bc66d2a6bf0b3e1fb3234fc511e2a6)
Diff:
---
gcc/fortran/trans-expr.cc | 9 +-
gcc/fortran/trans.cc | 6 +-
gcc/testsuite/gfortran.dg/finalize_54.f90 | 47 +
gcc/testsuite/gfortran.dg/finalize_55.f90 | 89
gcc/testsuite/gfortran.dg/finalize_56.f90 | 168 ++
5 files changed, 313 insertions(+), 6 deletions(-)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index c3f02c83b3f..5e4d04483ec 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -12182,11 +12182,14 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr *
expr2, bool init_flag,
gfc_add_block_to_block (&body, &lse.pre);
gfc_add_expr_to_block (&body, tmp);
- /* Add the post blocks to the body. */
- if (!l_is_temp)
+ /* Add the post blocks to the body. Scalar finalization must appear before
+ the post block in case any dellocations are done. */
+ if (rse.finalblock.head
+ && (!l_is_temp || (expr2->expr_type == EXPR_FUNCTION
+&& gfc_expr_attr (expr2).elemental)))
{
- gfc_add_block_to_block (&rse.finalblock, &rse.post);
gfc_add_block_to_block (&body, &rse.finalblock);
+ gfc_add_block_to_block (&body, &rse.post);
}
else
gfc_add_block_to_block (&body, &rse.post);
diff --git a/gcc/fortran/trans.cc b/gcc/fortran/trans.cc
index f7745add045..67ac06138e1 100644
--- a/gcc/fortran/trans.cc
+++ b/gcc/fortran/trans.cc
@@ -1527,7 +1527,7 @@ gfc_finalize_tree_expr (gfc_se *se, gfc_symbol *derived,
}
else if (derived && gfc_is_finalizable (derived, NULL))
{
- if (derived->attr.zero_comp && !rank)
+ if (!derived->components && (!rank || attr.elemental))
{
/* Any attempt to assign zero length entities, causes the gimplifier
all manner of problems. Instead, a variable is created to act as
@@ -1578,7 +1578,7 @@ gfc_finalize_tree_expr (gfc_se *se, gfc_symbol *derived,
final_fndecl);
if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
{
- if (is_class)
+ if (is_class || attr.elemental)
desc = gfc_conv_scalar_to_descriptor (se, desc, attr);
else
{
@@ -1588,7 +1588,7 @@ gfc_finalize_tree_expr (gfc_se *se, gfc_symbol *derived,
}
}
- if (derived && derived->attr.zero_comp)
+ if (derived && !derived->components)
{
/* All the conditions below break down for zero length derived types. */
tmp = build_call_expr_loc (input_location, final_fndecl, 3,
diff --git a/gcc/testsuite/gfortran.dg/finalize_54.f90
b/gcc/testsuite/gfortran.dg/finalize_54.f90
new file mode 100644
index 000..73d32b1b333
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/finalize_54.f90
@@ -0,0 +1,47 @@
+! { dg-do compile }
+! Test the fix for PR113885, where not only was there a gimplifier ICE
+! for a derived type 't' with no components but, with a component, gfortran
+! gave wrong results.
+! Contributed by David Binderman
+!
+module types
+ type t
+ contains
+ final :: finalize
+ end type t
+contains
+ pure subroutine finalize(x)
+type(t), intent(inout) :: x
+ end subroutine finalize
+end module types
+
+subroutine test1(x)
+ use types
+ interface
+ elemental function elem(x)
+ use types
+ type(t), intent(in) :: x
+ type(t) :: elem
+ end function elem
+ end interface
+ type(t) :: x(:)
+ x = elem(x)
+end subroutine test1
+
+subroutine test2(x)
+ use types
+ interface
+ elemental function elem(x)
+ use types
+ type(t), intent(in) :: x
+ type(t) :: elem
+ end function elem
+ elemental function elem2(x, y)
+ use types
+ type(t), intent(in) :: x, y
+ type(t) :: elem2
+ end function elem2
+ end interface
+ type(t) :: x(:)
+ x = elem2(elem(x), elem(x))
+end
[gcc r13-8691] Fortran: Fix wrong recursive errors and class initialization [PR112407]
https://gcc.gnu.org/g:f598a1c8a77e678ca009b433fd849b4834594926
commit r13-8691-gf598a1c8a77e678ca009b433fd849b4834594926
Author: Paul Thomas
Date: Tue Apr 2 14:19:09 2024 +0100
Fortran: Fix wrong recursive errors and class initialization [PR112407]
2024-04-02 Paul Thomas
gcc/fortran
PR fortran/112407
* resolve.cc (resolve_procedure_expression): Change the test for
for recursion in the case of hidden procedures from modules.
(resolve_typebound_static): Add warning for possible recursive
calls to typebound procedures.
* trans-expr.cc (gfc_trans_class_init_assign): Do not apply
default initializer to class dummy where component initializers
are all null.
gcc/testsuite/
PR fortran/112407
* gfortran.dg/pr112407a.f90: New test.
* gfortran.dg/pr112407b.f90: New test.
(cherry picked from commit 35408b3669fac104cd380582b32e32c64a603d8b)
Diff:
---
gcc/fortran/resolve.cc | 23 +--
gcc/fortran/trans-expr.cc | 16
gcc/testsuite/gfortran.dg/pr112407a.f90 | 71 +
gcc/testsuite/gfortran.dg/pr112407b.f90 | 58 +++
4 files changed, 164 insertions(+), 4 deletions(-)
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index e12997bc4a0..388209d2832 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -1950,12 +1950,20 @@ resolve_procedure_expression (gfc_expr* expr)
|| (sym->attr.function && sym->result == sym))
return true;
- /* A non-RECURSIVE procedure that is used as procedure expression within its
+ /* A non-RECURSIVE procedure that is used as procedure expression within its
own body is in danger of being called recursively. */
if (is_illegal_recursion (sym, gfc_current_ns))
-gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
-" itself recursively. Declare it RECURSIVE or use"
-" %<-frecursive%>", sym->name, &expr->where);
+{
+ if (sym->attr.use_assoc && expr->symtree->name[0] == '@')
+ gfc_warning (0, "Non-RECURSIVE procedure %qs from module %qs is "
+" possibly calling itself recursively in procedure %qs. "
+" Declare it RECURSIVE or use %<-frecursive%>",
+sym->name, sym->module, gfc_current_ns->proc_name->name);
+ else
+ gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
+" itself recursively. Declare it RECURSIVE or use"
+" %<-frecursive%>", sym->name, &expr->where);
+}
return true;
}
@@ -6624,6 +6632,13 @@ resolve_typebound_static (gfc_expr* e, gfc_symtree**
target,
if (st)
*target = st;
}
+
+ if (is_illegal_recursion ((*target)->n.sym, gfc_current_ns)
+ && !e->value.compcall.tbp->deferred)
+gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
+" itself recursively. Declare it RECURSIVE or use"
+" %<-frecursive%>", (*target)->n.sym->name, &e->where);
+
return true;
}
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 5e4d04483ec..c7ec591e279 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -1692,6 +1692,7 @@ gfc_trans_class_init_assign (gfc_code *code)
tree tmp;
gfc_se dst,src,memsz;
gfc_expr *lhs, *rhs, *sz;
+ gfc_component *cmp;
gfc_start_block (&block);
@@ -1708,6 +1709,21 @@ gfc_trans_class_init_assign (gfc_code *code)
/* The _def_init is always scalar. */
rhs->rank = 0;
+ /* Check def_init for initializers. If this is a dummy with all default
+ initializer components NULL, return NULL_TREE and use the passed value as
+ required by F2018(8.5.10). */
+ if (!lhs->ref && lhs->symtree->n.sym->attr.dummy)
+{
+ cmp = rhs->ref->next->u.c.component->ts.u.derived->components;
+ for (; cmp; cmp = cmp->next)
+ {
+ if (cmp->initializer)
+ break;
+ else if (!cmp->next)
+ return build_empty_stmt (input_location);
+ }
+}
+
if (code->expr1->ts.type == BT_CLASS
&& CLASS_DATA (code->expr1)->attr.dimension)
{
diff --git a/gcc/testsuite/gfortran.dg/pr112407a.f90
b/gcc/testsuite/gfortran.dg/pr112407a.f90
new file mode 100644
index 000..470f4191611
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr112407a.f90
@@ -0,0 +1,71 @@
+! { dg-do run }
+! Test of an issue found in the investigation of PR112407
+! Contributed by Tomas Trnka
+!
+module m
+ private new_t
+
+ type s
+procedure(),pointer,nopass :: op
+ end type
+
+ type :: t
+integer :: i
+type (s) :: s
+ contains
+procedure :: new_t
+procedure :: bar
+procedure :: add_t
+generic :: new => new_t, bar
+generic, public :: assignment(=) => add_t
[gcc r13-8692] Fortran: Add error for subroutine passed to a variable dummy [PR106999]
https://gcc.gnu.org/g:429935510202c4efee933bf907fd9dff816193f2
commit r13-8692-g429935510202c4efee933bf907fd9dff816193f2
Author: Paul Thomas
Date: Tue Apr 2 15:53:29 2024 +0100
Fortran: Add error for subroutine passed to a variable dummy [PR106999]
2024-04-02 Paul Thomas
gcc/fortran
PR fortran/106999
* interface.cc (gfc_compare_interfaces): Add error for a
subroutine proc pointer passed to a variable formal.
(compare_parameter): If a procedure pointer is being passed to
a non-procedure formal arg, and there is an an interface, use
gfc_compare_interfaces to check and provide a more useful error
message.
gcc/testsuite/
PR fortran/106999
* gfortran.dg/pr106999.f90: New test.
(cherry picked from commit a7aa9455a8b9cb080649a7357b7360f2d99bcbf1)
Diff:
---
gcc/fortran/interface.cc | 20 +++-
gcc/testsuite/gfortran.dg/pr106999.f90 | 33 +
2 files changed, 52 insertions(+), 1 deletion(-)
diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc
index dc384ad9323..05c92ab8f67 100644
--- a/gcc/fortran/interface.cc
+++ b/gcc/fortran/interface.cc
@@ -1752,6 +1752,14 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2,
const char *name2,
return false;
}
+ if (s2->attr.subroutine && s1->attr.flavor == FL_VARIABLE)
+{
+ if (errmsg != NULL)
+ snprintf (errmsg, err_len, "subroutine proc pointer '%s' passed "
+ "to dummy variable '%s'", name2, s1->name);
+ return false;
+}
+
/* Do strict checks on all characteristics
(for dummy procedures and procedure pointer assignments). */
if (!generic_flag && strict_flag)
@@ -2388,12 +2396,22 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
{
gfc_symbol *act_sym = actual->symtree->n.sym;
- if (formal->attr.flavor != FL_PROCEDURE)
+ if (formal->attr.flavor != FL_PROCEDURE && !act_sym->ts.interface)
{
if (where)
gfc_error ("Invalid procedure argument at %L", &actual->where);
return false;
}
+ else if (act_sym->ts.interface
+ && !gfc_compare_interfaces (formal, act_sym->ts.interface,
+ act_sym->name, 0, 1, err,
+ sizeof(err),NULL, NULL))
+ {
+ if (where)
+ gfc_error_opt (0, "Interface mismatch in dummy procedure %qs at %L:"
+ " %s", formal->name, &actual->where, err);
+ return false;
+ }
if (!gfc_compare_interfaces (formal, act_sym, act_sym->name, 0, 1, err,
sizeof(err), NULL, NULL))
diff --git a/gcc/testsuite/gfortran.dg/pr106999.f90
b/gcc/testsuite/gfortran.dg/pr106999.f90
new file mode 100644
index 000..f05a27006f6
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr106999.f90
@@ -0,0 +1,33 @@
+! { dg-do compile }
+! Test the fix for PR106999
+! Contributed by Gerhard Steinmetz
+program p
+ type t
+ integer :: i
+ procedure(g), pointer :: f
+ end type
+ class(t), allocatable :: y, z
+ procedure(g), pointer :: ff
+ allocate (z)
+ z%i = 42
+ z%f => g
+ ff => g
+ call r(z%f)
+ call s(z%f) ! { dg-error "Interface mismatch in dummy procedure" }
+ call s(ff) ! { dg-error "Interface mismatch in dummy procedure" }
+contains
+ subroutine g(x)
+ class(t) :: x
+ x%i = 84
+ end
+ subroutine r(x)
+ procedure(g) :: x
+ print *, "in r"
+ allocate (y)
+ call x(y)
+ print *, y%i
+ end
+ subroutine s(x)
+ class(*) :: x
+ end subroutine
+end
[gcc r12-10416] Fortran: Add error for subroutine passed to a variable dummy [PR106999]
https://gcc.gnu.org/g:d72e9f90e370538b057690b16c1e65350dbbb75c
commit r12-10416-gd72e9f90e370538b057690b16c1e65350dbbb75c
Author: Paul Thomas
Date: Tue Apr 2 15:53:29 2024 +0100
Fortran: Add error for subroutine passed to a variable dummy [PR106999]
2024-04-02 Paul Thomas
gcc/fortran
PR fortran/106999
* interface.cc (gfc_compare_interfaces): Add error for a
subroutine proc pointer passed to a variable formal.
(compare_parameter): If a procedure pointer is being passed to
a non-procedure formal arg, and there is an an interface, use
gfc_compare_interfaces to check and provide a more useful error
message.
gcc/testsuite/
PR fortran/106999
* gfortran.dg/pr106999.f90: New test.
(cherry picked from commit a7aa9455a8b9cb080649a7357b7360f2d99bcbf1)
Diff:
---
gcc/fortran/interface.cc | 20 +++-
gcc/testsuite/gfortran.dg/pr106999.f90 | 33 +
2 files changed, 52 insertions(+), 1 deletion(-)
diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc
index 874acb914f3..0c4cd385d56 100644
--- a/gcc/fortran/interface.cc
+++ b/gcc/fortran/interface.cc
@@ -1746,6 +1746,14 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2,
const char *name2,
return false;
}
+ if (s2->attr.subroutine && s1->attr.flavor == FL_VARIABLE)
+{
+ if (errmsg != NULL)
+ snprintf (errmsg, err_len, "subroutine proc pointer '%s' passed "
+ "to dummy variable '%s'", name2, s1->name);
+ return false;
+}
+
/* Do strict checks on all characteristics
(for dummy procedures and procedure pointer assignments). */
if (!generic_flag && strict_flag)
@@ -2381,12 +2389,22 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
{
gfc_symbol *act_sym = actual->symtree->n.sym;
- if (formal->attr.flavor != FL_PROCEDURE)
+ if (formal->attr.flavor != FL_PROCEDURE && !act_sym->ts.interface)
{
if (where)
gfc_error ("Invalid procedure argument at %L", &actual->where);
return false;
}
+ else if (act_sym->ts.interface
+ && !gfc_compare_interfaces (formal, act_sym->ts.interface,
+ act_sym->name, 0, 1, err,
+ sizeof(err),NULL, NULL))
+ {
+ if (where)
+ gfc_error_opt (0, "Interface mismatch in dummy procedure %qs at %L:"
+ " %s", formal->name, &actual->where, err);
+ return false;
+ }
if (!gfc_compare_interfaces (formal, act_sym, act_sym->name, 0, 1, err,
sizeof(err), NULL, NULL))
diff --git a/gcc/testsuite/gfortran.dg/pr106999.f90
b/gcc/testsuite/gfortran.dg/pr106999.f90
new file mode 100644
index 000..f05a27006f6
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr106999.f90
@@ -0,0 +1,33 @@
+! { dg-do compile }
+! Test the fix for PR106999
+! Contributed by Gerhard Steinmetz
+program p
+ type t
+ integer :: i
+ procedure(g), pointer :: f
+ end type
+ class(t), allocatable :: y, z
+ procedure(g), pointer :: ff
+ allocate (z)
+ z%i = 42
+ z%f => g
+ ff => g
+ call r(z%f)
+ call s(z%f) ! { dg-error "Interface mismatch in dummy procedure" }
+ call s(ff) ! { dg-error "Interface mismatch in dummy procedure" }
+contains
+ subroutine g(x)
+ class(t) :: x
+ x%i = 84
+ end
+ subroutine r(x)
+ procedure(g) :: x
+ print *, "in r"
+ allocate (y)
+ call x(y)
+ print *, y%i
+ end
+ subroutine s(x)
+ class(*) :: x
+ end subroutine
+end
[gcc r13-8714] Fortran: Fix ICE in trans-stmt.cc(gfc_trans_call) [PR114535]
https://gcc.gnu.org/g:9fd6f7e912415f426382099d6aa182fd2b8ebb82
commit r13-8714-g9fd6f7e912415f426382099d6aa182fd2b8ebb82
Author: Paul Thomas
Date: Tue Apr 9 15:27:28 2024 +0100
Fortran: Fix ICE in trans-stmt.cc(gfc_trans_call) [PR114535]
2024-04-09 Paul Thomas
gcc/fortran
PR fortran/114535
* resolve.cc (resolve_symbol): Remove last chunk that checked
for finalization of unreferenced symbols.
gcc/testsuite/
PR fortran/114535
* gfortran.dg/pr114535d.f90: New test.
* gfortran.dg/pr114535iv.f90: Additional source.
(cherry picked from commit de82b0cf981e49a0bda957c0ac31146b17407e23)
Diff:
---
gcc/fortran/resolve.cc | 9 ---
gcc/testsuite/gfortran.dg/pr114535d.f90 | 42
gcc/testsuite/gfortran.dg/pr114535iv.f90 | 18 ++
3 files changed, 60 insertions(+), 9 deletions(-)
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 388209d28329..453dd90b5fbc 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -16700,15 +16700,6 @@ resolve_symbol (gfc_symbol *sym)
if (sym->param_list)
resolve_pdt (sym);
-
- if (!sym->attr.referenced
- && (sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED))
-{
- gfc_expr *final_expr = gfc_lval_expr_from_sym (sym);
- if (gfc_is_finalizable (final_expr->ts.u.derived, NULL))
- gfc_set_sym_referenced (sym);
- gfc_free_expr (final_expr);
-}
}
diff --git a/gcc/testsuite/gfortran.dg/pr114535d.f90
b/gcc/testsuite/gfortran.dg/pr114535d.f90
new file mode 100644
index ..7ce178a1e303
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr114535d.f90
@@ -0,0 +1,42 @@
+! { dg-do compile }
+! { dg-compile-aux-modules "pr114535iv.f90" }
+! Contributed by Andrew Benson
+!
+module d
+ implicit none
+contains
+ function en() result(dd)
+use :: iv
+implicit none
+type(vs) :: dd
+dd%i = 1
+ end function en
+end module d
+
+! Delete line 1 and all brands complain that 'vs' is an undefined type.
+! Delete lines 1 and line 2 recreates the original problem.
+module ni
+ implicit none
+contains
+ subroutine iss1()
+!use :: iv! line 1
+use :: d
+implicit none
+!type(vs) :: ans; ans = en(); ! line 2
+ end subroutine iss1
+ subroutine iss2()
+use :: d
+implicit none
+ end subroutine iss2
+end module ni ! Used to give an ICE: in gfc_trans_call, at
fortran/trans-stmt.cc:400
+
+ use ni
+ use iv
+ type(vs) :: x
+ call iss1()
+ call iss1()
+ if ((ctr .eq. 0) .or. (ctr .ne. 6)) stop 1 ! Depends whether lines 1 & 2
are present
+ call iss2()
+ x = vs(42)
+ if ((ctr .eq. 1) .or. (ctr .ne. 7)) stop 2 ! Make sure destructor available
here
+end
diff --git a/gcc/testsuite/gfortran.dg/pr114535iv.f90
b/gcc/testsuite/gfortran.dg/pr114535iv.f90
new file mode 100644
index ..be629991023e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr114535iv.f90
@@ -0,0 +1,18 @@
+! Compiled with pr114535d.f90
+! Contributed by Andrew Benson
+!
+module iv
+ type, public :: vs
+ integer :: i
+ contains
+ final :: destructor
+ end type vs
+ integer :: ctr = 0
+contains
+ impure elemental subroutine destructor(s)
+type(vs), intent(inout) :: s
+s%i = 0
+ctr = ctr + 1
+ end subroutine destructor
+end module iv
+
[gcc r13-8715] Fortran: Fix ICE in gfc_trans_pointer_assignment [PR113956]
https://gcc.gnu.org/g:102d52967bde164d6b99037465688b62d57ae560
commit r13-8715-g102d52967bde164d6b99037465688b62d57ae560
Author: Paul Thomas
Date: Tue Apr 9 15:23:46 2024 +0100
Fortran: Fix ICE in gfc_trans_pointer_assignment [PR113956]
2024-04-09 Paul Thomas
gcc/fortran
PR fortran/113956
* trans-expr.cc (gfc_trans_pointer_assignment): Remove assert
causing the ICE since it was unnecesary.
gcc/testsuite/
PR fortran/113956
* gfortran.dg/pr113956.f90: New test.
(cherry picked from commit 88aea122a7ee639230bf17a9eda4bf8a5eb7e282)
Diff:
---
gcc/fortran/trans-expr.cc | 9 +++--
gcc/testsuite/gfortran.dg/pr113956.f90 | 21 +
2 files changed, 24 insertions(+), 6 deletions(-)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index c7ec591e279d..5c5fabf5f5ae 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -10257,12 +10257,9 @@ gfc_trans_pointer_assignment (gfc_expr * expr1,
gfc_expr * expr2)
{
gfc_symbol *psym = expr1->symtree->n.sym;
tmp = NULL_TREE;
- if (psym->ts.type == BT_CHARACTER)
- {
- gcc_assert (psym->ts.u.cl->backend_decl
- && VAR_P (psym->ts.u.cl->backend_decl));
- tmp = psym->ts.u.cl->backend_decl;
- }
+ if (psym->ts.type == BT_CHARACTER
+ && psym->ts.u.cl->backend_decl)
+ tmp = psym->ts.u.cl->backend_decl;
else if (expr1->ts.u.cl->backend_decl
&& VAR_P (expr1->ts.u.cl->backend_decl))
tmp = expr1->ts.u.cl->backend_decl;
diff --git a/gcc/testsuite/gfortran.dg/pr113956.f90
b/gcc/testsuite/gfortran.dg/pr113956.f90
new file mode 100644
index ..229e891f847b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr113956.f90
@@ -0,0 +1,21 @@
+! { dg-do run }
+! Test the fix for PR113956
+! Contributed by David Binderman
+module m
+contains
+ subroutine test_array_char(p, x)
+character(*), target :: x(:)
+character(:), pointer :: p(:)
+p => x ! ICE
+ end subroutine
+end module
+
+ use m
+ character(:), allocatable, target :: chr(:)
+ character(:), pointer :: p(:)
+ chr = ["ab","cd"]
+ call test_array_char (p, chr)
+ if (loc (chr) .ne. loc (p)) stop 1
+ if (len (p) .ne. 2) stop 2
+ if (any (p .ne. chr)) stop 3
+end
[gcc r13-8716] Fortran: Fix ICE in gfc_trans_create_temp_array from bad type [PR93678]
https://gcc.gnu.org/g:80bb0bda4a96da7e690cb4df572fcb9604f511f8
commit r13-8716-g80bb0bda4a96da7e690cb4df572fcb9604f511f8
Author: Paul Thomas
Date: Thu Apr 25 06:56:10 2024 +0100
Fortran: Fix ICE in gfc_trans_create_temp_array from bad type [PR93678]
2024-04-25 Paul Thomas
gcc/fortran
PR fortran/93678
* trans-expr.cc (gfc_conv_procedure_call): Use the interface,
where possible, to obtain the type of character procedure
pointers of class entities.
gcc/testsuite/
PR fortran/93678
* gfortran.dg/pr93678.f90: New test.
(cherry picked from commit c058105bc47a0701e157d1028e60f48554561f9f)
Diff:
---
gcc/fortran/trans-expr.cc | 10 --
gcc/testsuite/gfortran.dg/pr93678.f90 | 32
2 files changed, 40 insertions(+), 2 deletions(-)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 5c5fabf5f5ae..cfe03252582c 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -7626,8 +7626,14 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
{
gcc_assert (se->loop && info);
- /* Set the type of the array. */
- tmp = gfc_typenode_for_spec (&comp->ts);
+ /* Set the type of the array. vtable charlens are not always reliable.
+Use the interface, if possible. */
+ if (comp->ts.type == BT_CHARACTER
+ && expr->symtree->n.sym->ts.type == BT_CLASS
+ && comp->ts.interface && comp->ts.interface->result)
+ tmp = gfc_typenode_for_spec (&comp->ts.interface->result->ts);
+ else
+ tmp = gfc_typenode_for_spec (&comp->ts);
gcc_assert (se->ss->dimen == se->loop->dimen);
/* Evaluate the bounds of the result, if known. */
diff --git a/gcc/testsuite/gfortran.dg/pr93678.f90
b/gcc/testsuite/gfortran.dg/pr93678.f90
new file mode 100644
index ..403bedd0c4fd
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr93678.f90
@@ -0,0 +1,32 @@
+! { dg-do compile }
+! Test the fix for PR93678 in which the charlen for the 'unpackbytes'
+! vtable field was incomplete and caused the ICE as indicated.
+! Contributed by Luis Kornblueh
+!
+! The testcase was reduced by various gfortran regulars.
+module mo_a
+ implicit none
+ type t_b
+integer :: i
+ contains
+procedure :: unpackbytes => b_unpackbytes
+ end type t_b
+contains
+ function b_unpackbytes (me) result (res)
+class(t_b), intent(inout) :: me
+character :: res(1)
+res = char (me%i)
+ end function b_unpackbytes
+ subroutine b_unpackint (me, c)
+class(t_b), intent(inout) :: me
+character, intent(in) :: c
+! print *, b_unpackbytes (me) ! ok
+if (any (me% unpackbytes () .ne. c)) stop 1 ! ICEd here
+ end subroutine b_unpackint
+end module mo_a
+
+ use mo_a
+ class(t_b), allocatable :: z
+ allocate (z, source = t_b(97))
+ call b_unpackint (z, "a")
+end
[gcc r13-8717] Fortran: Generate new charlens for shared symbol typespecs [PR89462]
https://gcc.gnu.org/g:ff78ffe8f912bc8d2d355f22d32e1ddb9a1169aa
commit r13-8717-gff78ffe8f912bc8d2d355f22d32e1ddb9a1169aa
Author: Paul Thomas
Date: Thu Apr 25 06:52:31 2024 +0100
Fortran: Generate new charlens for shared symbol typespecs [PR89462]
2024-04-25 Paul Thomas
Jakub Jelinek
gcc/fortran
PR fortran/89462
* decl.cc (build_sym): Add an extra argument 'elem'. If 'elem'
is greater than 1, gfc_new_charlen is called to generate a new
charlen, registered in the symbol namespace.
(variable_decl, enumerator_decl): Set the new argument in the
calls to build_sym.
gcc/testsuite/
PR fortran/89462
* gfortran.dg/pr89462.f90: New test.
(cherry picked from commit 1fd5a07444776d76cdd6a2eee7df0478201197a5)
Diff:
---
gcc/fortran/decl.cc | 11 +++
gcc/testsuite/gfortran.dg/pr89462.f90 | 13 +
2 files changed, 20 insertions(+), 4 deletions(-)
diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index 527e84ad7637..19321685e550 100644
--- a/gcc/fortran/decl.cc
+++ b/gcc/fortran/decl.cc
@@ -1708,7 +1708,7 @@ gfc_verify_c_interop_param (gfc_symbol *sym)
/* Function called by variable_decl() that adds a name to the symbol table. */
static bool
-build_sym (const char *name, gfc_charlen *cl, bool cl_deferred,
+build_sym (const char *name, int elem, gfc_charlen *cl, bool cl_deferred,
gfc_array_spec **as, locus *var_locus)
{
symbol_attribute attr;
@@ -1773,7 +1773,10 @@ build_sym (const char *name, gfc_charlen *cl, bool
cl_deferred,
if (sym->ts.type == BT_CHARACTER)
{
- sym->ts.u.cl = cl;
+ if (elem > 1)
+ sym->ts.u.cl = gfc_new_charlen (sym->ns, cl);
+ else
+ sym->ts.u.cl = cl;
sym->ts.deferred = cl_deferred;
}
@@ -2955,7 +2958,7 @@ variable_decl (int elem)
create a symbol for those yet. If we fail to create the symbol,
bail out. */
if (!gfc_comp_struct (gfc_current_state ())
- && !build_sym (name, cl, cl_deferred, &as, &var_locus))
+ && !build_sym (name, elem, cl, cl_deferred, &as, &var_locus))
{
m = MATCH_ERROR;
goto cleanup;
@@ -10903,7 +10906,7 @@ enumerator_decl (void)
/* OK, we've successfully matched the declaration. Now put the
symbol in the current namespace. If we fail to create the symbol,
bail out. */
- if (!build_sym (name, NULL, false, &as, &var_locus))
+ if (!build_sym (name, 1, NULL, false, &as, &var_locus))
{
m = MATCH_ERROR;
goto cleanup;
diff --git a/gcc/testsuite/gfortran.dg/pr89462.f90
b/gcc/testsuite/gfortran.dg/pr89462.f90
new file mode 100644
index ..b2a4912fcc85
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr89462.f90
@@ -0,0 +1,13 @@
+! { dg-do compile }
+! { dg-options "-pedantic-errors" }
+! Test the fix for PR89462 in which the shared 'cl' field of the typespec
+! shared between 'test', 'TR' and 'aTP' caused the compiler to go into an
+! infinite loop.
+! Contributed by Sergei Trofimovich
+ CHARACTER*1 FUNCTION test(H) ! { dg-warning "Old-style character length" }
+ CHARACTER*1 test2,TR,aTP ! { dg-warning "Old-style character length" }
+ ENTRY test2(L)
+ CALL ttest3(aTP)
+ test = TR
+ RETURN
+ END
[gcc r15-386] Fortran: Unlimited polymorphic intrinsic function arguments [PR84006]
https://gcc.gnu.org/g:b9294757f82aae8de6d98c122cd4e3b98f685217
commit r15-386-gb9294757f82aae8de6d98c122cd4e3b98f685217
Author: Paul Thomas
Date: Sun May 12 06:59:45 2024 +0100
Fortran: Unlimited polymorphic intrinsic function arguments [PR84006]
2024-05-12 Paul Thomas
gcc/fortran
PR fortran/84006
PR fortran/100027
PR fortran/98534
* iresolve.cc (gfc_resolve_transfer): Emit a TODO error for
unlimited polymorphic mold.
* trans-expr.cc (gfc_resize_class_size_with_len): Use the fold
even if a block is not available in which to fix the result.
(trans_class_assignment): Enable correct assignment of
character expressions to unlimited polymorphic variables using
lhs _len field and rse string_length.
* trans-intrinsic.cc (gfc_conv_intrinsic_storage_size): Extract
the class expression so that the unlimited polymorphic class
expression can be used in gfc_resize_class_size_with_len to
obtain the storage size for character payloads. Guard the use
of GFC_DECL_SAVED_DESCRIPTOR by testing for DECL_LANG_SPECIFIC
to prevent the ICE. Also, invert the order to use the class
expression extracted from the argument.
(gfc_conv_intrinsic_transfer): In same way as 'storage_size',
use the _len field to obtaining the correct length for arg 1.
Add a branch for the element size in bytes of class expressions
with provision to make use of the unlimited polymorphic _len
field. Again, the class references are explicitly identified.
'mold_expr' was already declared. Use it instead of 'arg'. Do
not fix 'dest_word_len' for deferred character sources because
reallocation on assign makes use of it before it is assigned.
gcc/testsuite/
PR fortran/84006
PR fortran/100027
* gfortran.dg/storage_size_7.f90: New test.
PR fortran/98534
* gfortran.dg/transfer_class_4.f90: New test.
Diff:
---
gcc/fortran/iresolve.cc| 4 ++
gcc/fortran/trans-expr.cc | 15 -
gcc/fortran/trans-intrinsic.cc | 80 +-
gcc/testsuite/gfortran.dg/storage_size_7.f90 | 91 ++
gcc/testsuite/gfortran.dg/transfer_class_4.f90 | 87
5 files changed, 257 insertions(+), 20 deletions(-)
diff --git a/gcc/fortran/iresolve.cc b/gcc/fortran/iresolve.cc
index c961cdbc2df4..c63a4a8d38cd 100644
--- a/gcc/fortran/iresolve.cc
+++ b/gcc/fortran/iresolve.cc
@@ -3025,6 +3025,10 @@ gfc_resolve_transfer (gfc_expr *f, gfc_expr *source
ATTRIBUTE_UNUSED,
}
}
+ if (UNLIMITED_POLY (mold))
+gfc_error ("TODO: unlimited polymorphic MOLD in TRANSFER intrinsic at %L",
+ &mold->where);
+
f->ts = mold->ts;
if (size == NULL && mold->rank == 0)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index bc8eb419cffe..4590aa6edb44 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -317,6 +317,8 @@ gfc_resize_class_size_with_len (stmtblock_t * block, tree
class_expr, tree size)
size = gfc_evaluate_now (size, block);
tmp = gfc_evaluate_now (fold_convert (type , tmp), block);
}
+ else
+ tmp = fold_convert (type , tmp);
tmp2 = fold_build2_loc (input_location, MULT_EXPR,
type, size, tmp);
tmp = fold_build2_loc (input_location, GT_EXPR,
@@ -11994,15 +11996,24 @@ trans_class_assignment (stmtblock_t *block, gfc_expr
*lhs, gfc_expr *rhs,
/* 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)
+ if (UNLIMITED_POLY (rhs))
{
- tree len = trans_get_upoly_len (block, rhs);
+ tree len;
+ if (rhs->expr_type == EXPR_VARIABLE)
+ len = trans_get_upoly_len (block, rhs);
+ else
+ len = gfc_class_len_get (tmp);
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));
}
+ else if (rhs->ts.type == BT_CHARACTER && rse->string_length)
+ size = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_charlen_type_node, size,
+ rse->string_length);
+
tmp = lse->expr;
class_han = GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
diff --git a/gcc/fortran/trans-intrinsic.cc b/gc
[gcc r15-394] Fortran: Fix wrong code in unlimited polymorphic assignment [PR113363]
https://gcc.gnu.org/g:2d0eeb529d400e61197a09c56011be976dd81ef0
commit r15-394-g2d0eeb529d400e61197a09c56011be976dd81ef0
Author: Paul Thomas
Date: Mon May 13 07:27:20 2024 +0100
Fortran: Fix wrong code in unlimited polymorphic assignment [PR113363]
2024-05-13 Paul Thomas
gcc/fortran
PR fortran/113363
* trans-array.cc (gfc_array_init_size): Use the expr3 dtype so
that the correct element size is used.
* trans-expr.cc (gfc_conv_procedure_call): Remove restriction
that ss and ss->loop be present for the finalization of class
array function results.
(trans_class_assignment): Use free and malloc, rather than
realloc, for character expressions assigned to unlimited poly
entities.
* trans-stmt.cc (gfc_trans_allocate): Build a correct rhs for
the assignment of an unlimited polymorphic 'source'.
gcc/testsuite/
PR fortran/113363
* gfortran.dg/pr113363.f90: New test.
Diff:
---
gcc/fortran/trans-array.cc | 5 ++
gcc/fortran/trans-expr.cc | 34 --
gcc/fortran/trans-stmt.cc | 40
gcc/testsuite/gfortran.dg/pr113363.f90 | 86 ++
4 files changed, 151 insertions(+), 14 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 7ec33fb15986..c5b56f4e2735 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -5957,6 +5957,11 @@ gfc_array_init_size (tree descriptor, int rank, int
corank, tree * poffset,
tmp = gfc_conv_descriptor_dtype (descriptor);
gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type));
}
+ else if (expr3_desc && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr3_desc)))
+{
+ tmp = gfc_conv_descriptor_dtype (descriptor);
+ gfc_add_modify (pblock, tmp, gfc_conv_descriptor_dtype (expr3_desc));
+}
else
{
tmp = gfc_conv_descriptor_dtype (descriptor);
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 4590aa6edb44..e315e2d33701 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -8245,8 +8245,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
call the finalization function of the temporary. Note that the
nullification of allocatable components needed by the result
is done in gfc_trans_assignment_1. */
- if (expr && ((gfc_is_class_array_function (expr)
- && se->ss && se->ss->loop)
+ if (expr && (gfc_is_class_array_function (expr)
|| gfc_is_alloc_class_scalar_function (expr))
&& se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
&& expr->must_finalize)
@@ -12028,18 +12027,25 @@ trans_class_assignment (stmtblock_t *block, gfc_expr
*lhs, gfc_expr *rhs,
/* Reallocate if dynamic types are different. */
gfc_init_block (&re_alloc);
- tmp = fold_convert (pvoid_type_node, class_han);
- re = build_call_expr_loc (input_location,
- builtin_decl_explicit (BUILT_IN_REALLOC), 2,
- tmp, size);
- re = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (tmp), tmp,
- re);
- tmp = fold_build2_loc (input_location, NE_EXPR,
-logical_type_node, rhs_vptr, old_vptr);
- re = fold_build3_loc (input_location, COND_EXPR, void_type_node,
- tmp, re, build_empty_stmt (input_location));
- gfc_add_expr_to_block (&re_alloc, re);
-
+ if (UNLIMITED_POLY (lhs) && rhs->ts.type == BT_CHARACTER)
+ {
+ gfc_add_expr_to_block (&re_alloc, gfc_call_free (class_han));
+ gfc_allocate_using_malloc (&re_alloc, class_han, size, NULL_TREE);
+ }
+ else
+ {
+ tmp = fold_convert (pvoid_type_node, class_han);
+ re = build_call_expr_loc (input_location,
+ builtin_decl_explicit (BUILT_IN_REALLOC),
+ 2, tmp, size);
+ re = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (tmp),
+ tmp, re);
+ tmp = fold_build2_loc (input_location, NE_EXPR,
+logical_type_node, rhs_vptr, old_vptr);
+ re = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+ tmp, re, build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&re_alloc, re);
+ }
tree realloc_expr = lhs->ts.type == BT_CLASS ?
gfc_finish_block (&re_alloc) :
build_empty_stmt (input_location);
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index d355009fa5e4..9b497d6bdc60 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/for
[gcc r15-633] Fortran: Fix select type regression due to r14-9489 [PR114874]
https://gcc.gnu.org/g:5f5074fe7aaf9524defb265299a985eecba7f914
commit r15-633-g5f5074fe7aaf9524defb265299a985eecba7f914
Author: Paul Thomas
Date: Fri May 17 15:19:26 2024 +0100
Fortran: Fix select type regression due to r14-9489 [PR114874]
2024-05-17 Paul Thomas
gcc/fortran
PR fortran/114874
* gfortran.h: Add 'assoc_name_inferred' to gfc_namespace.
* match.cc (gfc_match_select_type): Set 'assoc_name_inferred'
in select type namespace if the selector has inferred type.
* primary.cc (gfc_match_varspec): If a select type temporary
is apparently scalar and a left parenthesis has been detected,
check the current namespace has 'assoc_name_inferred' set. If
so, set inferred_type.
* resolve.cc (resolve_variable): If the namespace of a select
type temporary is marked with 'assoc_name_inferred' call
gfc_fixup_inferred_type_refs to ensure references are OK.
(gfc_fixup_inferred_type_refs): Catch invalid array refs..
gcc/testsuite/
PR fortran/114874
* gfortran.dg/pr114874_1.f90: New test for valid code.
* gfortran.dg/pr114874_2.f90: New test for invalid code.
Diff:
---
gcc/fortran/gfortran.h | 4 +++
gcc/fortran/match.cc | 21 +
gcc/fortran/primary.cc | 10 +++---
gcc/fortran/resolve.cc | 17 +++---
gcc/testsuite/gfortran.dg/pr114874_1.f90 | 32 +++
gcc/testsuite/gfortran.dg/pr114874_2.f90 | 53
6 files changed, 128 insertions(+), 9 deletions(-)
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index a7a0fdba3dd3..de1a7cd09352 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2242,6 +2242,10 @@ typedef struct gfc_namespace
/* Set when resolve_types has been called for this namespace. */
unsigned types_resolved:1;
+ /* Set if the associate_name in a select type statement is an
+ inferred type. */
+ unsigned assoc_name_inferred:1;
+
/* Set to 1 if code has been generated for this namespace. */
unsigned translated:1;
diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc
index 4539c9bb1344..1851a8f94a54 100644
--- a/gcc/fortran/match.cc
+++ b/gcc/fortran/match.cc
@@ -6721,6 +6721,27 @@ gfc_match_select_type (void)
goto cleanup;
}
+ /* Select type namespaces are not filled until resolution. Therefore, the
+ namespace must be marked as having an inferred type associate name if
+ either expr1 is an inferred type variable or expr2 is. In the latter
+ case, as well as the symbol being marked as inferred type, it might be
+ that it has not been detected to be so. In this case the target has
+ unknown type. Once the namespace is marked, the fixups in resolution can
+ be triggered. */
+ if (!expr2
+ && expr1->symtree->n.sym->assoc
+ && expr1->symtree->n.sym->assoc->inferred_type)
+gfc_current_ns->assoc_name_inferred = 1;
+ else if (expr2 && expr2->expr_type == EXPR_VARIABLE
+ && expr2->symtree->n.sym->assoc)
+{
+ if (expr2->symtree->n.sym->assoc->inferred_type)
+ gfc_current_ns->assoc_name_inferred = 1;
+ else if (expr2->symtree->n.sym->assoc->target
+ && expr2->symtree->n.sym->assoc->target->ts.type == BT_UNKNOWN)
+ gfc_current_ns->assoc_name_inferred = 1;
+}
+
new_st.op = EXEC_SELECT_TYPE;
new_st.expr1 = expr1;
new_st.expr2 = expr2;
diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index 8e7833769a8f..76f6bcb8a789 100644
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
@@ -2113,13 +2113,13 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag,
bool sub_flag,
inferred_type = IS_INFERRED_TYPE (primary);
- /* SELECT TYPE and SELECT RANK temporaries within an ASSOCIATE block, whose
- selector has not been parsed, can generate errors with array and component
- refs.. Use 'inferred_type' as a flag to suppress these errors. */
+ /* SELECT TYPE temporaries within an ASSOCIATE block, whose selector has not
+ been parsed, can generate errors with array refs.. The SELECT TYPE
+ namespace is marked with 'assoc_name_inferred'. During resolution, this is
+ detected and gfc_fixup_inferred_type_refs is called. */
if (!inferred_type
- && (gfc_peek_ascii_char () == '(' && !sym->attr.dimension)
- && !sym->attr.codimension
&& sym->attr.select_type_temporary
+ && sym->ns->assoc_name_inferred
&& !sym->attr.select_rank_temporary)
inferred_type = true;
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 4368627041ed..d7a0856fcca1 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -5888,6 +5888,9 @@ resolve_variable (gfc_expr *e)
if (e->expr_type == EXPR_CONSTANT)
return true;
}
+ el
[gcc r14-10216] Fortran: Fix select type regression due to r14-9489 [PR114874]
https://gcc.gnu.org/g:c887341432bb71cf5540d54955ad7265b0aaca77
commit r14-10216-gc887341432bb71cf5540d54955ad7265b0aaca77
Author: Paul Thomas
Date: Fri May 17 15:19:26 2024 +0100
Fortran: Fix select type regression due to r14-9489 [PR114874]
2024-05-17 Paul Thomas
gcc/fortran
PR fortran/114874
* gfortran.h: Add 'assoc_name_inferred' to gfc_namespace.
* match.cc (gfc_match_select_type): Set 'assoc_name_inferred'
in select type namespace if the selector has inferred type.
* primary.cc (gfc_match_varspec): If a select type temporary
is apparently scalar and a left parenthesis has been detected,
check the current namespace has 'assoc_name_inferred' set. If
so, set inferred_type.
* resolve.cc (resolve_variable): If the namespace of a select
type temporary is marked with 'assoc_name_inferred' call
gfc_fixup_inferred_type_refs to ensure references are OK.
(gfc_fixup_inferred_type_refs): Catch invalid array refs..
gcc/testsuite/
PR fortran/114874
* gfortran.dg/pr114874_1.f90: New test for valid code.
* gfortran.dg/pr114874_2.f90: New test for invalid code.
(cherry picked from commit 5f5074fe7aaf9524defb265299a985eecba7f914)
Diff:
---
gcc/fortran/gfortran.h | 4 +++
gcc/fortran/match.cc | 21 +
gcc/fortran/primary.cc | 10 +++---
gcc/fortran/resolve.cc | 17 +++---
gcc/testsuite/gfortran.dg/pr114874_1.f90 | 32 +++
gcc/testsuite/gfortran.dg/pr114874_2.f90 | 53
6 files changed, 128 insertions(+), 9 deletions(-)
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 58505446bac5..de3d9e25911b 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2241,6 +2241,10 @@ typedef struct gfc_namespace
/* Set when resolve_types has been called for this namespace. */
unsigned types_resolved:1;
+ /* Set if the associate_name in a select type statement is an
+ inferred type. */
+ unsigned assoc_name_inferred:1;
+
/* Set to 1 if code has been generated for this namespace. */
unsigned translated:1;
diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc
index 4539c9bb1344..1851a8f94a54 100644
--- a/gcc/fortran/match.cc
+++ b/gcc/fortran/match.cc
@@ -6721,6 +6721,27 @@ gfc_match_select_type (void)
goto cleanup;
}
+ /* Select type namespaces are not filled until resolution. Therefore, the
+ namespace must be marked as having an inferred type associate name if
+ either expr1 is an inferred type variable or expr2 is. In the latter
+ case, as well as the symbol being marked as inferred type, it might be
+ that it has not been detected to be so. In this case the target has
+ unknown type. Once the namespace is marked, the fixups in resolution can
+ be triggered. */
+ if (!expr2
+ && expr1->symtree->n.sym->assoc
+ && expr1->symtree->n.sym->assoc->inferred_type)
+gfc_current_ns->assoc_name_inferred = 1;
+ else if (expr2 && expr2->expr_type == EXPR_VARIABLE
+ && expr2->symtree->n.sym->assoc)
+{
+ if (expr2->symtree->n.sym->assoc->inferred_type)
+ gfc_current_ns->assoc_name_inferred = 1;
+ else if (expr2->symtree->n.sym->assoc->target
+ && expr2->symtree->n.sym->assoc->target->ts.type == BT_UNKNOWN)
+ gfc_current_ns->assoc_name_inferred = 1;
+}
+
new_st.op = EXEC_SELECT_TYPE;
new_st.expr1 = expr1;
new_st.expr2 = expr2;
diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index 606e84432be6..c4821030ebb5 100644
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
@@ -2113,13 +2113,13 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag,
bool sub_flag,
inferred_type = IS_INFERRED_TYPE (primary);
- /* SELECT TYPE and SELECT RANK temporaries within an ASSOCIATE block, whose
- selector has not been parsed, can generate errors with array and component
- refs.. Use 'inferred_type' as a flag to suppress these errors. */
+ /* SELECT TYPE temporaries within an ASSOCIATE block, whose selector has not
+ been parsed, can generate errors with array refs.. The SELECT TYPE
+ namespace is marked with 'assoc_name_inferred'. During resolution, this is
+ detected and gfc_fixup_inferred_type_refs is called. */
if (!inferred_type
- && (gfc_peek_ascii_char () == '(' && !sym->attr.dimension)
- && !sym->attr.codimension
&& sym->attr.select_type_temporary
+ && sym->ns->assoc_name_inferred
&& !sym->attr.select_rank_temporary)
inferred_type = true;
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 4368627041ed..d7a0856fcca1 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -5888,6 +5888,9 @@ resolve_variable (gfc_expr
[gcc r15-3123] Revert "Fortran: Fix class transformational intrinsic calls [PR102689]"
https://gcc.gnu.org/g:f9f599a44e3156a5f5679adc048ec6ff2f44cc0e
commit r15-3123-gf9f599a44e3156a5f5679adc048ec6ff2f44cc0e
Author: Paul Thomas
Date: Fri Aug 23 13:16:53 2024 +0100
Revert "Fortran: Fix class transformational intrinsic calls [PR102689]"
This reverts commit 4cb07a38233aadb4b389a6e5236c95f52241b6e0.
Diff:
---
gcc/fortran/trans-array.cc | 146 +++
gcc/fortran/trans-expr.cc | 57 +-
.../gfortran.dg/class_transformational_1.f90 | 204 -
.../gfortran.dg/class_transformational_2.f90 | 103 ---
4 files changed, 35 insertions(+), 475 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index ea5fff2e0c29..8c35926436d7 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1301,28 +1301,23 @@ get_array_ref_dim_for_loop_dim (gfc_ss *ss, int
loop_dim)
is a class expression. */
static tree
-get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype,
- gfc_ss **fcnss)
+get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype)
{
- gfc_ss *loop_ss = ss->loop->ss;
gfc_ss *lhs_ss;
gfc_ss *rhs_ss;
- gfc_ss *fcn_ss = NULL;
tree tmp;
tree tmp2;
tree vptr;
- tree class_expr = NULL_TREE;
+ tree rhs_class_expr = NULL_TREE;
tree lhs_class_expr = NULL_TREE;
bool unlimited_rhs = false;
bool unlimited_lhs = false;
bool rhs_function = false;
- bool unlimited_arg1 = false;
gfc_symbol *vtab;
- tree cntnr = NULL_TREE;
/* The second element in the loop chain contains the source for the
- class temporary created in gfc_trans_create_temp_array. */
- rhs_ss = loop_ss->loop_chain;
+ temporary; ie. the rhs of the assignment. */
+ rhs_ss = ss->loop->ss->loop_chain;
if (rhs_ss != gfc_ss_terminator
&& rhs_ss->info
@@ -1331,58 +1326,28 @@ get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss,
tree *eltype,
&& rhs_ss->info->data.array.descriptor)
{
if (rhs_ss->info->expr->expr_type != EXPR_VARIABLE)
- class_expr
+ rhs_class_expr
= gfc_get_class_from_expr (rhs_ss->info->data.array.descriptor);
else
- class_expr = gfc_get_class_from_gfc_expr (rhs_ss->info->expr);
+ rhs_class_expr = gfc_get_class_from_gfc_expr (rhs_ss->info->expr);
unlimited_rhs = UNLIMITED_POLY (rhs_ss->info->expr);
if (rhs_ss->info->expr->expr_type == EXPR_FUNCTION)
rhs_function = true;
}
- /* Usually, ss points to the function. When the function call is an actual
- argument, it is instead rhs_ss because the ss chain is shifted by one. */
- *fcnss = fcn_ss = rhs_function ? rhs_ss : ss;
-
- /* If this is a transformational function with a class result, the info
- class_container field points to the class container of arg1. */
- if (class_expr != NULL_TREE
- && fcn_ss->info && fcn_ss->info->expr
- && fcn_ss->info->expr->expr_type == EXPR_FUNCTION
- && fcn_ss->info->expr->value.function.isym
- && fcn_ss->info->expr->value.function.isym->transformational)
-{
- cntnr = ss->info->class_container;
- unlimited_arg1
- = UNLIMITED_POLY (fcn_ss->info->expr->value.function.actual->expr);
-}
-
/* For an assignment the lhs is the next element in the loop chain.
If we have a class rhs, this had better be a class variable
- expression! Otherwise, the class container from arg1 can be used
- to set the vptr and len fields of the result class container. */
+ expression! */
lhs_ss = rhs_ss->loop_chain;
- if (lhs_ss && lhs_ss != gfc_ss_terminator
- && lhs_ss->info && lhs_ss->info->expr
+ if (lhs_ss != gfc_ss_terminator
+ && lhs_ss->info
+ && lhs_ss->info->expr
&& lhs_ss->info->expr->expr_type ==EXPR_VARIABLE
&& lhs_ss->info->expr->ts.type == BT_CLASS)
{
tmp = lhs_ss->info->data.array.descriptor;
unlimited_lhs = UNLIMITED_POLY (rhs_ss->info->expr);
}
- else if (cntnr != NULL_TREE)
-{
- tmp = gfc_class_vptr_get (class_expr);
- gfc_add_modify (pre, tmp, fold_convert (TREE_TYPE (tmp),
- gfc_class_vptr_get (cntnr)));
- if (unlimited_rhs)
- {
- tmp = gfc_class_len_get (class_expr);
- if (unlimited_arg1)
- gfc_add_modify (pre, tmp, gfc_class_len_get (cntnr));
- }
- tmp = NULL_TREE;
-}
else
tmp = NULL_TREE;
@@ -1390,33 +1355,35 @@ get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss,
tree *eltype,
if (tmp != NULL_TREE && lhs_ss->loop_chain == gfc_ss_terminator)
lhs_class_expr = gfc_get_class_from_expr (tmp);
else
-return class_expr;
+return rhs_class_expr;
gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (lhs_class_expr)));
/* Set the lhs vptr and, if necessary, the _len field. */
- if (class_expr)
+ if (rhs_class_expr)
{
/*
[gcc r14-10390] Fortran: Unlimited polymorphic intrinsic function arguments [PR84006]
https://gcc.gnu.org/g:c36acfea1aea17ff8df8994657c8bf9e3ccde6ca
commit r14-10390-gc36acfea1aea17ff8df8994657c8bf9e3ccde6ca
Author: Paul Thomas
Date: Sun May 12 06:59:45 2024 +0100
Fortran: Unlimited polymorphic intrinsic function arguments [PR84006]
2024-05-12 Paul Thomas
gcc/fortran
PR fortran/84006
PR fortran/100027
PR fortran/98534
* iresolve.cc (gfc_resolve_transfer): Emit a TODO error for
unlimited polymorphic mold.
* trans-expr.cc (gfc_resize_class_size_with_len): Use the fold
even if a block is not available in which to fix the result.
(trans_class_assignment): Enable correct assignment of
character expressions to unlimited polymorphic variables using
lhs _len field and rse string_length.
* trans-intrinsic.cc (gfc_conv_intrinsic_storage_size): Extract
the class expression so that the unlimited polymorphic class
expression can be used in gfc_resize_class_size_with_len to
obtain the storage size for character payloads. Guard the use
of GFC_DECL_SAVED_DESCRIPTOR by testing for DECL_LANG_SPECIFIC
to prevent the ICE. Also, invert the order to use the class
expression extracted from the argument.
(gfc_conv_intrinsic_transfer): In same way as 'storage_size',
use the _len field to obtaining the correct length for arg 1.
Add a branch for the element size in bytes of class expressions
with provision to make use of the unlimited polymorphic _len
field. Again, the class references are explicitly identified.
'mold_expr' was already declared. Use it instead of 'arg'. Do
not fix 'dest_word_len' for deferred character sources because
reallocation on assign makes use of it before it is assigned.
gcc/testsuite/
PR fortran/84006
PR fortran/100027
* gfortran.dg/storage_size_7.f90: New test.
PR fortran/98534
* gfortran.dg/transfer_class_4.f90: New test.
(cherry picked from commit b9294757f82aae8de6d98c122cd4e3b98f685217)
Diff:
---
gcc/fortran/iresolve.cc| 4 ++
gcc/fortran/trans-expr.cc | 15 -
gcc/fortran/trans-intrinsic.cc | 80 +-
gcc/testsuite/gfortran.dg/storage_size_7.f90 | 91 ++
gcc/testsuite/gfortran.dg/transfer_class_4.f90 | 87
5 files changed, 257 insertions(+), 20 deletions(-)
diff --git a/gcc/fortran/iresolve.cc b/gcc/fortran/iresolve.cc
index c961cdbc2df4..c63a4a8d38cd 100644
--- a/gcc/fortran/iresolve.cc
+++ b/gcc/fortran/iresolve.cc
@@ -3025,6 +3025,10 @@ gfc_resolve_transfer (gfc_expr *f, gfc_expr *source
ATTRIBUTE_UNUSED,
}
}
+ if (UNLIMITED_POLY (mold))
+gfc_error ("TODO: unlimited polymorphic MOLD in TRANSFER intrinsic at %L",
+ &mold->where);
+
f->ts = mold->ts;
if (size == NULL && mold->rank == 0)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index d5fd6e399965..114e7629182a 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -317,6 +317,8 @@ gfc_resize_class_size_with_len (stmtblock_t * block, tree
class_expr, tree size)
size = gfc_evaluate_now (size, block);
tmp = gfc_evaluate_now (fold_convert (type , tmp), block);
}
+ else
+ tmp = fold_convert (type , tmp);
tmp2 = fold_build2_loc (input_location, MULT_EXPR,
type, size, tmp);
tmp = fold_build2_loc (input_location, GT_EXPR,
@@ -11998,15 +12000,24 @@ trans_class_assignment (stmtblock_t *block, gfc_expr
*lhs, gfc_expr *rhs,
/* 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)
+ if (UNLIMITED_POLY (rhs))
{
- tree len = trans_get_upoly_len (block, rhs);
+ tree len;
+ if (rhs->expr_type == EXPR_VARIABLE)
+ len = trans_get_upoly_len (block, rhs);
+ else
+ len = gfc_class_len_get (tmp);
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));
}
+ else if (rhs->ts.type == BT_CHARACTER && rse->string_length)
+ size = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_charlen_type_node, size,
+ rse->string_length);
+
tmp = lse->expr;
class_han = GFC
[gcc r13-8897] Fortran: Unlimited polymorphic intrinsic function arguments [PR84006]
https://gcc.gnu.org/g:b1429ddd7f20a5c88b65d8de38d64c98c4820782
commit r13-8897-gb1429ddd7f20a5c88b65d8de38d64c98c4820782
Author: Paul Thomas
Date: Sun May 12 06:59:45 2024 +0100
Fortran: Unlimited polymorphic intrinsic function arguments [PR84006]
2024-05-12 Paul Thomas
gcc/fortran
PR fortran/84006
PR fortran/100027
PR fortran/98534
* iresolve.cc (gfc_resolve_transfer): Emit a TODO error for
unlimited polymorphic mold.
* trans-expr.cc (gfc_resize_class_size_with_len): Use the fold
even if a block is not available in which to fix the result.
(trans_class_assignment): Enable correct assignment of
character expressions to unlimited polymorphic variables using
lhs _len field and rse string_length.
* trans-intrinsic.cc (gfc_conv_intrinsic_storage_size): Extract
the class expression so that the unlimited polymorphic class
expression can be used in gfc_resize_class_size_with_len to
obtain the storage size for character payloads. Guard the use
of GFC_DECL_SAVED_DESCRIPTOR by testing for DECL_LANG_SPECIFIC
to prevent the ICE. Also, invert the order to use the class
expression extracted from the argument.
(gfc_conv_intrinsic_transfer): In same way as 'storage_size',
use the _len field to obtaining the correct length for arg 1.
Add a branch for the element size in bytes of class expressions
with provision to make use of the unlimited polymorphic _len
field. Again, the class references are explicitly identified.
'mold_expr' was already declared. Use it instead of 'arg'. Do
not fix 'dest_word_len' for deferred character sources because
reallocation on assign makes use of it before it is assigned.
gcc/testsuite/
PR fortran/84006
PR fortran/100027
* gfortran.dg/storage_size_7.f90: New test.
PR fortran/98534
* gfortran.dg/transfer_class_4.f90: New test.
(cherry picked from commit b9294757f82aae8de6d98c122cd4e3b98f685217)
Diff:
---
gcc/fortran/iresolve.cc| 4 ++
gcc/fortran/trans-expr.cc | 15 -
gcc/fortran/trans-intrinsic.cc | 80 +-
gcc/testsuite/gfortran.dg/storage_size_7.f90 | 91 ++
gcc/testsuite/gfortran.dg/transfer_class_4.f90 | 87
5 files changed, 257 insertions(+), 20 deletions(-)
diff --git a/gcc/fortran/iresolve.cc b/gcc/fortran/iresolve.cc
index 8acad60a02be..108c9a35949d 100644
--- a/gcc/fortran/iresolve.cc
+++ b/gcc/fortran/iresolve.cc
@@ -3017,6 +3017,10 @@ gfc_resolve_transfer (gfc_expr *f, gfc_expr *source
ATTRIBUTE_UNUSED,
}
}
+ if (UNLIMITED_POLY (mold))
+gfc_error ("TODO: unlimited polymorphic MOLD in TRANSFER intrinsic at %L",
+ &mold->where);
+
f->ts = mold->ts;
if (size == NULL && mold->rank == 0)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 5946aa813917..6b75c147a350 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -317,6 +317,8 @@ gfc_resize_class_size_with_len (stmtblock_t * block, tree
class_expr, tree size)
size = gfc_evaluate_now (size, block);
tmp = gfc_evaluate_now (fold_convert (type , tmp), block);
}
+ else
+ tmp = fold_convert (type , tmp);
tmp2 = fold_build2_loc (input_location, MULT_EXPR,
type, size, tmp);
tmp = fold_build2_loc (input_location, GT_EXPR,
@@ -11671,15 +11673,24 @@ trans_class_assignment (stmtblock_t *block, gfc_expr
*lhs, gfc_expr *rhs,
/* 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)
+ if (UNLIMITED_POLY (rhs))
{
- tree len = trans_get_upoly_len (block, rhs);
+ tree len;
+ if (rhs->expr_type == EXPR_VARIABLE)
+ len = trans_get_upoly_len (block, rhs);
+ else
+ len = gfc_class_len_get (tmp);
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));
}
+ else if (rhs->ts.type == BT_CHARACTER && rse->string_length)
+ size = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_charlen_type_node, size,
+ rse->string_length);
+
tmp = lse->expr;
class_han = GFC_
[gcc r14-10410] Fortran: Fix ICEs due to comp calls in initialization exprs [PR103312]
https://gcc.gnu.org/g:29b2e1cdb6f182d3f519a4b96cdc98032a10f81d
commit r14-10410-g29b2e1cdb6f182d3f519a4b96cdc98032a10f81d
Author: Paul Thomas
Date: Thu May 23 07:59:46 2024 +0100
Fortran: Fix ICEs due to comp calls in initialization exprs [PR103312]
2024-05-23 Paul Thomas
gcc/fortran
PR fortran/103312
* dependency.cc (gfc_dep_compare_expr): Handle component call
expressions. Return -2 as default and return 0 if compared with
a function expression that is from an interface body and has
the same name.
* expr.cc (gfc_reduce_init_expr): If the expression is a comp
call do not attempt to reduce, defer to resolution and return
false.
* trans-types.cc (gfc_get_dtype_rank_type,
gfc_get_nodesc_array_type): Fix whitespace.
gcc/testsuite/
PR fortran/103312
* gfortran.dg/pr103312.f90: New test.
(cherry picked from commit 2ce90517ed75c4af9fc0616f2670cf6dfcfa8a91)
Diff:
---
gcc/fortran/dependency.cc | 32 +
gcc/fortran/expr.cc| 5 ++
gcc/fortran/trans-types.cc | 4 +-
gcc/testsuite/gfortran.dg/pr103312.f90 | 87 ++
4 files changed, 126 insertions(+), 2 deletions(-)
diff --git a/gcc/fortran/dependency.cc b/gcc/fortran/dependency.cc
index fb4d94de6413..bafe8cbc5bc3 100644
--- a/gcc/fortran/dependency.cc
+++ b/gcc/fortran/dependency.cc
@@ -440,6 +440,38 @@ gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2)
return mpz_sgn (e2->value.op.op2->value.integer);
}
+
+ if (e1->expr_type == EXPR_COMPCALL)
+{
+ /* This will have emerged from interface.cc(gfc_check_typebound_override)
+via gfc_check_result_characteristics. It is possible that other
+variants exist that are 'equal' but play it safe for now by setting
+the relationship as 'indeterminate'. */
+ if (e2->expr_type == EXPR_FUNCTION && e2->ref)
+ {
+ gfc_ref *ref = e2->ref;
+ gfc_symbol *s = NULL;
+
+ if (e1->value.compcall.tbp->u.specific)
+ s = e1->value.compcall.tbp->u.specific->n.sym;
+
+ /* Check if the proc ptr points to an interface declaration and the
+names are the same; ie. the overriden proc. of an abstract type.
+The checking of the arguments will already have been done. */
+ for (; ref && s; ref = ref->next)
+ if (!ref->next && ref->type == REF_COMPONENT
+ && ref->u.c.component->attr.proc_pointer
+ && ref->u.c.component->ts.interface
+ && ref->u.c.component->ts.interface->attr.if_source
+ == IFSRC_IFBODY
+ && !strcmp (s->name, ref->u.c.component->name))
+ return 0;
+ }
+
+ /* Assume as default that TKR checking is sufficient. */
+ return -2;
+ }
+
if (e1->expr_type != e2->expr_type)
return -3;
diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc
index 50e32a7a3b75..9ce0b950b617 100644
--- a/gcc/fortran/expr.cc
+++ b/gcc/fortran/expr.cc
@@ -3201,6 +3201,11 @@ gfc_reduce_init_expr (gfc_expr *expr)
{
bool t;
+ /* It is far too early to resolve a class compcall. Punt to resolution. */
+ if (expr && expr->expr_type == EXPR_COMPCALL
+ && expr->symtree->n.sym->ts.type == BT_CLASS)
+return false;
+
gfc_init_expr_flag = true;
t = gfc_resolve_expr (expr);
if (t)
diff --git a/gcc/fortran/trans-types.cc b/gcc/fortran/trans-types.cc
index 676014e9b984..8466c595e065 100644
--- a/gcc/fortran/trans-types.cc
+++ b/gcc/fortran/trans-types.cc
@@ -1591,7 +1591,7 @@ gfc_get_dtype_rank_type (int rank, tree etype)
size = size_in_bytes (etype);
break;
}
-
+
gcc_assert (size);
STRIP_NOPS (size);
@@ -1740,7 +1740,7 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec *
as, gfc_packed packed,
tmp = gfc_conv_mpz_to_tree (expr->value.integer,
gfc_index_integer_kind);
else
- tmp = NULL_TREE;
+ tmp = NULL_TREE;
GFC_TYPE_ARRAY_LBOUND (type, n) = tmp;
expr = as->upper[n];
diff --git a/gcc/testsuite/gfortran.dg/pr103312.f90
b/gcc/testsuite/gfortran.dg/pr103312.f90
new file mode 100644
index ..deacc70bf5df
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr103312.f90
@@ -0,0 +1,87 @@
+! { dg-do run }
+!
+! Test the fix for pr103312, in which the use of a component call in
+! initialization expressions, eg. character(this%size()), caused ICEs.
+!
+! Contributed by Arseny Solokha
+!
+module example
+
+ type, abstract :: foo
+integer :: i
+ contains
+procedure(foo_size), deferred :: size
+procedure(foo_func), deferred :: func
+ end type
+
+ interface
+function foo_func (this) result (string)
+ import :: foo
+ class(foo) :: this
+ character(
[gcc r13-8907] Fortran: Fix ICEs due to comp calls in initialization exprs [PR103312]
https://gcc.gnu.org/g:1b22831d3c74a1b3e72dab840e2818e495ecd567
commit r13-8907-g1b22831d3c74a1b3e72dab840e2818e495ecd567
Author: Paul Thomas
Date: Thu May 23 07:59:46 2024 +0100
Fortran: Fix ICEs due to comp calls in initialization exprs [PR103312]
2024-05-23 Paul Thomas
gcc/fortran
PR fortran/103312
* dependency.cc (gfc_dep_compare_expr): Handle component call
expressions. Return -2 as default and return 0 if compared with
a function expression that is from an interface body and has
the same name.
* expr.cc (gfc_reduce_init_expr): If the expression is a comp
call do not attempt to reduce, defer to resolution and return
false.
* trans-types.cc (gfc_get_dtype_rank_type,
gfc_get_nodesc_array_type): Fix whitespace.
gcc/testsuite/
PR fortran/103312
* gfortran.dg/pr103312.f90: New test.
(cherry picked from commit 2ce90517ed75c4af9fc0616f2670cf6dfcfa8a91)
Diff:
---
gcc/fortran/dependency.cc | 32 +
gcc/fortran/expr.cc| 5 ++
gcc/fortran/trans-types.cc | 4 +-
gcc/testsuite/gfortran.dg/pr103312.f90 | 87 ++
4 files changed, 126 insertions(+), 2 deletions(-)
diff --git a/gcc/fortran/dependency.cc b/gcc/fortran/dependency.cc
index 9117825ee6e8..f928099e9e2f 100644
--- a/gcc/fortran/dependency.cc
+++ b/gcc/fortran/dependency.cc
@@ -440,6 +440,38 @@ gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2)
return mpz_sgn (e2->value.op.op2->value.integer);
}
+
+ if (e1->expr_type == EXPR_COMPCALL)
+{
+ /* This will have emerged from interface.cc(gfc_check_typebound_override)
+via gfc_check_result_characteristics. It is possible that other
+variants exist that are 'equal' but play it safe for now by setting
+the relationship as 'indeterminate'. */
+ if (e2->expr_type == EXPR_FUNCTION && e2->ref)
+ {
+ gfc_ref *ref = e2->ref;
+ gfc_symbol *s = NULL;
+
+ if (e1->value.compcall.tbp->u.specific)
+ s = e1->value.compcall.tbp->u.specific->n.sym;
+
+ /* Check if the proc ptr points to an interface declaration and the
+names are the same; ie. the overriden proc. of an abstract type.
+The checking of the arguments will already have been done. */
+ for (; ref && s; ref = ref->next)
+ if (!ref->next && ref->type == REF_COMPONENT
+ && ref->u.c.component->attr.proc_pointer
+ && ref->u.c.component->ts.interface
+ && ref->u.c.component->ts.interface->attr.if_source
+ == IFSRC_IFBODY
+ && !strcmp (s->name, ref->u.c.component->name))
+ return 0;
+ }
+
+ /* Assume as default that TKR checking is sufficient. */
+ return -2;
+ }
+
if (e1->expr_type != e2->expr_type)
return -3;
diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc
index 4a9b29c7e9d5..90d2daa08642 100644
--- a/gcc/fortran/expr.cc
+++ b/gcc/fortran/expr.cc
@@ -3188,6 +3188,11 @@ gfc_reduce_init_expr (gfc_expr *expr)
{
bool t;
+ /* It is far too early to resolve a class compcall. Punt to resolution. */
+ if (expr && expr->expr_type == EXPR_COMPCALL
+ && expr->symtree->n.sym->ts.type == BT_CLASS)
+return false;
+
gfc_init_expr_flag = true;
t = gfc_resolve_expr (expr);
if (t)
diff --git a/gcc/fortran/trans-types.cc b/gcc/fortran/trans-types.cc
index b2a3000da1fe..0c59ab3f5b57 100644
--- a/gcc/fortran/trans-types.cc
+++ b/gcc/fortran/trans-types.cc
@@ -1591,7 +1591,7 @@ gfc_get_dtype_rank_type (int rank, tree etype)
size = size_in_bytes (etype);
break;
}
-
+
gcc_assert (size);
STRIP_NOPS (size);
@@ -1736,7 +1736,7 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec *
as, gfc_packed packed,
tmp = gfc_conv_mpz_to_tree (expr->value.integer,
gfc_index_integer_kind);
else
- tmp = NULL_TREE;
+ tmp = NULL_TREE;
GFC_TYPE_ARRAY_LBOUND (type, n) = tmp;
expr = as->upper[n];
diff --git a/gcc/testsuite/gfortran.dg/pr103312.f90
b/gcc/testsuite/gfortran.dg/pr103312.f90
new file mode 100644
index ..deacc70bf5df
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr103312.f90
@@ -0,0 +1,87 @@
+! { dg-do run }
+!
+! Test the fix for pr103312, in which the use of a component call in
+! initialization expressions, eg. character(this%size()), caused ICEs.
+!
+! Contributed by Arseny Solokha
+!
+module example
+
+ type, abstract :: foo
+integer :: i
+ contains
+procedure(foo_size), deferred :: size
+procedure(foo_func), deferred :: func
+ end type
+
+ interface
+function foo_func (this) result (string)
+ import :: foo
+ class(foo) :: this
+ character(t
[gcc r15-2072] Fortran: Simplify len_trim with array ref and fix mapping bug[PR84868].
https://gcc.gnu.org/g:9f966b6a8ff0244dd6f8bf36d876799d5f9bbaee
commit r15-2072-g9f966b6a8ff0244dd6f8bf36d876799d5f9bbaee
Author: Paul Thomas
Date: Tue Jul 16 15:56:44 2024 +0100
Fortran: Simplify len_trim with array ref and fix mapping bug[PR84868].
2024-07-16 Paul Thomas
gcc/fortran
PR fortran/84868
* simplify.cc (gfc_simplify_len_trim): If the argument is an
element of a parameter array, simplify all the elements and
build a new parameter array to hold the result, after checking
that it doesn't already exist.
* trans-expr.cc (gfc_get_interface_mapping_array) if a string
length is available, use it for the typespec.
(gfc_add_interface_mapping): Supply the se string length.
gcc/testsuite/
PR fortran/84868
* gfortran.dg/pr84868.f90: New test.
Diff:
---
gcc/fortran/simplify.cc | 75 +++
gcc/fortran/trans-expr.cc | 18 +---
gcc/testsuite/gfortran.dg/pr84868.f90 | 84 +++
3 files changed, 171 insertions(+), 6 deletions(-)
diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc
index 7a5d31c01a65..60b717fea9a7 100644
--- a/gcc/fortran/simplify.cc
+++ b/gcc/fortran/simplify.cc
@@ -4637,6 +4637,81 @@ gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind)
if (k == -1)
return &gfc_bad_expr;
+ /* If the expression is either an array element or section, an array
+ parameter must be built so that the reference can be applied. Constant
+ references should have already been simplified away. All other cases
+ can proceed to translation, where kind conversion will occur silently. */
+ if (e->expr_type == EXPR_VARIABLE
+ && e->ts.type == BT_CHARACTER
+ && e->symtree->n.sym->attr.flavor == FL_PARAMETER
+ && e->ref && e->ref->type == REF_ARRAY
+ && e->ref->u.ar.type != AR_FULL
+ && e->symtree->n.sym->value)
+{
+ char name[2*GFC_MAX_SYMBOL_LEN + 12];
+ gfc_namespace *ns = e->symtree->n.sym->ns;
+ gfc_symtree *st;
+ gfc_expr *expr;
+ gfc_expr *p;
+ gfc_constructor *c;
+ int cnt = 0;
+
+ sprintf (name, "_len_trim_%s_%s", e->symtree->n.sym->name,
+ ns->proc_name->name);
+ st = gfc_find_symtree (ns->sym_root, name);
+ if (st)
+ goto already_built;
+
+ /* Recursively call this fcn to simplify the constructor elements. */
+ expr = gfc_copy_expr (e->symtree->n.sym->value);
+ expr->ts.type = BT_INTEGER;
+ expr->ts.kind = k;
+ expr->ts.u.cl = NULL;
+ c = gfc_constructor_first (expr->value.constructor);
+ for (; c; c = gfc_constructor_next (c))
+ {
+ if (c->iterator)
+ continue;
+
+ if (c->expr && c->expr->ts.type == BT_CHARACTER)
+ {
+ p = gfc_simplify_len_trim (c->expr, kind);
+ if (p == NULL)
+ goto clean_up;
+ gfc_replace_expr (c->expr, p);
+ cnt++;
+ }
+ }
+
+ if (cnt)
+ {
+ /* Build a new parameter to take the result. */
+ st = gfc_new_symtree (&ns->sym_root, name);
+ st->n.sym = gfc_new_symbol (st->name, ns);
+ st->n.sym->value = expr;
+ st->n.sym->ts = expr->ts;
+ st->n.sym->attr.dimension = 1;
+ st->n.sym->attr.save = SAVE_IMPLICIT;
+ st->n.sym->attr.flavor = FL_PARAMETER;
+ st->n.sym->as = gfc_copy_array_spec (e->symtree->n.sym->as);
+ gfc_set_sym_referenced (st->n.sym);
+ st->n.sym->refs++;
+ gfc_commit_symbol (st->n.sym);
+
+already_built:
+ /* Build a return expression. */
+ expr = gfc_copy_expr (e);
+ expr->ts = st->n.sym->ts;
+ expr->symtree = st;
+ gfc_expression_rank (expr);
+ return expr;
+ }
+
+clean_up:
+ gfc_free_expr (expr);
+ return NULL;
+}
+
if (e->expr_type != EXPR_CONSTANT)
return NULL;
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index fc23fb1a7ebf..410256742537 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -4474,12 +4474,15 @@ gfc_get_interface_mapping_charlen
(gfc_interface_mapping * mapping,
static tree
gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
-gfc_packed packed, tree data)
+gfc_packed packed, tree data, tree len)
{
tree type;
tree var;
- type = gfc_typenode_for_spec (&sym->ts);
+ if (len != NULL_TREE && (TREE_CONSTANT (len) || VAR_P (len)))
+type = gfc_get_character_type_len (sym->ts.kind, len);
+ else
+type = gfc_typenode_for_spec (&sym->ts);
type = gfc_get_nodesc_array_type (type, sym->as, packed,
!sym->attr.target && !sym->attr.pointer
&& !sym->attr.pro
[gcc r15-2135] Fortran: Suppress bogus used uninitialized warnings [PR108889].
https://gcc.gnu.org/g:c3aa339ea50f050caf7ed2e497f5499ec2d7b9cc
commit r15-2135-gc3aa339ea50f050caf7ed2e497f5499ec2d7b9cc
Author: Paul Thomas
Date: Thu Jul 18 08:51:35 2024 +0100
Fortran: Suppress bogus used uninitialized warnings [PR108889].
2024-07-18 Paul Thomas
gcc/fortran
PR fortran/108889
* gfortran.h: Add bit field 'allocated_in_scope' to gfc_symbol.
* trans-array.cc (gfc_array_allocate): Set 'allocated_in_scope'
after allocation if not a component reference.
(gfc_alloc_allocatable_for_assignment): If 'allocated_in_scope'
not set, not a component ref and not allocated, set the array
bounds and offset to give zero length in all dimensions. Then
set allocated_in_scope.
gcc/testsuite/
PR fortran/108889
* gfortran.dg/pr108889.f90: New test.
Diff:
---
gcc/fortran/gfortran.h | 4
gcc/fortran/trans-array.cc | 43 ++
gcc/testsuite/gfortran.dg/pr108889.f90 | 43 ++
3 files changed, 90 insertions(+)
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index ed1213a41cbb..c1fb896f587e 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -1950,6 +1950,10 @@ typedef struct gfc_symbol
/* Set if this should be passed by value, but is not a VALUE argument
according to the Fortran standard. */
unsigned pass_as_value:1;
+ /* Set if an allocatable array variable has been allocated in the current
+ scope. Used in the suppression of uninitialized warnings in reallocation
+ on assignment. */
+ unsigned allocated_in_scope:1;
/* Reference counter, used for memory management.
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 140d933e45d4..6d3b63b026c6 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -6580,6 +6580,8 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree
status, tree errmsg,
else
gfc_add_expr_to_block (&se->pre, set_descriptor);
+ expr->symtree->n.sym->allocated_in_scope = 1;
+
return true;
}
@@ -11060,6 +11062,8 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop,
stmtblock_t realloc_block;
stmtblock_t alloc_block;
stmtblock_t fblock;
+ stmtblock_t loop_pre_block;
+ gfc_ref *ref;
gfc_ss *rss;
gfc_ss *lss;
gfc_array_info *linfo;
@@ -11260,6 +11264,45 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop,
array1, build_int_cst (TREE_TYPE (array1), 0));
cond_null= gfc_evaluate_now (cond_null, &fblock);
+ /* If the data is null, set the descriptor bounds and offset. This suppresses
+ the maybe used uninitialized warning and forces the use of malloc because
+ the size is zero in all dimensions. Note that this block is only executed
+ if the lhs is unallocated and is only applied once in any namespace.
+ Component references are not subject to the warnings. */
+ for (ref = expr1->ref; ref; ref = ref->next)
+if (ref->type == REF_COMPONENT)
+ break;
+
+ if (!expr1->symtree->n.sym->allocated_in_scope && !ref)
+{
+ gfc_start_block (&loop_pre_block);
+ for (n = 0; n < expr1->rank; n++)
+ {
+ gfc_conv_descriptor_lbound_set (&loop_pre_block, desc,
+ gfc_rank_cst[n],
+ gfc_index_one_node);
+ gfc_conv_descriptor_ubound_set (&loop_pre_block, desc,
+ gfc_rank_cst[n],
+ gfc_index_zero_node);
+ gfc_conv_descriptor_stride_set (&loop_pre_block, desc,
+ gfc_rank_cst[n],
+ gfc_index_zero_node);
+ }
+
+ tmp = gfc_conv_descriptor_offset (desc);
+ gfc_add_modify (&loop_pre_block, tmp, gfc_index_zero_node);
+
+ tmp = fold_build2_loc (input_location, EQ_EXPR,
+logical_type_node, array1,
+build_int_cst (TREE_TYPE (array1), 0));
+ tmp = build3_v (COND_EXPR, tmp,
+ gfc_finish_block (&loop_pre_block),
+ build_empty_stmt (input_location));
+ gfc_prepend_expr_to_block (&loop->pre, tmp);
+
+ expr1->symtree->n.sym->allocated_in_scope = 1;
+}
+
tmp = build3_v (COND_EXPR, cond_null,
build1_v (GOTO_EXPR, jump_label1),
build_empty_stmt (input_location));
diff --git a/gcc/testsuite/gfortran.dg/pr108889.f90
b/gcc/testsuite/gfortran.dg/pr108889.f90
new file mode 100644
index ..7fd4e3882a48
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr108889.f90
@@ -0,0 +1,43 @@
+! { dg-do compile }
+! { dg-options "-Wall -fdump-tree-original" }
+!
+! Contributed by Tobias Burnus
+!
+program main
+ implicit none
+
+ type ::
[gcc r15-2157] libgomp: Remove bogus warnings from privatized-ref-2.f90.
https://gcc.gnu.org/g:8d6994f33a98a168151a57a3d21395b19196cd9d
commit r15-2157-g8d6994f33a98a168151a57a3d21395b19196cd9d
Author: Paul Thomas
Date: Fri Jul 19 16:58:33 2024 +0100
libgomp: Remove bogus warnings from privatized-ref-2.f90.
2024-07-19 Paul Thomas
libgomp/ChangeLog
* testsuite/libgomp.oacc-fortran/privatized-ref-2.f90: Cut
dg-note about 'a' and remove bogus warnings about its array
descriptor components being used uninitialized.
Diff:
---
libgomp/testsuite/libgomp.oacc-fortran/privatized-ref-2.f90 | 6 --
1 file changed, 6 deletions(-)
diff --git a/libgomp/testsuite/libgomp.oacc-fortran/privatized-ref-2.f90
b/libgomp/testsuite/libgomp.oacc-fortran/privatized-ref-2.f90
index 498ef70b63a4..8cf79a10e8d2 100644
--- a/libgomp/testsuite/libgomp.oacc-fortran/privatized-ref-2.f90
+++ b/libgomp/testsuite/libgomp.oacc-fortran/privatized-ref-2.f90
@@ -29,16 +29,10 @@ program main
implicit none (type, external)
integer :: j
integer, allocatable :: A(:)
- ! { dg-note {'a' declared here} {} { target *-*-* } .-1 }
character(len=:), allocatable :: my_str
character(len=15), allocatable :: my_str15
A = [(3*j, j=1, 10)]
- ! { dg-bogus {'a\.offset' is used uninitialized} {PR77504 etc.} { xfail
*-*-* } .-1 }
- ! { dg-bogus {'a\.dim\[0\]\.lbound' is used uninitialized} {PR77504 etc.} {
xfail *-*-* } .-2 }
- ! { dg-bogus {'a\.dim\[0\]\.ubound' is used uninitialized} {PR77504 etc.} {
xfail *-*-* } .-3 }
- ! { dg-bogus {'a\.dim\[0\]\.lbound' may be used uninitialized} {PR77504
etc.} { xfail { ! __OPTIMIZE__ } } .-4 }
- ! { dg-bogus {'a\.dim\[0\]\.ubound' may be used uninitialized} {PR77504
etc.} { xfail { ! __OPTIMIZE__ } } .-5 }
call foo (A, size(A))
call bar (A)
my_str = "1234567890"
[gcc r14-10477] Fortran: Auto array allocation with function dependencies [PR59104]
https://gcc.gnu.org/g:5034af8223c0db07cdec01cef70048ec44cdd47b
commit r14-10477-g5034af8223c0db07cdec01cef70048ec44cdd47b
Author: Paul Thomas
Date: Thu Jun 20 08:01:36 2024 +0100
Fortran: Auto array allocation with function dependencies [PR59104]
2024-06-20 Paul Thomas
gcc/fortran
PR fortran/59104
* dependency.cc (dependency_fcn, gfc_function_dependency): New
functions to detect dependency in array bounds and character
lengths on old style function results.
* dependency.h : Add prototype for gfc_function_dependency.
* error.cc (error_print): Remove trailing space.
* gfortran.h : Remove dummy_order and add fn_result_spec.
* symbol.cc : Remove declaration of next_dummy_order..
(gfc_set_sym_referenced): remove setting of symbol dummy order.
* trans-array.cc (gfc_trans_auto_array_allocation): Detect
non-dummy symbols with function dependencies and put the
allocation at the end of the initialization code.
* trans-decl.cc : Include dependency.h.
(decl_order): New function that determines uses the location
field of the symbol 'declared_at' to determine the order of two
declarations.
(gfc_defer_symbol_init): Call gfc_function_dependency to put
dependent symbols in the right part of the tlink chain. Use
the location field of the symbol declared_at to determine the
order of declarations.
(gfc_trans_auto_character_variable): Put character length
initialization of dependent symbols at the end of the chain.
* trans.cc (gfc_add_init_cleanup): Add boolean argument with
default false that determines whther an expression is placed at
the back or the front of the initialization chain.
* trans.h : Update the prototype for gfc_add_init_cleanup.
gcc/testsuite/
PR fortran/59104
* gfortran.dg/dependent_decls_2.f90: New test.
(cherry picked from commit ccaa39a268bef2a1d8880022696ff2dcaa6af941)
Diff:
---
gcc/fortran/dependency.cc | 82 +++
gcc/fortran/dependency.h| 4 +-
gcc/fortran/error.cc| 2 +-
gcc/fortran/gfortran.h | 6 +-
gcc/fortran/symbol.cc | 10 ---
gcc/fortran/trans-array.cc | 15 -
gcc/fortran/trans-decl.cc | 51 --
gcc/fortran/trans.cc| 5 +-
gcc/fortran/trans.h | 3 +-
gcc/testsuite/gfortran.dg/dependent_decls_2.f90 | 89 +
10 files changed, 238 insertions(+), 29 deletions(-)
diff --git a/gcc/fortran/dependency.cc b/gcc/fortran/dependency.cc
index bafe8cbc5bc3..15edf1af9dff 100644
--- a/gcc/fortran/dependency.cc
+++ b/gcc/fortran/dependency.cc
@@ -2497,3 +2497,85 @@ gfc_omp_expr_prefix_same (gfc_expr *lexpr, gfc_expr
*rexpr)
return true;
}
+
+
+/* gfc_function_dependency returns true for non-dummy symbols with dependencies
+ on an old-fashioned function result (ie. proc_name = proc_name->result).
+ This is used to ensure that initialization code appears after the function
+ result is treated and that any mutual dependencies between these symbols are
+ respected. */
+
+static bool
+dependency_fcn (gfc_expr *e, gfc_symbol *sym,
+int *f ATTRIBUTE_UNUSED)
+{
+ if (e == NULL)
+return false;
+
+ if (e && e->expr_type == EXPR_VARIABLE)
+{
+ if (e->symtree && e->symtree->n.sym == sym)
+ return true;
+ /* Recurse to see if this symbol is dependent on the function result. If
+so an indirect dependence exists, which should be handled in the same
+way as a direct dependence. The recursion is prevented from being
+infinite by statement order. */
+ else if (e->symtree && e->symtree->n.sym)
+ return gfc_function_dependency (e->symtree->n.sym, sym);
+}
+
+ return false;
+}
+
+
+bool
+gfc_function_dependency (gfc_symbol *sym, gfc_symbol *proc_name)
+{
+ bool dep = false;
+
+ if (proc_name && proc_name->attr.function
+ && proc_name == proc_name->result
+ && !(sym->attr.dummy || sym->attr.result))
+{
+ if (sym->fn_result_dep)
+ return true;
+
+ if (sym->as && sym->as->type == AS_EXPLICIT)
+ {
+ for (int dim = 0; dim < sym->as->rank; dim++)
+ {
+ if (sym->as->lower[dim]
+ && sym->as->lower[dim]->expr_type != EXPR_CONSTANT)
+ dep = gfc_traverse_expr (sym->as->lower[dim], proc_name,
+dependency_fcn, 0);
+ if (dep)
+ {
+ sym->fn_result_dep = 1;
+ return true;
+ }
+
[gcc r14-10478] Fortran: Fix wrong code in unlimited polymorphic assignment [PR113363]
https://gcc.gnu.org/g:d15664f71c150a1b0e6cc07c0534b356b111344d
commit r14-10478-gd15664f71c150a1b0e6cc07c0534b356b111344d
Author: Paul Thomas
Date: Mon May 13 07:27:20 2024 +0100
Fortran: Fix wrong code in unlimited polymorphic assignment [PR113363]
2024-05-13 Paul Thomas
gcc/fortran
PR fortran/113363
* trans-array.cc (gfc_array_init_size): Use the expr3 dtype so
that the correct element size is used.
* trans-expr.cc (gfc_conv_procedure_call): Remove restriction
that ss and ss->loop be present for the finalization of class
array function results.
(trans_class_assignment): Use free and malloc, rather than
realloc, for character expressions assigned to unlimited poly
entities.
* trans-stmt.cc (gfc_trans_allocate): Build a correct rhs for
the assignment of an unlimited polymorphic 'source'.
gcc/testsuite/
PR fortran/113363
* gfortran.dg/pr113363.f90: New test.
(cherry picked from commit 2d0eeb529d400e61197a09c56011be976dd81ef0)
Diff:
---
gcc/fortran/trans-array.cc | 5 ++
gcc/fortran/trans-expr.cc | 34 --
gcc/fortran/trans-stmt.cc | 40
gcc/testsuite/gfortran.dg/pr113363.f90 | 86 ++
4 files changed, 151 insertions(+), 14 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index d69a437980bc..b621f42917c9 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -5964,6 +5964,11 @@ gfc_array_init_size (tree descriptor, int rank, int
corank, tree * poffset,
tmp = gfc_conv_descriptor_dtype (descriptor);
gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type));
}
+ else if (expr3_desc && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr3_desc)))
+{
+ tmp = gfc_conv_descriptor_dtype (descriptor);
+ gfc_add_modify (pblock, tmp, gfc_conv_descriptor_dtype (expr3_desc));
+}
else
{
tmp = gfc_conv_descriptor_dtype (descriptor);
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 114e7629182a..dfc5b8e9b4a5 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -8249,8 +8249,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
call the finalization function of the temporary. Note that the
nullification of allocatable components needed by the result
is done in gfc_trans_assignment_1. */
- if (expr && ((gfc_is_class_array_function (expr)
- && se->ss && se->ss->loop)
+ if (expr && (gfc_is_class_array_function (expr)
|| gfc_is_alloc_class_scalar_function (expr))
&& se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
&& expr->must_finalize)
@@ -12032,18 +12031,25 @@ trans_class_assignment (stmtblock_t *block, gfc_expr
*lhs, gfc_expr *rhs,
/* Reallocate if dynamic types are different. */
gfc_init_block (&re_alloc);
- tmp = fold_convert (pvoid_type_node, class_han);
- re = build_call_expr_loc (input_location,
- builtin_decl_explicit (BUILT_IN_REALLOC), 2,
- tmp, size);
- re = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (tmp), tmp,
- re);
- tmp = fold_build2_loc (input_location, NE_EXPR,
-logical_type_node, rhs_vptr, old_vptr);
- re = fold_build3_loc (input_location, COND_EXPR, void_type_node,
- tmp, re, build_empty_stmt (input_location));
- gfc_add_expr_to_block (&re_alloc, re);
-
+ if (UNLIMITED_POLY (lhs) && rhs->ts.type == BT_CHARACTER)
+ {
+ gfc_add_expr_to_block (&re_alloc, gfc_call_free (class_han));
+ gfc_allocate_using_malloc (&re_alloc, class_han, size, NULL_TREE);
+ }
+ else
+ {
+ tmp = fold_convert (pvoid_type_node, class_han);
+ re = build_call_expr_loc (input_location,
+ builtin_decl_explicit (BUILT_IN_REALLOC),
+ 2, tmp, size);
+ re = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (tmp),
+ tmp, re);
+ tmp = fold_build2_loc (input_location, NE_EXPR,
+logical_type_node, rhs_vptr, old_vptr);
+ re = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+ tmp, re, build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&re_alloc, re);
+ }
tree realloc_expr = lhs->ts.type == BT_CLASS ?
gfc_finish_block (&re_alloc) :
build_empty_stmt (input_location);
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index
[gcc r13-8926] Fortran: Fix wrong code in unlimited polymorphic assignment [PR113363]
https://gcc.gnu.org/g:7c81ff02a943cda82cc1a82b36ae8ab14470b00a
commit r13-8926-g7c81ff02a943cda82cc1a82b36ae8ab14470b00a
Author: Paul Thomas
Date: Mon May 13 07:27:20 2024 +0100
Fortran: Fix wrong code in unlimited polymorphic assignment [PR113363]
2024-05-13 Paul Thomas
gcc/fortran
PR fortran/113363
* trans-array.cc (gfc_array_init_size): Use the expr3 dtype so
that the correct element size is used.
* trans-expr.cc (gfc_conv_procedure_call): Remove restriction
that ss and ss->loop be present for the finalization of class
array function results.
(trans_class_assignment): Use free and malloc, rather than
realloc, for character expressions assigned to unlimited poly
entities.
* trans-stmt.cc (gfc_trans_allocate): Build a correct rhs for
the assignment of an unlimited polymorphic 'source'.
gcc/testsuite/
PR fortran/113363
* gfortran.dg/pr113363.f90: New test.
(cherry picked from commit 2d0eeb529d400e61197a09c56011be976dd81ef0)
Diff:
---
gcc/fortran/trans-array.cc | 5 ++
gcc/fortran/trans-expr.cc | 34 --
gcc/fortran/trans-stmt.cc | 40
gcc/testsuite/gfortran.dg/pr113363.f90 | 86 ++
4 files changed, 151 insertions(+), 14 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index f38e872f5d9c..9557cd14b5e0 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -5795,6 +5795,11 @@ gfc_array_init_size (tree descriptor, int rank, int
corank, tree * poffset,
tmp = gfc_conv_descriptor_dtype (descriptor);
gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type));
}
+ else if (expr3_desc && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr3_desc)))
+{
+ tmp = gfc_conv_descriptor_dtype (descriptor);
+ gfc_add_modify (pblock, tmp, gfc_conv_descriptor_dtype (expr3_desc));
+}
else
{
tmp = gfc_conv_descriptor_dtype (descriptor);
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 6b75c147a350..657f1cb649b4 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -7984,8 +7984,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
call the finalization function of the temporary. Note that the
nullification of allocatable components needed by the result
is done in gfc_trans_assignment_1. */
- if (expr && ((gfc_is_class_array_function (expr)
- && se->ss && se->ss->loop)
+ if (expr && (gfc_is_class_array_function (expr)
|| gfc_is_alloc_class_scalar_function (expr))
&& se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
&& expr->must_finalize)
@@ -11705,18 +11704,25 @@ trans_class_assignment (stmtblock_t *block, gfc_expr
*lhs, gfc_expr *rhs,
/* Reallocate if dynamic types are different. */
gfc_init_block (&re_alloc);
- tmp = fold_convert (pvoid_type_node, class_han);
- re = build_call_expr_loc (input_location,
- builtin_decl_explicit (BUILT_IN_REALLOC), 2,
- tmp, size);
- re = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (tmp), tmp,
- re);
- tmp = fold_build2_loc (input_location, NE_EXPR,
-logical_type_node, rhs_vptr, old_vptr);
- re = fold_build3_loc (input_location, COND_EXPR, void_type_node,
- tmp, re, build_empty_stmt (input_location));
- gfc_add_expr_to_block (&re_alloc, re);
-
+ if (UNLIMITED_POLY (lhs) && rhs->ts.type == BT_CHARACTER)
+ {
+ gfc_add_expr_to_block (&re_alloc, gfc_call_free (class_han));
+ gfc_allocate_using_malloc (&re_alloc, class_han, size, NULL_TREE);
+ }
+ else
+ {
+ tmp = fold_convert (pvoid_type_node, class_han);
+ re = build_call_expr_loc (input_location,
+ builtin_decl_explicit (BUILT_IN_REALLOC),
+ 2, tmp, size);
+ re = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (tmp),
+ tmp, re);
+ tmp = fold_build2_loc (input_location, NE_EXPR,
+logical_type_node, rhs_vptr, old_vptr);
+ re = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+ tmp, re, build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&re_alloc, re);
+ }
tree realloc_expr = lhs->ts.type == BT_CLASS ?
gfc_finish_block (&re_alloc) :
build_empty_stmt (input_location);
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index
[gcc r14-10480] Revert "Fortran: Auto array allocation with function dependencies [PR59104]"
https://gcc.gnu.org/g:94e4661fee27c5b1362e02690c5047e0b543fc9a
commit r14-10480-g94e4661fee27c5b1362e02690c5047e0b543fc9a
Author: Paul Thomas
Date: Sat Jul 20 10:42:40 2024 +0100
Revert "Fortran: Auto array allocation with function dependencies [PR59104]"
This reverts commit 5034af8223c0db07cdec01cef70048ec44cdd47b.
Diff:
---
gcc/fortran/dependency.cc | 82 ---
gcc/fortran/dependency.h| 4 +-
gcc/fortran/error.cc| 2 +-
gcc/fortran/gfortran.h | 6 +-
gcc/fortran/symbol.cc | 10 +++
gcc/fortran/trans-array.cc | 15 +
gcc/fortran/trans-decl.cc | 51 ++
gcc/fortran/trans.cc| 5 +-
gcc/fortran/trans.h | 3 +-
gcc/testsuite/gfortran.dg/dependent_decls_2.f90 | 89 -
10 files changed, 29 insertions(+), 238 deletions(-)
diff --git a/gcc/fortran/dependency.cc b/gcc/fortran/dependency.cc
index 15edf1af9dff..bafe8cbc5bc3 100644
--- a/gcc/fortran/dependency.cc
+++ b/gcc/fortran/dependency.cc
@@ -2497,85 +2497,3 @@ gfc_omp_expr_prefix_same (gfc_expr *lexpr, gfc_expr
*rexpr)
return true;
}
-
-
-/* gfc_function_dependency returns true for non-dummy symbols with dependencies
- on an old-fashioned function result (ie. proc_name = proc_name->result).
- This is used to ensure that initialization code appears after the function
- result is treated and that any mutual dependencies between these symbols are
- respected. */
-
-static bool
-dependency_fcn (gfc_expr *e, gfc_symbol *sym,
-int *f ATTRIBUTE_UNUSED)
-{
- if (e == NULL)
-return false;
-
- if (e && e->expr_type == EXPR_VARIABLE)
-{
- if (e->symtree && e->symtree->n.sym == sym)
- return true;
- /* Recurse to see if this symbol is dependent on the function result. If
-so an indirect dependence exists, which should be handled in the same
-way as a direct dependence. The recursion is prevented from being
-infinite by statement order. */
- else if (e->symtree && e->symtree->n.sym)
- return gfc_function_dependency (e->symtree->n.sym, sym);
-}
-
- return false;
-}
-
-
-bool
-gfc_function_dependency (gfc_symbol *sym, gfc_symbol *proc_name)
-{
- bool dep = false;
-
- if (proc_name && proc_name->attr.function
- && proc_name == proc_name->result
- && !(sym->attr.dummy || sym->attr.result))
-{
- if (sym->fn_result_dep)
- return true;
-
- if (sym->as && sym->as->type == AS_EXPLICIT)
- {
- for (int dim = 0; dim < sym->as->rank; dim++)
- {
- if (sym->as->lower[dim]
- && sym->as->lower[dim]->expr_type != EXPR_CONSTANT)
- dep = gfc_traverse_expr (sym->as->lower[dim], proc_name,
-dependency_fcn, 0);
- if (dep)
- {
- sym->fn_result_dep = 1;
- return true;
- }
- if (sym->as->upper[dim]
- && sym->as->upper[dim]->expr_type != EXPR_CONSTANT)
- dep = gfc_traverse_expr (sym->as->upper[dim], proc_name,
-dependency_fcn, 0);
- if (dep)
- {
- sym->fn_result_dep = 1;
- return true;
- }
- }
- }
-
- if (sym->ts.type == BT_CHARACTER
- && sym->ts.u.cl && sym->ts.u.cl->length
- && sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
- dep = gfc_traverse_expr (sym->ts.u.cl->length, proc_name,
-dependency_fcn, 0);
- if (dep)
- {
- sym->fn_result_dep = 1;
- return true;
- }
-}
-
- return false;
- }
diff --git a/gcc/fortran/dependency.h b/gcc/fortran/dependency.h
index 8f172f86f08f..ea4bd04b0e82 100644
--- a/gcc/fortran/dependency.h
+++ b/gcc/fortran/dependency.h
@@ -23,7 +23,7 @@ enum gfc_dep_check
{
NOT_ELEMENTAL,/* Not elemental case: normal dependency check. */
ELEM_CHECK_VARIABLE, /* Test whether variables overlap. */
- ELEM_DONT_CHECK_VARIABLE /* Test whether variables overlap only if used
+ ELEM_DONT_CHECK_VARIABLE /* Test whether variables overlap only if used
in an expression. */
};
@@ -43,5 +43,3 @@ bool gfc_are_equivalenced_arrays (gfc_expr *, gfc_expr *);
bool gfc_omp_expr_prefix_same (gfc_expr *, gfc_expr *);
gfc_expr * gfc_discard_nops (gfc_expr *);
-
-bool gfc_function_dependency (gfc_symbol *, gfc_symbol *);
diff --git a/gcc/fortran/error.cc b/gcc/fortran/error.cc
index 60f607ecc4f2..65e38b0e8667 100644
--- a/gcc/fortran/error.cc
+++ b/gcc/fortran/error.cc
@@ -892,7 +892,7 @@ error_print (const char *type, const char *format0, va_list
argp)
#else
m =
[gcc r15-2187] Fortran: Fix regression caused by r14-10477 [PR59104]
https://gcc.gnu.org/g:838999bb23303edc14e96b6034cd837fa4454cfd
commit r15-2187-g838999bb23303edc14e96b6034cd837fa4454cfd
Author: Paul Thomas
Date: Sun Jul 21 17:48:47 2024 +0100
Fortran: Fix regression caused by r14-10477 [PR59104]
2024-07-21 Paul Thomas
gcc/fortran
PR fortran/59104
* gfortran.h : Add decl_order to gfc_symbol.
* symbol.cc : Add static next_decl_order..
(gfc_set_sym_referenced): Set symbol decl_order.
* trans-decl.cc : Include dependency.h.
(decl_order): Replace symbol declared_at.lb->location with
decl_order.
gcc/testsuite/
PR fortran/59104
* gfortran.dg/dependent_decls_3.f90: New test.
Diff:
---
gcc/fortran/gfortran.h | 3 +++
gcc/fortran/symbol.cc | 6 ++
gcc/fortran/trans-decl.cc | 2 +-
gcc/testsuite/gfortran.dg/dependent_decls_3.f90 | 26 +
4 files changed, 36 insertions(+), 1 deletion(-)
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 3bdf18d6f9bc..6207ad6ed1df 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -1893,6 +1893,9 @@ typedef struct gfc_symbol
points to C and B's is NULL. */
struct gfc_common_head* common_head;
+ /* Make sure initialization code is generated in the correct order. */
+ int decl_order;
+
gfc_namelist *namelist, *namelist_tail;
/* The tlink field is used in the front end to carry the module
diff --git a/gcc/fortran/symbol.cc b/gcc/fortran/symbol.cc
index 2f326492d5fb..a8479b862e39 100644
--- a/gcc/fortran/symbol.cc
+++ b/gcc/fortran/symbol.cc
@@ -96,6 +96,9 @@ const mstring dtio_procs[] =
minit ("_dtio_unformatted_write", DTIO_WUF),
};
+/* This is to make sure the backend generates setup code in the correct
+ order. */
+static int next_decl_order = 1;
gfc_namespace *gfc_current_ns;
gfc_namespace *gfc_global_ns_list;
@@ -940,6 +943,9 @@ gfc_set_sym_referenced (gfc_symbol *sym)
return;
sym->attr.referenced = 1;
+
+ /* Remember the declaration order. */
+ sym->decl_order = next_decl_order++;
}
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index e6ac7f25b3b0..82fa2bb61349 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -842,7 +842,7 @@ gfc_allocate_lang_decl (tree decl)
static bool
decl_order (gfc_symbol *sym1, gfc_symbol *sym2)
{
- if (sym1->declared_at.lb->location > sym2->declared_at.lb->location)
+ if (sym1->decl_order > sym2->decl_order)
return true;
else
return false;
diff --git a/gcc/testsuite/gfortran.dg/dependent_decls_3.f90
b/gcc/testsuite/gfortran.dg/dependent_decls_3.f90
new file mode 100644
index ..93862b8ccdca
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/dependent_decls_3.f90
@@ -0,0 +1,26 @@
+! { dg-do run }
+!
+! Fix a regression caused by the fix for PR59104.
+!
+! Contributed by Harald Anlauf
+!
+program p
+ implicit none
+ integer, parameter :: nx = 64, ny = 32
+ real :: x(nx,ny), s(nx/2,ny), d(nx/2,ny)
+
+ s = 0.0
+ d = 0.0
+ call sub (x,s,d)
+ if (sum(s) .ne. 256) stop 1
+ if (sum(d) .ne. 256) stop 2 ! Stopped with sum(d) == 0.
+contains
+ subroutine sub (v, w, d)
+real, intent(in) :: v(:,:)
+real, intent(out), dimension (size (v,dim=1)/4,size (v,dim=2)/2) :: w, d
+w = 1.0
+d = 1.0
+if (any (shape (w) .ne. [nx/4, ny/2])) stop 3
+if (any (shape (d) .ne. [nx/4, ny/2])) print *, shape (d) ! Printed "0 0"
here
+ end subroutine sub
+end
[gcc r14-9489] Fortran: Fix class/derived/complex function associate selectors [PR87477]
https://gcc.gnu.org/g:3fd46d859cda1074125449a4cc680ce59fcebc38 commit r14-9489-g3fd46d859cda1074125449a4cc680ce59fcebc38 Author: Paul Thomas Date: Fri Mar 15 06:52:59 2024 + Fortran: Fix class/derived/complex function associate selectors [PR87477] 2024-03-15 Paul Thomas gcc/fortran PR fortran/87477 PR fortran/89645 PR fortran/99065 PR fortran/114141 PR fortran/114280 * class.cc (gfc_change_class): New function needed for associate names, when rank changes or a derived type is produced by resolution * dump-parse-tree.cc (show_code_node): Make output for SELECT TYPE more comprehensible. * expr.cc (find_inquiry_ref): Do not simplify expressions of an inferred type. * gfortran.h : Add 'gfc_association_list' to structure 'gfc_association_list'. Add prototypes for 'gfc_find_derived_types', 'gfc_fixup_inferred_type_refs' and 'gfc_change_class'. Add macro IS_INFERRED_TYPE. * match.cc (copy_ts_from_selector_to_associate): Add bolean arg 'select_type' with default false. If this is a select type name and the selector is a inferred type, build the class type and apply it to the associate name. (build_associate_name): Pass true to 'select_type' in call to previous. * parse.cc (parse_associate): If the selector is inferred type the associate name is too. Make sure that function selector class and rank, if known, are passed to the associate name. If a function result exists, pass its typespec to the associate name. * primary.cc (resolvable_fcns): New function to check that all the function references are resolvable. (gfc_match_varspec): If a scalar derived type select type temporary has an array reference, match the array reference, treating this in the same way as an equivalence member. Do not set 'inquiry' if applied to an unknown type the inquiry name is ambiguous with the component of an accessible derived type. Check that resolution of the target expression is OK by testing if the symbol is declared or is an operator expression, then using 'resolvable_fcns' recursively. If all is well, resolve the expression. If this is an inferred type with a component reference, call 'gfc_find_derived_types' to find a suitable derived type. If there is an inquiry ref and the symbol either is of unknown type or is inferred to be a derived type, set the primary and symbol TKR appropriately. * resolve.cc (resolve_variable): Call new function below. (gfc_fixup_inferred_type_refs): New function to ensure that the expression references for a inferred type are consistent with the now fixed up selector. (resolve_assoc_var): Ensure that derived type or class function selectors transmit the correct arrayspec to the associate name. (resolve_select_type): If the selector is an associate name of inferred type and has no component references, the associate name should have its typespec. Simplify the conversion of a class array to class scalar by calling 'gfc_change_class'. Make sure that a class, inferred type selector with an array ref transfers the typespec from the symbol to the expression. * symbol.cc (gfc_set_default_type): If an associate name with unknown type has a selector expression, try resolving the expr. (find_derived_types, gfc_find_derived_types): New functions that search for a derived type with a given name. * trans-expr.cc (gfc_conv_variable): Some inferred type exprs escape resolution so call 'gfc_fixup_inferred_type_refs'. * trans-stmt.cc (trans_associate_var): Tidy up expression for 'class_target'. Finalize and free class function results. Correctly handle selectors that are class functions and class array references, passed as derived types. gcc/testsuite/ PR fortran/87477 PR fortran/89645 PR fortran/99065 * gfortran.dg/associate_64.f90 : New test * gfortran.dg/associate_66.f90 : New test * gfortran.dg/associate_67.f90 : New test PR fortran/114141 * gfortran.dg/associate_65.f90 : New test PR fortran/114280 * gfortran.dg/associate_68.f90 : New test Diff: --- gcc/fortran/class.cc | 50 + gcc/fortran/dump-parse-tree.cc | 17 +- gcc/fortran/expr.cc
[gcc r13-8503] Fortran: Fix assumed length chars and len inquiry [PR103716]
https://gcc.gnu.org/g:48d23749534ca96b3f0883579b44700a17e83d15
commit r13-8503-g48d23749534ca96b3f0883579b44700a17e83d15
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 4475c864277..e12997bc4a0 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -5526,7 +5526,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 316ad684a64..3f3f0123dc3 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -2875,11 +2875,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 (&expr->ts),
ts->kind);
+ se->string_length = NULL_TREE;
break;
case INQUIRY_LEN:
res = fold_convert (gfc_typenode_for_spec (&expr->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 r14-9719] Fortran: Fix a gimplifier ICE/wrong result with finalization [PR36337]
https://gcc.gnu.org/g:3c793f0361bc66d2a6bf0b3e1fb3234fc511e2a6
commit r14-9719-g3c793f0361bc66d2a6bf0b3e1fb3234fc511e2a6
Author: Paul Thomas
Date: Fri Mar 29 07:23:19 2024 +
Fortran: Fix a gimplifier ICE/wrong result with finalization [PR36337]
2024-03-29 Paul Thomas
gcc/fortran
PR fortran/36337
PR fortran/110987
PR fortran/113885
* trans-expr.cc (gfc_trans_assignment_1): Place finalization
block before rhs post block for elemental rhs.
* trans.cc (gfc_finalize_tree_expr): Check directly if a type
has no components, rather than the zero components attribute.
Treat elemental zero component expressions in the same way as
scalars.
gcc/testsuite/
PR fortran/113885
* gfortran.dg/finalize_54.f90: New test.
* gfortran.dg/finalize_55.f90: New test.
gcc/testsuite/
PR fortran/110987
* gfortran.dg/finalize_56.f90: New test.
Diff:
---
gcc/fortran/trans-expr.cc | 9 +-
gcc/fortran/trans.cc | 6 +-
gcc/testsuite/gfortran.dg/finalize_54.f90 | 47 +
gcc/testsuite/gfortran.dg/finalize_55.f90 | 89
gcc/testsuite/gfortran.dg/finalize_56.f90 | 168 ++
5 files changed, 313 insertions(+), 6 deletions(-)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 76bed9830c4..079ac93aa8a 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -12511,11 +12511,14 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr *
expr2, bool init_flag,
gfc_add_block_to_block (&body, &lse.pre);
gfc_add_expr_to_block (&body, tmp);
- /* Add the post blocks to the body. */
- if (!l_is_temp)
+ /* Add the post blocks to the body. Scalar finalization must appear before
+ the post block in case any dellocations are done. */
+ if (rse.finalblock.head
+ && (!l_is_temp || (expr2->expr_type == EXPR_FUNCTION
+&& gfc_expr_attr (expr2).elemental)))
{
- gfc_add_block_to_block (&rse.finalblock, &rse.post);
gfc_add_block_to_block (&body, &rse.finalblock);
+ gfc_add_block_to_block (&body, &rse.post);
}
else
gfc_add_block_to_block (&body, &rse.post);
diff --git a/gcc/fortran/trans.cc b/gcc/fortran/trans.cc
index 7f50b16aee9..badad6ae892 100644
--- a/gcc/fortran/trans.cc
+++ b/gcc/fortran/trans.cc
@@ -1624,7 +1624,7 @@ gfc_finalize_tree_expr (gfc_se *se, gfc_symbol *derived,
}
else if (derived && gfc_is_finalizable (derived, NULL))
{
- if (derived->attr.zero_comp && !rank)
+ if (!derived->components && (!rank || attr.elemental))
{
/* Any attempt to assign zero length entities, causes the gimplifier
all manner of problems. Instead, a variable is created to act as
@@ -1675,7 +1675,7 @@ gfc_finalize_tree_expr (gfc_se *se, gfc_symbol *derived,
final_fndecl);
if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
{
- if (is_class)
+ if (is_class || attr.elemental)
desc = gfc_conv_scalar_to_descriptor (se, desc, attr);
else
{
@@ -1685,7 +1685,7 @@ gfc_finalize_tree_expr (gfc_se *se, gfc_symbol *derived,
}
}
- if (derived && derived->attr.zero_comp)
+ if (derived && !derived->components)
{
/* All the conditions below break down for zero length derived types. */
tmp = build_call_expr_loc (input_location, final_fndecl, 3,
diff --git a/gcc/testsuite/gfortran.dg/finalize_54.f90
b/gcc/testsuite/gfortran.dg/finalize_54.f90
new file mode 100644
index 000..73d32b1b333
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/finalize_54.f90
@@ -0,0 +1,47 @@
+! { dg-do compile }
+! Test the fix for PR113885, where not only was there a gimplifier ICE
+! for a derived type 't' with no components but, with a component, gfortran
+! gave wrong results.
+! Contributed by David Binderman
+!
+module types
+ type t
+ contains
+ final :: finalize
+ end type t
+contains
+ pure subroutine finalize(x)
+type(t), intent(inout) :: x
+ end subroutine finalize
+end module types
+
+subroutine test1(x)
+ use types
+ interface
+ elemental function elem(x)
+ use types
+ type(t), intent(in) :: x
+ type(t) :: elem
+ end function elem
+ end interface
+ type(t) :: x(:)
+ x = elem(x)
+end subroutine test1
+
+subroutine test2(x)
+ use types
+ interface
+ elemental function elem(x)
+ use types
+ type(t), intent(in) :: x
+ type(t) :: elem
+ end function elem
+ elemental function elem2(x, y)
+ use types
+ type(t), intent(in) :: x, y
+ type(t) :: elem2
+ end function elem2
+ end interface
+ type(t) :: x(:)
+ x = elem2(elem(x), elem(x))
+end subroutine test2
diff --git a/gcc/testsuite/gfortran.dg/finalize_55.f90
b/gcc
[gcc r14-9752] Fortran: Fix wrong recursive errors and class initialization [PR112407]
https://gcc.gnu.org/g:35408b3669fac104cd380582b32e32c64a603d8b
commit r14-9752-g35408b3669fac104cd380582b32e32c64a603d8b
Author: Paul Thomas
Date: Tue Apr 2 14:19:09 2024 +0100
Fortran: Fix wrong recursive errors and class initialization [PR112407]
2024-04-02 Paul Thomas
gcc/fortran
PR fortran/112407
* resolve.cc (resolve_procedure_expression): Change the test for
for recursion in the case of hidden procedures from modules.
(resolve_typebound_static): Add warning for possible recursive
calls to typebound procedures.
* trans-expr.cc (gfc_trans_class_init_assign): Do not apply
default initializer to class dummy where component initializers
are all null.
gcc/testsuite/
PR fortran/112407
* gfortran.dg/pr112407a.f90: New test.
* gfortran.dg/pr112407b.f90: New test.
Diff:
---
gcc/fortran/resolve.cc | 23 +--
gcc/fortran/trans-expr.cc | 16
gcc/testsuite/gfortran.dg/pr112407a.f90 | 71 +
gcc/testsuite/gfortran.dg/pr112407b.f90 | 58 +++
4 files changed, 164 insertions(+), 4 deletions(-)
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 50d51b06c92..43315a6a550 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -1963,12 +1963,20 @@ resolve_procedure_expression (gfc_expr* expr)
|| (sym->attr.function && sym->result == sym))
return true;
- /* A non-RECURSIVE procedure that is used as procedure expression within its
+ /* A non-RECURSIVE procedure that is used as procedure expression within its
own body is in danger of being called recursively. */
if (is_illegal_recursion (sym, gfc_current_ns))
-gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
-" itself recursively. Declare it RECURSIVE or use"
-" %<-frecursive%>", sym->name, &expr->where);
+{
+ if (sym->attr.use_assoc && expr->symtree->name[0] == '@')
+ gfc_warning (0, "Non-RECURSIVE procedure %qs from module %qs is "
+" possibly calling itself recursively in procedure %qs. "
+" Declare it RECURSIVE or use %<-frecursive%>",
+sym->name, sym->module, gfc_current_ns->proc_name->name);
+ else
+ gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
+" itself recursively. Declare it RECURSIVE or use"
+" %<-frecursive%>", sym->name, &expr->where);
+}
return true;
}
@@ -6820,6 +6828,13 @@ resolve_typebound_static (gfc_expr* e, gfc_symtree**
target,
if (st)
*target = st;
}
+
+ if (is_illegal_recursion ((*target)->n.sym, gfc_current_ns)
+ && !e->value.compcall.tbp->deferred)
+gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
+" itself recursively. Declare it RECURSIVE or use"
+" %<-frecursive%>", (*target)->n.sym->name, &e->where);
+
return true;
}
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index d21e3956d6e..f4c4724e1c3 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -1719,6 +1719,7 @@ gfc_trans_class_init_assign (gfc_code *code)
tree tmp;
gfc_se dst,src,memsz;
gfc_expr *lhs, *rhs, *sz;
+ gfc_component *cmp;
gfc_start_block (&block);
@@ -1735,6 +1736,21 @@ gfc_trans_class_init_assign (gfc_code *code)
/* The _def_init is always scalar. */
rhs->rank = 0;
+ /* Check def_init for initializers. If this is a dummy with all default
+ initializer components NULL, return NULL_TREE and use the passed value as
+ required by F2018(8.5.10). */
+ if (!lhs->ref && lhs->symtree->n.sym->attr.dummy)
+{
+ cmp = rhs->ref->next->u.c.component->ts.u.derived->components;
+ for (; cmp; cmp = cmp->next)
+ {
+ if (cmp->initializer)
+ break;
+ else if (!cmp->next)
+ return build_empty_stmt (input_location);
+ }
+}
+
if (code->expr1->ts.type == BT_CLASS
&& CLASS_DATA (code->expr1)->attr.dimension)
{
diff --git a/gcc/testsuite/gfortran.dg/pr112407a.f90
b/gcc/testsuite/gfortran.dg/pr112407a.f90
new file mode 100644
index 000..470f4191611
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr112407a.f90
@@ -0,0 +1,71 @@
+! { dg-do run }
+! Test of an issue found in the investigation of PR112407
+! Contributed by Tomas Trnka
+!
+module m
+ private new_t
+
+ type s
+procedure(),pointer,nopass :: op
+ end type
+
+ type :: t
+integer :: i
+type (s) :: s
+ contains
+procedure :: new_t
+procedure :: bar
+procedure :: add_t
+generic :: new => new_t, bar
+generic, public :: assignment(=) => add_t
+final :: final_t
+ end type
+
+ integer :: i = 0, finals = 0
+
+contain
[gcc r14-9753] Fortran: Add error for subroutine passed to a variable dummy [PR106999]
https://gcc.gnu.org/g:a7aa9455a8b9cb080649a7357b7360f2d99bcbf1
commit r14-9753-ga7aa9455a8b9cb080649a7357b7360f2d99bcbf1
Author: Paul Thomas
Date: Tue Apr 2 15:53:29 2024 +0100
Fortran: Add error for subroutine passed to a variable dummy [PR106999]
2024-04-02 Paul Thomas
gcc/fortran
PR fortran/106999
* interface.cc (gfc_compare_interfaces): Add error for a
subroutine proc pointer passed to a variable formal.
(compare_parameter): If a procedure pointer is being passed to
a non-procedure formal arg, and there is an an interface, use
gfc_compare_interfaces to check and provide a more useful error
message.
gcc/testsuite/
PR fortran/106999
* gfortran.dg/pr106999.f90: New test.
Diff:
---
gcc/fortran/interface.cc | 20 +++-
gcc/testsuite/gfortran.dg/pr106999.f90 | 33 +
2 files changed, 52 insertions(+), 1 deletion(-)
diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc
index 7b86a338bc1..bf151dae743 100644
--- a/gcc/fortran/interface.cc
+++ b/gcc/fortran/interface.cc
@@ -1789,6 +1789,14 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2,
const char *name2,
return false;
}
+ if (s2->attr.subroutine && s1->attr.flavor == FL_VARIABLE)
+{
+ if (errmsg != NULL)
+ snprintf (errmsg, err_len, "subroutine proc pointer '%s' passed "
+ "to dummy variable '%s'", name2, s1->name);
+ return false;
+}
+
/* Do strict checks on all characteristics
(for dummy procedures and procedure pointer assignments). */
if (!generic_flag && strict_flag)
@@ -2425,12 +2433,22 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
{
gfc_symbol *act_sym = actual->symtree->n.sym;
- if (formal->attr.flavor != FL_PROCEDURE)
+ if (formal->attr.flavor != FL_PROCEDURE && !act_sym->ts.interface)
{
if (where)
gfc_error ("Invalid procedure argument at %L", &actual->where);
return false;
}
+ else if (act_sym->ts.interface
+ && !gfc_compare_interfaces (formal, act_sym->ts.interface,
+ act_sym->name, 0, 1, err,
+ sizeof(err),NULL, NULL))
+ {
+ if (where)
+ gfc_error_opt (0, "Interface mismatch in dummy procedure %qs at %L:"
+ " %s", formal->name, &actual->where, err);
+ return false;
+ }
if (!gfc_compare_interfaces (formal, act_sym, act_sym->name, 0, 1, err,
sizeof(err), NULL, NULL))
diff --git a/gcc/testsuite/gfortran.dg/pr106999.f90
b/gcc/testsuite/gfortran.dg/pr106999.f90
new file mode 100644
index 000..f05a27006f6
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr106999.f90
@@ -0,0 +1,33 @@
+! { dg-do compile }
+! Test the fix for PR106999
+! Contributed by Gerhard Steinmetz
+program p
+ type t
+ integer :: i
+ procedure(g), pointer :: f
+ end type
+ class(t), allocatable :: y, z
+ procedure(g), pointer :: ff
+ allocate (z)
+ z%i = 42
+ z%f => g
+ ff => g
+ call r(z%f)
+ call s(z%f) ! { dg-error "Interface mismatch in dummy procedure" }
+ call s(ff) ! { dg-error "Interface mismatch in dummy procedure" }
+contains
+ subroutine g(x)
+ class(t) :: x
+ x%i = 84
+ end
+ subroutine r(x)
+ procedure(g) :: x
+ print *, "in r"
+ allocate (y)
+ call x(y)
+ print *, y%i
+ end
+ subroutine s(x)
+ class(*) :: x
+ end subroutine
+end
[gcc r14-9873] Fortran: Fix ICE in gfc_trans_pointer_assignment [PR113956]
https://gcc.gnu.org/g:88aea122a7ee639230bf17a9eda4bf8a5eb7e282
commit r14-9873-g88aea122a7ee639230bf17a9eda4bf8a5eb7e282
Author: Paul Thomas
Date: Tue Apr 9 15:23:46 2024 +0100
Fortran: Fix ICE in gfc_trans_pointer_assignment [PR113956]
2024-04-09 Paul Thomas
gcc/fortran
PR fortran/113956
* trans-expr.cc (gfc_trans_pointer_assignment): Remove assert
causing the ICE since it was unnecesary.
gcc/testsuite/
PR fortran/113956
* gfortran.dg/pr113956.f90: New test.
Diff:
---
gcc/fortran/trans-expr.cc | 9 +++--
gcc/testsuite/gfortran.dg/pr113956.f90 | 21 +
2 files changed, 24 insertions(+), 6 deletions(-)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index f4c4724e1c3..605434f4ddb 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -10550,12 +10550,9 @@ gfc_trans_pointer_assignment (gfc_expr * expr1,
gfc_expr * expr2)
{
gfc_symbol *psym = expr1->symtree->n.sym;
tmp = NULL_TREE;
- if (psym->ts.type == BT_CHARACTER)
- {
- gcc_assert (psym->ts.u.cl->backend_decl
- && VAR_P (psym->ts.u.cl->backend_decl));
- tmp = psym->ts.u.cl->backend_decl;
- }
+ if (psym->ts.type == BT_CHARACTER
+ && psym->ts.u.cl->backend_decl)
+ tmp = psym->ts.u.cl->backend_decl;
else if (expr1->ts.u.cl->backend_decl
&& VAR_P (expr1->ts.u.cl->backend_decl))
tmp = expr1->ts.u.cl->backend_decl;
diff --git a/gcc/testsuite/gfortran.dg/pr113956.f90
b/gcc/testsuite/gfortran.dg/pr113956.f90
new file mode 100644
index 000..229e891f847
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr113956.f90
@@ -0,0 +1,21 @@
+! { dg-do run }
+! Test the fix for PR113956
+! Contributed by David Binderman
+module m
+contains
+ subroutine test_array_char(p, x)
+character(*), target :: x(:)
+character(:), pointer :: p(:)
+p => x ! ICE
+ end subroutine
+end module
+
+ use m
+ character(:), allocatable, target :: chr(:)
+ character(:), pointer :: p(:)
+ chr = ["ab","cd"]
+ call test_array_char (p, chr)
+ if (loc (chr) .ne. loc (p)) stop 1
+ if (len (p) .ne. 2) stop 2
+ if (any (p .ne. chr)) stop 3
+end
[gcc r14-9874] Fortran: Fix ICE in trans-stmt.cc(gfc_trans_call) [PR114535]
https://gcc.gnu.org/g:de82b0cf981e49a0bda957c0ac31146b17407e23
commit r14-9874-gde82b0cf981e49a0bda957c0ac31146b17407e23
Author: Paul Thomas
Date: Tue Apr 9 15:27:28 2024 +0100
Fortran: Fix ICE in trans-stmt.cc(gfc_trans_call) [PR114535]
2024-04-09 Paul Thomas
gcc/fortran
PR fortran/114535
* resolve.cc (resolve_symbol): Remove last chunk that checked
for finalization of unreferenced symbols.
gcc/testsuite/
PR fortran/114535
* gfortran.dg/pr114535d.f90: New test.
* gfortran.dg/pr114535iv.f90: Additional source.
Diff:
---
gcc/fortran/resolve.cc | 9 ---
gcc/testsuite/gfortran.dg/pr114535d.f90 | 42
gcc/testsuite/gfortran.dg/pr114535iv.f90 | 18 ++
3 files changed, 60 insertions(+), 9 deletions(-)
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 43315a6a550..4cbf7186119 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -17069,15 +17069,6 @@ resolve_symbol (gfc_symbol *sym)
if (sym->param_list)
resolve_pdt (sym);
-
- if (!sym->attr.referenced
- && (sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED))
-{
- gfc_expr *final_expr = gfc_lval_expr_from_sym (sym);
- if (gfc_is_finalizable (final_expr->ts.u.derived, NULL))
- gfc_set_sym_referenced (sym);
- gfc_free_expr (final_expr);
-}
}
diff --git a/gcc/testsuite/gfortran.dg/pr114535d.f90
b/gcc/testsuite/gfortran.dg/pr114535d.f90
new file mode 100644
index 000..7ce178a1e30
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr114535d.f90
@@ -0,0 +1,42 @@
+! { dg-do compile }
+! { dg-compile-aux-modules "pr114535iv.f90" }
+! Contributed by Andrew Benson
+!
+module d
+ implicit none
+contains
+ function en() result(dd)
+use :: iv
+implicit none
+type(vs) :: dd
+dd%i = 1
+ end function en
+end module d
+
+! Delete line 1 and all brands complain that 'vs' is an undefined type.
+! Delete lines 1 and line 2 recreates the original problem.
+module ni
+ implicit none
+contains
+ subroutine iss1()
+!use :: iv! line 1
+use :: d
+implicit none
+!type(vs) :: ans; ans = en(); ! line 2
+ end subroutine iss1
+ subroutine iss2()
+use :: d
+implicit none
+ end subroutine iss2
+end module ni ! Used to give an ICE: in gfc_trans_call, at
fortran/trans-stmt.cc:400
+
+ use ni
+ use iv
+ type(vs) :: x
+ call iss1()
+ call iss1()
+ if ((ctr .eq. 0) .or. (ctr .ne. 6)) stop 1 ! Depends whether lines 1 & 2
are present
+ call iss2()
+ x = vs(42)
+ if ((ctr .eq. 1) .or. (ctr .ne. 7)) stop 2 ! Make sure destructor available
here
+end
diff --git a/gcc/testsuite/gfortran.dg/pr114535iv.f90
b/gcc/testsuite/gfortran.dg/pr114535iv.f90
new file mode 100644
index 000..be629991023
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr114535iv.f90
@@ -0,0 +1,18 @@
+! Compiled with pr114535d.f90
+! Contributed by Andrew Benson
+!
+module iv
+ type, public :: vs
+ integer :: i
+ contains
+ final :: destructor
+ end type vs
+ integer :: ctr = 0
+contains
+ impure elemental subroutine destructor(s)
+type(vs), intent(inout) :: s
+s%i = 0
+ctr = ctr + 1
+ end subroutine destructor
+end module iv
+
[gcc r14-10030] Fortran: Fix ICE and clear incorrect error messages [PR114739]
https://gcc.gnu.org/g:e243d0feafa533141ef7e23820d5cc60cf33204a
commit r14-10030-ge243d0feafa533141ef7e23820d5cc60cf33204a
Author: Paul Thomas
Date: Thu Apr 18 18:07:25 2024 +0100
Fortran: Fix ICE and clear incorrect error messages [PR114739]
2024-04-18 Paul Thomas
gcc/fortran
PR fortran/114739
* primary.cc (gfc_match_varspec): Check for default type before
checking for derived types with the right component name.
gcc/testsuite/
PR fortran/114739
* gfortran.dg/pr114739.f90: New test.
* gfortran.dg/derived_comp_array_ref_8.f90: Add 'implicit none'
for consistency with expected error message.
* gfortran.dg/nullify_4.f90: ditto
* gfortran.dg/pointer_init_6.f90: ditto
* gfortran.dg/pr107397.f90: ditto
* gfortran.dg/pr88138.f90: ditto
Diff:
---
gcc/fortran/primary.cc | 9 +
gcc/testsuite/gfortran.dg/derived_comp_array_ref_8.f90 | 1 +
gcc/testsuite/gfortran.dg/nullify_4.f90| 1 +
gcc/testsuite/gfortran.dg/pointer_init_6.f90 | 2 +-
gcc/testsuite/gfortran.dg/pr107397.f90 | 1 +
gcc/testsuite/gfortran.dg/pr114739.f90 | 11 +++
gcc/testsuite/gfortran.dg/pr88138.f90 | 1 +
7 files changed, 25 insertions(+), 1 deletion(-)
diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index 5dd6875a4a6..606e84432be 100644
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
@@ -2236,6 +2236,15 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag,
bool sub_flag,
match mm;
old_loc = gfc_current_locus;
mm = gfc_match_name (name);
+
+ /* Check to see if this has a default complex. */
+ if (sym->ts.type == BT_UNKNOWN && tgt_expr == NULL
+ && gfc_get_default_type (sym->name, sym->ns)->type != BT_UNKNOWN)
+ {
+ gfc_set_default_type (sym, 0, sym->ns);
+ primary->ts = sym->ts;
+ }
+
/* This is a usable inquiry reference, if the symbol is already known
to have a type or no derived types with a component of this name
can be found. If this was an inquiry reference with the same name
diff --git a/gcc/testsuite/gfortran.dg/derived_comp_array_ref_8.f90
b/gcc/testsuite/gfortran.dg/derived_comp_array_ref_8.f90
index 739f4adfb78..22dfdc668a6 100644
--- a/gcc/testsuite/gfortran.dg/derived_comp_array_ref_8.f90
+++ b/gcc/testsuite/gfortran.dg/derived_comp_array_ref_8.f90
@@ -2,6 +2,7 @@
!
! PR fortran/52325
!
+implicit none
real :: f
cc%a = 5 ! { dg-error "Symbol 'cc' at .1. has no IMPLICIT type" }
f%a = 5 ! { dg-error "Unexpected '%' for nonderived-type variable 'f' at" }
diff --git a/gcc/testsuite/gfortran.dg/nullify_4.f90
b/gcc/testsuite/gfortran.dg/nullify_4.f90
index 0fd5056ee07..240110fabf8 100644
--- a/gcc/testsuite/gfortran.dg/nullify_4.f90
+++ b/gcc/testsuite/gfortran.dg/nullify_4.f90
@@ -3,6 +3,7 @@
!
! Check error recovery; was crashing before.
!
+implicit none
real, pointer :: ptr
nullify(ptr, mesh%coarser) ! { dg-error "Symbol 'mesh' at .1. has no IMPLICIT
type" }
end
diff --git a/gcc/testsuite/gfortran.dg/pointer_init_6.f90
b/gcc/testsuite/gfortran.dg/pointer_init_6.f90
index 3abad4ae179..477626e66bb 100644
--- a/gcc/testsuite/gfortran.dg/pointer_init_6.f90
+++ b/gcc/testsuite/gfortran.dg/pointer_init_6.f90
@@ -21,7 +21,7 @@ end module m1
module m2
-
+ implicit none
type :: t
procedure(s), pointer, nopass :: ppc
end type
diff --git a/gcc/testsuite/gfortran.dg/pr107397.f90
b/gcc/testsuite/gfortran.dg/pr107397.f90
index fd59bf16007..f77b4b00d00 100644
--- a/gcc/testsuite/gfortran.dg/pr107397.f90
+++ b/gcc/testsuite/gfortran.dg/pr107397.f90
@@ -1,6 +1,7 @@
!{ dg-do compile }
!
program p
+ implicit none
type t
real :: a = 1.0
end type
diff --git a/gcc/testsuite/gfortran.dg/pr114739.f90
b/gcc/testsuite/gfortran.dg/pr114739.f90
new file mode 100644
index 000..eb82cb3f65b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr114739.f90
@@ -0,0 +1,11 @@
+! { dg-do compile }
+! The fix here was triggered by an ICE prior to r14-9489-g3fd46d859cda10
+! Before that gfortran gave an incorrect "no implicit type" error for all
+! three statements.
+program main
+ implicit complex(z)
+ implicit character(c)
+ z2%re = 1.
+ z2%im = 2.
+ print *, z2, c%kind
+end
diff --git a/gcc/testsuite/gfortran.dg/pr88138.f90
b/gcc/testsuite/gfortran.dg/pr88138.f90
index c4019a6ca2e..f1130cf2bab 100644
--- a/gcc/testsuite/gfortran.dg/pr88138.f90
+++ b/gcc/testsuite/gfortran.dg/pr88138.f90
@@ -1,5 +1,6 @@
! { dg-do compile }
program p
+ implicit none
type t
character :: c = 'c'
end type
[gcc r14-10059] Fortran: Detect 'no implicit type' error in right place [PR103471]
https://gcc.gnu.org/g:f17d31e709af9b2d488adecd6cd040dfc1f23b04
commit r14-10059-gf17d31e709af9b2d488adecd6cd040dfc1f23b04
Author: Paul Thomas
Date: Sun Apr 21 17:24:24 2024 +0100
Fortran: Detect 'no implicit type' error in right place [PR103471]
2024-04-21 Paul Thomas
gcc/fortran
PR fortran/103471
* resolve.cc (resolve_actual_arglist): Catch variables silently
set as untyped, resetting the flag so that gfc_resolve_expr can
generate the no implicit type error.
(gfc_resolve_index_1): Block index expressions of unknown type
from being converted to default integer, avoiding the fatal
error in trans-decl.cc.
* symbol.cc (gfc_set_default_type): Remove '(symbol)' from the
'no IMPLICIT type' error message.
* trans-decl.cc (gfc_get_symbol_decl): Change fatal error locus
to that of the symbol declaration.
(gfc_trans_deferred_vars): Remove two trailing tabs.
gcc/testsuite/
PR fortran/103471
* gfortran.dg/pr103471.f90: New test.
Diff:
---
gcc/fortran/resolve.cc | 11 ++-
gcc/fortran/symbol.cc | 2 +-
gcc/fortran/trans-decl.cc | 7 ---
gcc/testsuite/gfortran.dg/pr103471.f90 | 18 ++
4 files changed, 33 insertions(+), 5 deletions(-)
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 6b3e5ba4fcb..4368627041e 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -2189,6 +2189,14 @@ resolve_actual_arglist (gfc_actual_arglist *arg,
procedure_type ptype,
? CLASS_DATA (sym)->as : sym->as;
}
+ /* These symbols are set untyped by calls to gfc_set_default_type
+with 'error_flag' = false. Reset the untyped attribute so that
+the error will be generated in gfc_resolve_expr. */
+ if (e->expr_type == EXPR_VARIABLE
+ && sym->ts.type == BT_UNKNOWN
+ && sym->attr.untyped)
+ sym->attr.untyped = 0;
+
/* Expressions are assigned a default ts.type of BT_PROCEDURE in
primary.cc (match_actual_arg). If above code determines that it
is a variable instead, it needs to be resolved as it was not
@@ -5001,7 +5009,8 @@ gfc_resolve_index_1 (gfc_expr *index, int check_scalar,
if ((index->ts.kind != gfc_index_integer_kind
&& force_index_integer_kind)
- || index->ts.type != BT_INTEGER)
+ || (index->ts.type != BT_INTEGER
+ && index->ts.type != BT_UNKNOWN))
{
gfc_clear_ts (&ts);
ts.type = BT_INTEGER;
diff --git a/gcc/fortran/symbol.cc b/gcc/fortran/symbol.cc
index 3a3b6de5cec..8f7deac1d1e 100644
--- a/gcc/fortran/symbol.cc
+++ b/gcc/fortran/symbol.cc
@@ -320,7 +320,7 @@ gfc_set_default_type (gfc_symbol *sym, int error_flag,
gfc_namespace *ns)
"; did you mean %qs?",
sym->name, &sym->declared_at, guessed);
else
- gfc_error ("Symbol %qs at %L has no IMPLICIT type(symbol)",
+ gfc_error ("Symbol %qs at %L has no IMPLICIT type",
sym->name, &sym->declared_at);
sym->attr.untyped = 1; /* Ensure we only give an error once. */
}
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index e160c5c98c1..301439baaf5 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -1797,7 +1797,8 @@ gfc_get_symbol_decl (gfc_symbol * sym)
}
if (sym->ts.type == BT_UNKNOWN)
-gfc_fatal_error ("%s at %C has no default type", sym->name);
+gfc_fatal_error ("%s at %L has no default type", sym->name,
+&sym->declared_at);
if (sym->attr.intrinsic)
gfc_internal_error ("intrinsic variable which isn't a procedure");
@@ -5214,8 +5215,8 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym,
gfc_wrapped_block * block)
tree tmp = lookup_attribute ("omp allocate",
DECL_ATTRIBUTES (n->sym->backend_decl));
tmp = TREE_VALUE (tmp);
- TREE_PURPOSE (tmp) = se.expr;
- TREE_VALUE (tmp) = align;
+ TREE_PURPOSE (tmp) = se.expr;
+ TREE_VALUE (tmp) = align;
TREE_PURPOSE (TREE_CHAIN (tmp)) = init_stmtlist;
TREE_VALUE (TREE_CHAIN (tmp)) = cleanup_stmtlist;
}
diff --git a/gcc/testsuite/gfortran.dg/pr103471.f90
b/gcc/testsuite/gfortran.dg/pr103471.f90
new file mode 100644
index 000..695446e034e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr103471.f90
@@ -0,0 +1,18 @@
+! { dg-do compile }
+! Test the fix for PR103471 in which, rather than giving a "no IMPLICIT type"
+! message, gfortran took to ICEing. The fuzzy symbol check for 'kk'
demonstrates
+! that the error is being detected at the right place.
+!
+! Contributed by Gerhard Steinmetz
+!
+program p
+ implicit none
+ integer, parameter :: x(4) = [1,2,3,4]
+ real, extern
[gcc r14-10089] Fortran: Check that the ICE does not reappear [PR102597]
https://gcc.gnu.org/g:ca00bf02dcc37f9ff1028ca1d90e8b8d95d69683
commit r14-10089-gca00bf02dcc37f9ff1028ca1d90e8b8d95d69683
Author: Paul Thomas
Date: Tue Apr 23 10:22:48 2024 +0100
Fortran: Check that the ICE does not reappear [PR102597]
2024-04-23 Paul Thomas
gcc/testsuite/
PR fortran/102597
* gfortran.dg/pr102597.f90: New test.
Diff:
---
gcc/testsuite/gfortran.dg/pr102597.f90 | 9 +
1 file changed, 9 insertions(+)
diff --git a/gcc/testsuite/gfortran.dg/pr102597.f90
b/gcc/testsuite/gfortran.dg/pr102597.f90
new file mode 100644
index 000..c2d875f897a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr102597.f90
@@ -0,0 +1,9 @@
+! { dg-do compile }
+! Check that PR102597 does not resurface. Regression caused ICE at associate
+! statement.
+! Contributed by Gerhard Steinmetz
+program p
+ use iso_fortran_env
+ associate (y => (compiler_version)) ! { dg-error "is a procedure name" }
+ end associate
+end
[gcc r14-10115] Fortran: Generate new charlens for shared symbol typespecs [PR89462]
https://gcc.gnu.org/g:1fd5a07444776d76cdd6a2eee7df0478201197a5
commit r14-10115-g1fd5a07444776d76cdd6a2eee7df0478201197a5
Author: Paul Thomas
Date: Thu Apr 25 06:52:31 2024 +0100
Fortran: Generate new charlens for shared symbol typespecs [PR89462]
2024-04-25 Paul Thomas
Jakub Jelinek
gcc/fortran
PR fortran/89462
* decl.cc (build_sym): Add an extra argument 'elem'. If 'elem'
is greater than 1, gfc_new_charlen is called to generate a new
charlen, registered in the symbol namespace.
(variable_decl, enumerator_decl): Set the new argument in the
calls to build_sym.
gcc/testsuite/
PR fortran/89462
* gfortran.dg/pr89462.f90: New test.
Diff:
---
gcc/fortran/decl.cc | 11 +++
gcc/testsuite/gfortran.dg/pr89462.f90 | 13 +
2 files changed, 20 insertions(+), 4 deletions(-)
diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index a7576f4bc40..b8308aeee55 100644
--- a/gcc/fortran/decl.cc
+++ b/gcc/fortran/decl.cc
@@ -1713,7 +1713,7 @@ gfc_verify_c_interop_param (gfc_symbol *sym)
/* Function called by variable_decl() that adds a name to the symbol table. */
static bool
-build_sym (const char *name, gfc_charlen *cl, bool cl_deferred,
+build_sym (const char *name, int elem, gfc_charlen *cl, bool cl_deferred,
gfc_array_spec **as, locus *var_locus)
{
symbol_attribute attr;
@@ -1778,7 +1778,10 @@ build_sym (const char *name, gfc_charlen *cl, bool
cl_deferred,
if (sym->ts.type == BT_CHARACTER)
{
- sym->ts.u.cl = cl;
+ if (elem > 1)
+ sym->ts.u.cl = gfc_new_charlen (sym->ns, cl);
+ else
+ sym->ts.u.cl = cl;
sym->ts.deferred = cl_deferred;
}
@@ -2960,7 +2963,7 @@ variable_decl (int elem)
create a symbol for those yet. If we fail to create the symbol,
bail out. */
if (!gfc_comp_struct (gfc_current_state ())
- && !build_sym (name, cl, cl_deferred, &as, &var_locus))
+ && !build_sym (name, elem, cl, cl_deferred, &as, &var_locus))
{
m = MATCH_ERROR;
goto cleanup;
@@ -10938,7 +10941,7 @@ enumerator_decl (void)
/* OK, we've successfully matched the declaration. Now put the
symbol in the current namespace. If we fail to create the symbol,
bail out. */
- if (!build_sym (name, NULL, false, &as, &var_locus))
+ if (!build_sym (name, 1, NULL, false, &as, &var_locus))
{
m = MATCH_ERROR;
goto cleanup;
diff --git a/gcc/testsuite/gfortran.dg/pr89462.f90
b/gcc/testsuite/gfortran.dg/pr89462.f90
new file mode 100644
index 000..b2a4912fcc8
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr89462.f90
@@ -0,0 +1,13 @@
+! { dg-do compile }
+! { dg-options "-pedantic-errors" }
+! Test the fix for PR89462 in which the shared 'cl' field of the typespec
+! shared between 'test', 'TR' and 'aTP' caused the compiler to go into an
+! infinite loop.
+! Contributed by Sergei Trofimovich
+ CHARACTER*1 FUNCTION test(H) ! { dg-warning "Old-style character length" }
+ CHARACTER*1 test2,TR,aTP ! { dg-warning "Old-style character length" }
+ ENTRY test2(L)
+ CALL ttest3(aTP)
+ test = TR
+ RETURN
+ END
[gcc r14-10116] Fortran: Fix ICE in gfc_trans_create_temp_array from bad type [PR93678]
https://gcc.gnu.org/g:c058105bc47a0701e157d1028e60f48554561f9f
commit r14-10116-gc058105bc47a0701e157d1028e60f48554561f9f
Author: Paul Thomas
Date: Thu Apr 25 06:56:10 2024 +0100
Fortran: Fix ICE in gfc_trans_create_temp_array from bad type [PR93678]
2024-04-25 Paul Thomas
gcc/fortran
PR fortran/93678
* trans-expr.cc (gfc_conv_procedure_call): Use the interface,
where possible, to obtain the type of character procedure
pointers of class entities.
gcc/testsuite/
PR fortran/93678
* gfortran.dg/pr93678.f90: New test.
Diff:
---
gcc/fortran/trans-expr.cc | 10 --
gcc/testsuite/gfortran.dg/pr93678.f90 | 32
2 files changed, 40 insertions(+), 2 deletions(-)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 605434f4ddb..072adf3fe77 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -7879,8 +7879,14 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
{
gcc_assert (se->loop && info);
- /* Set the type of the array. */
- tmp = gfc_typenode_for_spec (&comp->ts);
+ /* Set the type of the array. vtable charlens are not always reliable.
+Use the interface, if possible. */
+ if (comp->ts.type == BT_CHARACTER
+ && expr->symtree->n.sym->ts.type == BT_CLASS
+ && comp->ts.interface && comp->ts.interface->result)
+ tmp = gfc_typenode_for_spec (&comp->ts.interface->result->ts);
+ else
+ tmp = gfc_typenode_for_spec (&comp->ts);
gcc_assert (se->ss->dimen == se->loop->dimen);
/* Evaluate the bounds of the result, if known. */
diff --git a/gcc/testsuite/gfortran.dg/pr93678.f90
b/gcc/testsuite/gfortran.dg/pr93678.f90
new file mode 100644
index 000..403bedd0c4f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr93678.f90
@@ -0,0 +1,32 @@
+! { dg-do compile }
+! Test the fix for PR93678 in which the charlen for the 'unpackbytes'
+! vtable field was incomplete and caused the ICE as indicated.
+! Contributed by Luis Kornblueh
+!
+! The testcase was reduced by various gfortran regulars.
+module mo_a
+ implicit none
+ type t_b
+integer :: i
+ contains
+procedure :: unpackbytes => b_unpackbytes
+ end type t_b
+contains
+ function b_unpackbytes (me) result (res)
+class(t_b), intent(inout) :: me
+character :: res(1)
+res = char (me%i)
+ end function b_unpackbytes
+ subroutine b_unpackint (me, c)
+class(t_b), intent(inout) :: me
+character, intent(in) :: c
+! print *, b_unpackbytes (me) ! ok
+if (any (me% unpackbytes () .ne. c)) stop 1 ! ICEd here
+ end subroutine b_unpackint
+end module mo_a
+
+ use mo_a
+ class(t_b), allocatable :: z
+ allocate (z, source = t_b(97))
+ call b_unpackint (z, "a")
+end
[gcc r15-46] Fortran: Fix regression caused by r14-9752 [PR114959]
https://gcc.gnu.org/g:bca41a8d55e830c882b0f39246afead4fcfae6f7
commit r15-46-gbca41a8d55e830c882b0f39246afead4fcfae6f7
Author: Paul Thomas
Date: Mon Apr 29 11:52:11 2024 +0100
Fortran: Fix regression caused by r14-9752 [PR114959]
2024-04-29 Paul Thomas
gcc/fortran
PR fortran/114959
* trans-expr.cc (gfc_trans_class_init_assign): Return NULL_TREE
if the default initializer has all NULL fields. Guard this
by a requirement that the code not be EXEC_INIT_ASSIGN and that
the object be an INTENT_OUT dummy.
* trans-stmt.cc (gfc_trans_allocate): Change the initializer
code for allocate with mold to EXEC_ALLOCATE to allow an
initializer with all NULL fields.
gcc/testsuite/
PR fortran/114959
* gfortran.dg/pr114959.f90: New test.
Diff:
---
gcc/fortran/trans-expr.cc | 28 ++--
gcc/fortran/trans-stmt.cc | 5 +++--
gcc/testsuite/gfortran.dg/pr114959.f90 | 33 +
3 files changed, 54 insertions(+), 12 deletions(-)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 072adf3fe77..0280c441ced 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -1720,6 +1720,7 @@ gfc_trans_class_init_assign (gfc_code *code)
gfc_se dst,src,memsz;
gfc_expr *lhs, *rhs, *sz;
gfc_component *cmp;
+ gfc_symbol *sym;
gfc_start_block (&block);
@@ -1736,18 +1737,25 @@ gfc_trans_class_init_assign (gfc_code *code)
/* The _def_init is always scalar. */
rhs->rank = 0;
- /* Check def_init for initializers. If this is a dummy with all default
- initializer components NULL, return NULL_TREE and use the passed value as
- required by F2018(8.5.10). */
- if (!lhs->ref && lhs->symtree->n.sym->attr.dummy)
+ /* Check def_init for initializers. If this is an INTENT(OUT) dummy with all
+ default initializer components NULL, return NULL_TREE and use the passed
+ value as required by F2018(8.5.10). */
+ sym = code->expr1->expr_type == EXPR_VARIABLE ? code->expr1->symtree->n.sym
+ : NULL;
+ if (code->op != EXEC_ALLOCATE
+ && sym && sym->attr.dummy
+ && sym->attr.intent == INTENT_OUT)
{
- cmp = rhs->ref->next->u.c.component->ts.u.derived->components;
- for (; cmp; cmp = cmp->next)
+ if (!lhs->ref && lhs->symtree->n.sym->attr.dummy)
{
- if (cmp->initializer)
- break;
- else if (!cmp->next)
- return build_empty_stmt (input_location);
+ cmp = rhs->ref->next->u.c.component->ts.u.derived->components;
+ for (; cmp; cmp = cmp->next)
+ {
+ if (cmp->initializer)
+ break;
+ else if (!cmp->next)
+ return NULL_TREE;
+ }
}
}
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index c34e0b4c0cd..d355009fa5e 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -7262,11 +7262,12 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist
*omp_allocate)
{
/* Use class_init_assign to initialize expr. */
gfc_code *ini;
- ini = gfc_get_code (EXEC_INIT_ASSIGN);
+ ini = gfc_get_code (EXEC_ALLOCATE);
ini->expr1 = gfc_find_and_cut_at_last_class_ref (expr, true);
tmp = gfc_trans_class_init_assign (ini);
gfc_free_statements (ini);
- gfc_add_expr_to_block (&block, tmp);
+ if (tmp != NULL_TREE)
+ gfc_add_expr_to_block (&block, tmp);
}
else if ((init_expr = allocate_get_initializer (code, expr)))
{
diff --git a/gcc/testsuite/gfortran.dg/pr114959.f90
b/gcc/testsuite/gfortran.dg/pr114959.f90
new file mode 100644
index 000..5cc3c052c1d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr114959.f90
@@ -0,0 +1,33 @@
+! { dg-do compile }
+! { dg-options "-fdump-tree-original" }
+!
+! Fix the regression caused by r14-9752 (fix for PR112407)
+! Contributed by Orion Poplawski
+! Problem isolated by Jakub Jelinek and further
+! reduced here.
+!
+module m
+ type :: smoother_type
+integer :: i
+ end type
+ type :: onelev_type
+class(smoother_type), allocatable :: sm
+class(smoother_type), allocatable :: sm2a
+ end type
+contains
+ subroutine save_smoothers(level,save1, save2)
+Implicit None
+type(onelev_type), intent(inout) :: level
+class(smoother_type), allocatable , intent(inout) :: save1, save2
+integer(4) :: info
+
+info = 0
+! r14-9752 causes the 'stat' declaration from the first ALLOCATE statement
+! to disappear, which triggers an ICE in gimplify_var_or_parm_decl. The
+! second ALLOCATE statement has to be present for the ICE to occur.
+allocate(save1, mold=level%sm,stat=info)
+allocate(save2, mold=level%sm2a,stat=info)
+ end subroutine save_sm
[gcc r14-10560] Fortran: Suppress bogus used uninitialized warnings [PR108889].
https://gcc.gnu.org/g:9906a9863d65386ee4045333eb26a2569783abb5
commit r14-10560-g9906a9863d65386ee4045333eb26a2569783abb5
Author: Paul Thomas
Date: Thu Jul 18 08:51:35 2024 +0100
Fortran: Suppress bogus used uninitialized warnings [PR108889].
2024-07-18 Paul Thomas
gcc/fortran
PR fortran/108889
* gfortran.h: Add bit field 'allocated_in_scope' to gfc_symbol.
* trans-array.cc (gfc_array_allocate): Set 'allocated_in_scope'
after allocation if not a component reference.
(gfc_alloc_allocatable_for_assignment): If 'allocated_in_scope'
not set, not a component ref and not allocated, set the array
bounds and offset to give zero length in all dimensions. Then
set allocated_in_scope.
gcc/testsuite/
PR fortran/108889
* gfortran.dg/pr108889.f90: New test.
(cherry picked from commit c3aa339ea50f050caf7ed2e497f5499ec2d7b9cc)
Diff:
---
gcc/fortran/gfortran.h | 4
gcc/fortran/trans-array.cc | 43 ++
gcc/testsuite/gfortran.dg/pr108889.f90 | 43 ++
3 files changed, 90 insertions(+)
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index de3d9e25911b..fbdf00590bc2 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -1946,6 +1946,10 @@ typedef struct gfc_symbol
/* Set if this should be passed by value, but is not a VALUE argument
according to the Fortran standard. */
unsigned pass_as_value:1;
+ /* Set if an allocatable array variable has been allocated in the current
+ scope. Used in the suppression of uninitialized warnings in reallocation
+ on assignment. */
+ unsigned allocated_in_scope:1;
/* Reference counter, used for memory management.
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 761f0a425078..d5d9c730826e 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -6561,6 +6561,8 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree
status, tree errmsg,
else
gfc_add_expr_to_block (&se->pre, set_descriptor);
+ expr->symtree->n.sym->allocated_in_scope = 1;
+
return true;
}
@@ -10932,6 +10934,8 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop,
stmtblock_t realloc_block;
stmtblock_t alloc_block;
stmtblock_t fblock;
+ stmtblock_t loop_pre_block;
+ gfc_ref *ref;
gfc_ss *rss;
gfc_ss *lss;
gfc_array_info *linfo;
@@ -11132,6 +11136,45 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop,
array1, build_int_cst (TREE_TYPE (array1), 0));
cond_null= gfc_evaluate_now (cond_null, &fblock);
+ /* If the data is null, set the descriptor bounds and offset. This suppresses
+ the maybe used uninitialized warning and forces the use of malloc because
+ the size is zero in all dimensions. Note that this block is only executed
+ if the lhs is unallocated and is only applied once in any namespace.
+ Component references are not subject to the warnings. */
+ for (ref = expr1->ref; ref; ref = ref->next)
+if (ref->type == REF_COMPONENT)
+ break;
+
+ if (!expr1->symtree->n.sym->allocated_in_scope && !ref)
+{
+ gfc_start_block (&loop_pre_block);
+ for (n = 0; n < expr1->rank; n++)
+ {
+ gfc_conv_descriptor_lbound_set (&loop_pre_block, desc,
+ gfc_rank_cst[n],
+ gfc_index_one_node);
+ gfc_conv_descriptor_ubound_set (&loop_pre_block, desc,
+ gfc_rank_cst[n],
+ gfc_index_zero_node);
+ gfc_conv_descriptor_stride_set (&loop_pre_block, desc,
+ gfc_rank_cst[n],
+ gfc_index_zero_node);
+ }
+
+ tmp = gfc_conv_descriptor_offset (desc);
+ gfc_add_modify (&loop_pre_block, tmp, gfc_index_zero_node);
+
+ tmp = fold_build2_loc (input_location, EQ_EXPR,
+logical_type_node, array1,
+build_int_cst (TREE_TYPE (array1), 0));
+ tmp = build3_v (COND_EXPR, tmp,
+ gfc_finish_block (&loop_pre_block),
+ build_empty_stmt (input_location));
+ gfc_prepend_expr_to_block (&loop->pre, tmp);
+
+ expr1->symtree->n.sym->allocated_in_scope = 1;
+}
+
tmp = build3_v (COND_EXPR, cond_null,
build1_v (GOTO_EXPR, jump_label1),
build_empty_stmt (input_location));
diff --git a/gcc/testsuite/gfortran.dg/pr108889.f90
b/gcc/testsuite/gfortran.dg/pr108889.f90
new file mode 100644
index ..7fd4e3882a48
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr108889.f90
@@ -0,0 +1,43 @@
+! { dg-do compile }
+! { dg-options "-Wall -fdump-tree-original" }
+!
+!
[gcc r14-10561] libgomp: Remove bogus warnings from privatized-ref-2.f90.
https://gcc.gnu.org/g:2405d29086d5045821b1a7260b589fbae1e6f05a
commit r14-10561-g2405d29086d5045821b1a7260b589fbae1e6f05a
Author: Paul Thomas
Date: Fri Jul 19 16:58:33 2024 +0100
libgomp: Remove bogus warnings from privatized-ref-2.f90.
2024-07-19 Paul Thomas
libgomp/ChangeLog
* testsuite/libgomp.oacc-fortran/privatized-ref-2.f90: Cut
dg-note about 'a' and remove bogus warnings about its array
descriptor components being used uninitialized.
(cherry picked from commit 8d6994f33a98a168151a57a3d21395b19196cd9d)
Diff:
---
libgomp/testsuite/libgomp.oacc-fortran/privatized-ref-2.f90 | 6 --
1 file changed, 6 deletions(-)
diff --git a/libgomp/testsuite/libgomp.oacc-fortran/privatized-ref-2.f90
b/libgomp/testsuite/libgomp.oacc-fortran/privatized-ref-2.f90
index 498ef70b63a4..8cf79a10e8d2 100644
--- a/libgomp/testsuite/libgomp.oacc-fortran/privatized-ref-2.f90
+++ b/libgomp/testsuite/libgomp.oacc-fortran/privatized-ref-2.f90
@@ -29,16 +29,10 @@ program main
implicit none (type, external)
integer :: j
integer, allocatable :: A(:)
- ! { dg-note {'a' declared here} {} { target *-*-* } .-1 }
character(len=:), allocatable :: my_str
character(len=15), allocatable :: my_str15
A = [(3*j, j=1, 10)]
- ! { dg-bogus {'a\.offset' is used uninitialized} {PR77504 etc.} { xfail
*-*-* } .-1 }
- ! { dg-bogus {'a\.dim\[0\]\.lbound' is used uninitialized} {PR77504 etc.} {
xfail *-*-* } .-2 }
- ! { dg-bogus {'a\.dim\[0\]\.ubound' is used uninitialized} {PR77504 etc.} {
xfail *-*-* } .-3 }
- ! { dg-bogus {'a\.dim\[0\]\.lbound' may be used uninitialized} {PR77504
etc.} { xfail { ! __OPTIMIZE__ } } .-4 }
- ! { dg-bogus {'a\.dim\[0\]\.ubound' may be used uninitialized} {PR77504
etc.} { xfail { ! __OPTIMIZE__ } } .-5 }
call foo (A, size(A))
call bar (A)
my_str = "1234567890"
[gcc r13-8959] Fortran: Suppress bogus used uninitialized warnings [PR108889].
https://gcc.gnu.org/g:7195144e39e404ec712ca5401f2328c14d5020eb
commit r13-8959-g7195144e39e404ec712ca5401f2328c14d5020eb
Author: Paul Thomas
Date: Thu Jul 18 08:51:35 2024 +0100
Fortran: Suppress bogus used uninitialized warnings [PR108889].
2024-07-18 Paul Thomas
gcc/fortran
PR fortran/108889
* gfortran.h: Add bit field 'allocated_in_scope' to gfc_symbol.
* trans-array.cc (gfc_array_allocate): Set 'allocated_in_scope'
after allocation if not a component reference.
(gfc_alloc_allocatable_for_assignment): If 'allocated_in_scope'
not set, not a component ref and not allocated, set the array
bounds and offset to give zero length in all dimensions. Then
set allocated_in_scope.
gcc/testsuite/
PR fortran/108889
* gfortran.dg/pr108889.f90: New test.
(cherry picked from commit c3aa339ea50f050caf7ed2e497f5499ec2d7b9cc)
Diff:
---
gcc/fortran/gfortran.h | 4
gcc/fortran/trans-array.cc | 43 ++
gcc/testsuite/gfortran.dg/pr108889.f90 | 43 ++
3 files changed, 90 insertions(+)
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index c1430f7dfeca..c710945f1013 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -1927,6 +1927,10 @@ typedef struct gfc_symbol
/* Set if this should be passed by value, but is not a VALUE argument
according to the Fortran standard. */
unsigned pass_as_value:1;
+ /* Set if an allocatable array variable has been allocated in the current
+ scope. Used in the suppression of uninitialized warnings in reallocation
+ on assignment. */
+ unsigned allocated_in_scope:1;
int refs;
struct gfc_namespace *ns;/* namespace containing this symbol */
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 4d42cf1131aa..eecb342f32af 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -6341,6 +6341,8 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree
status, tree errmsg,
else
gfc_add_expr_to_block (&se->pre, set_descriptor);
+ expr->symtree->n.sym->allocated_in_scope = 1;
+
return true;
}
@@ -10645,6 +10647,8 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop,
stmtblock_t realloc_block;
stmtblock_t alloc_block;
stmtblock_t fblock;
+ stmtblock_t loop_pre_block;
+ gfc_ref *ref;
gfc_ss *rss;
gfc_ss *lss;
gfc_array_info *linfo;
@@ -10845,6 +10849,45 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop,
array1, build_int_cst (TREE_TYPE (array1), 0));
cond_null= gfc_evaluate_now (cond_null, &fblock);
+ /* If the data is null, set the descriptor bounds and offset. This suppresses
+ the maybe used uninitialized warning and forces the use of malloc because
+ the size is zero in all dimensions. Note that this block is only executed
+ if the lhs is unallocated and is only applied once in any namespace.
+ Component references are not subject to the warnings. */
+ for (ref = expr1->ref; ref; ref = ref->next)
+if (ref->type == REF_COMPONENT)
+ break;
+
+ if (!expr1->symtree->n.sym->allocated_in_scope && !ref)
+{
+ gfc_start_block (&loop_pre_block);
+ for (n = 0; n < expr1->rank; n++)
+ {
+ gfc_conv_descriptor_lbound_set (&loop_pre_block, desc,
+ gfc_rank_cst[n],
+ gfc_index_one_node);
+ gfc_conv_descriptor_ubound_set (&loop_pre_block, desc,
+ gfc_rank_cst[n],
+ gfc_index_zero_node);
+ gfc_conv_descriptor_stride_set (&loop_pre_block, desc,
+ gfc_rank_cst[n],
+ gfc_index_zero_node);
+ }
+
+ tmp = gfc_conv_descriptor_offset (desc);
+ gfc_add_modify (&loop_pre_block, tmp, gfc_index_zero_node);
+
+ tmp = fold_build2_loc (input_location, EQ_EXPR,
+logical_type_node, array1,
+build_int_cst (TREE_TYPE (array1), 0));
+ tmp = build3_v (COND_EXPR, tmp,
+ gfc_finish_block (&loop_pre_block),
+ build_empty_stmt (input_location));
+ gfc_prepend_expr_to_block (&loop->pre, tmp);
+
+ expr1->symtree->n.sym->allocated_in_scope = 1;
+}
+
tmp = build3_v (COND_EXPR, cond_null,
build1_v (GOTO_EXPR, jump_label1),
build_empty_stmt (input_location));
diff --git a/gcc/testsuite/gfortran.dg/pr108889.f90
b/gcc/testsuite/gfortran.dg/pr108889.f90
new file mode 100644
index ..7fd4e3882a48
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr108889.f90
@@ -0,0 +1,43 @@
+! { dg-do compile }
+! { dg-options "-Wall -
[gcc r13-8960] libgomp: Remove bogus warnings from privatized-ref-2.f90.
https://gcc.gnu.org/g:bf0673ef66a6dd8a000c6fb882a206c1cef639c7
commit r13-8960-gbf0673ef66a6dd8a000c6fb882a206c1cef639c7
Author: Paul Thomas
Date: Fri Jul 19 16:58:33 2024 +0100
libgomp: Remove bogus warnings from privatized-ref-2.f90.
2024-07-19 Paul Thomas
libgomp/ChangeLog
* testsuite/libgomp.oacc-fortran/privatized-ref-2.f90: Cut
dg-note about 'a' and remove bogus warnings about its array
descriptor components being used uninitialized.
(cherry picked from commit 8d6994f33a98a168151a57a3d21395b19196cd9d)
Diff:
---
libgomp/testsuite/libgomp.oacc-fortran/privatized-ref-2.f90 | 6 --
1 file changed, 6 deletions(-)
diff --git a/libgomp/testsuite/libgomp.oacc-fortran/privatized-ref-2.f90
b/libgomp/testsuite/libgomp.oacc-fortran/privatized-ref-2.f90
index 498ef70b63a4..8cf79a10e8d2 100644
--- a/libgomp/testsuite/libgomp.oacc-fortran/privatized-ref-2.f90
+++ b/libgomp/testsuite/libgomp.oacc-fortran/privatized-ref-2.f90
@@ -29,16 +29,10 @@ program main
implicit none (type, external)
integer :: j
integer, allocatable :: A(:)
- ! { dg-note {'a' declared here} {} { target *-*-* } .-1 }
character(len=:), allocatable :: my_str
character(len=15), allocatable :: my_str15
A = [(3*j, j=1, 10)]
- ! { dg-bogus {'a\.offset' is used uninitialized} {PR77504 etc.} { xfail
*-*-* } .-1 }
- ! { dg-bogus {'a\.dim\[0\]\.lbound' is used uninitialized} {PR77504 etc.} {
xfail *-*-* } .-2 }
- ! { dg-bogus {'a\.dim\[0\]\.ubound' is used uninitialized} {PR77504 etc.} {
xfail *-*-* } .-3 }
- ! { dg-bogus {'a\.dim\[0\]\.lbound' may be used uninitialized} {PR77504
etc.} { xfail { ! __OPTIMIZE__ } } .-4 }
- ! { dg-bogus {'a\.dim\[0\]\.ubound' may be used uninitialized} {PR77504
etc.} { xfail { ! __OPTIMIZE__ } } .-5 }
call foo (A, size(A))
call bar (A)
my_str = "1234567890"
[gcc r12-10657] Fortran: Suppress bogus used uninitialized warnings [PR108889].
https://gcc.gnu.org/g:0e945f6e8849ae4722ea7ac70d713f7b35d3fade
commit r12-10657-g0e945f6e8849ae4722ea7ac70d713f7b35d3fade
Author: Paul Thomas
Date: Thu Jul 18 08:51:35 2024 +0100
Fortran: Suppress bogus used uninitialized warnings [PR108889].
2024-07-18 Paul Thomas
gcc/fortran
PR fortran/108889
* gfortran.h: Add bit field 'allocated_in_scope' to gfc_symbol.
* trans-array.cc (gfc_array_allocate): Set 'allocated_in_scope'
after allocation if not a component reference.
(gfc_alloc_allocatable_for_assignment): If 'allocated_in_scope'
not set, not a component ref and not allocated, set the array
bounds and offset to give zero length in all dimensions. Then
set allocated_in_scope.
gcc/testsuite/
PR fortran/108889
* gfortran.dg/pr108889.f90: New test.
(cherry picked from commit c3aa339ea50f050caf7ed2e497f5499ec2d7b9cc)
Diff:
---
gcc/fortran/gfortran.h | 4
gcc/fortran/trans-array.cc | 43 ++
gcc/testsuite/gfortran.dg/pr108889.f90 | 43 ++
3 files changed, 90 insertions(+)
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 0b0a8fe71180..7162f39f39c4 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -1887,6 +1887,10 @@ typedef struct gfc_symbol
/* Set if this should be passed by value, but is not a VALUE argument
according to the Fortran standard. */
unsigned pass_as_value:1;
+ /* Set if an allocatable array variable has been allocated in the current
+ scope. Used in the suppression of uninitialized warnings in reallocation
+ on assignment. */
+ unsigned allocated_in_scope:1;
int refs;
struct gfc_namespace *ns;/* namespace containing this symbol */
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 85c641b55c52..59668177bbf7 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -6285,6 +6285,8 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree
status, tree errmsg,
else
gfc_add_expr_to_block (&se->pre, set_descriptor);
+ expr->symtree->n.sym->allocated_in_scope = 1;
+
return true;
}
@@ -10509,6 +10511,8 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop,
stmtblock_t realloc_block;
stmtblock_t alloc_block;
stmtblock_t fblock;
+ stmtblock_t loop_pre_block;
+ gfc_ref *ref;
gfc_ss *rss;
gfc_ss *lss;
gfc_array_info *linfo;
@@ -10717,6 +10721,45 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop,
else
cond_null= gfc_evaluate_now (cond_null, &fblock);
+ /* If the data is null, set the descriptor bounds and offset. This suppresses
+ the maybe used uninitialized warning and forces the use of malloc because
+ the size is zero in all dimensions. Note that this block is only executed
+ if the lhs is unallocated and is only applied once in any namespace.
+ Component references are not subject to the warnings. */
+ for (ref = expr1->ref; ref; ref = ref->next)
+if (ref->type == REF_COMPONENT)
+ break;
+
+ if (!expr1->symtree->n.sym->allocated_in_scope && !ref)
+{
+ gfc_start_block (&loop_pre_block);
+ for (n = 0; n < expr1->rank; n++)
+ {
+ gfc_conv_descriptor_lbound_set (&loop_pre_block, desc,
+ gfc_rank_cst[n],
+ gfc_index_one_node);
+ gfc_conv_descriptor_ubound_set (&loop_pre_block, desc,
+ gfc_rank_cst[n],
+ gfc_index_zero_node);
+ gfc_conv_descriptor_stride_set (&loop_pre_block, desc,
+ gfc_rank_cst[n],
+ gfc_index_zero_node);
+ }
+
+ tmp = gfc_conv_descriptor_offset (desc);
+ gfc_add_modify (&loop_pre_block, tmp, gfc_index_zero_node);
+
+ tmp = fold_build2_loc (input_location, EQ_EXPR,
+logical_type_node, array1,
+build_int_cst (TREE_TYPE (array1), 0));
+ tmp = build3_v (COND_EXPR, tmp,
+ gfc_finish_block (&loop_pre_block),
+ build_empty_stmt (input_location));
+ gfc_prepend_expr_to_block (&loop->pre, tmp);
+
+ expr1->symtree->n.sym->allocated_in_scope = 1;
+}
+
tmp = build3_v (COND_EXPR, cond_null,
build1_v (GOTO_EXPR, jump_label1),
build_empty_stmt (input_location));
diff --git a/gcc/testsuite/gfortran.dg/pr108889.f90
b/gcc/testsuite/gfortran.dg/pr108889.f90
new file mode 100644
index ..7fd4e3882a48
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr108889.f90
@@ -0,0 +1,43 @@
+! { dg-do compile }
+! { dg-options "-Wall -fdump-tree-original" }
+!
+! Contributed by Tobias Burnus
+!
[gcc r12-10658] libgomp: Remove bogus warnings from privatized-ref-2.f90.
https://gcc.gnu.org/g:3f356a88d6c15d0ea93a5191c23b668744254f72
commit r12-10658-g3f356a88d6c15d0ea93a5191c23b668744254f72
Author: Paul Thomas
Date: Fri Jul 19 16:58:33 2024 +0100
libgomp: Remove bogus warnings from privatized-ref-2.f90.
2024-07-19 Paul Thomas
libgomp/ChangeLog
* testsuite/libgomp.oacc-fortran/privatized-ref-2.f90: Cut
dg-note about 'a' and remove bogus warnings about its array
descriptor components being used uninitialized.
(cherry picked from commit 8d6994f33a98a168151a57a3d21395b19196cd9d)
Diff:
---
libgomp/testsuite/libgomp.oacc-fortran/privatized-ref-2.f90 | 6 --
1 file changed, 6 deletions(-)
diff --git a/libgomp/testsuite/libgomp.oacc-fortran/privatized-ref-2.f90
b/libgomp/testsuite/libgomp.oacc-fortran/privatized-ref-2.f90
index 498ef70b63a4..8cf79a10e8d2 100644
--- a/libgomp/testsuite/libgomp.oacc-fortran/privatized-ref-2.f90
+++ b/libgomp/testsuite/libgomp.oacc-fortran/privatized-ref-2.f90
@@ -29,16 +29,10 @@ program main
implicit none (type, external)
integer :: j
integer, allocatable :: A(:)
- ! { dg-note {'a' declared here} {} { target *-*-* } .-1 }
character(len=:), allocatable :: my_str
character(len=15), allocatable :: my_str15
A = [(3*j, j=1, 10)]
- ! { dg-bogus {'a\.offset' is used uninitialized} {PR77504 etc.} { xfail
*-*-* } .-1 }
- ! { dg-bogus {'a\.dim\[0\]\.lbound' is used uninitialized} {PR77504 etc.} {
xfail *-*-* } .-2 }
- ! { dg-bogus {'a\.dim\[0\]\.ubound' is used uninitialized} {PR77504 etc.} {
xfail *-*-* } .-3 }
- ! { dg-bogus {'a\.dim\[0\]\.lbound' may be used uninitialized} {PR77504
etc.} { xfail { ! __OPTIMIZE__ } } .-4 }
- ! { dg-bogus {'a\.dim\[0\]\.ubound' may be used uninitialized} {PR77504
etc.} { xfail { ! __OPTIMIZE__ } } .-5 }
call foo (A, size(A))
call bar (A)
my_str = "1234567890"
[gcc r15-2739] Fortran: Fix class transformational intrinsic calls [PR102689]
https://gcc.gnu.org/g:4cb07a38233aadb4b389a6e5236c95f52241b6e0
commit r15-2739-g4cb07a38233aadb4b389a6e5236c95f52241b6e0
Author: Paul Thomas
Date: Tue Aug 6 06:42:27 2024 +0100
Fortran: Fix class transformational intrinsic calls [PR102689]
2024-08-06 Paul Thomas
gcc/fortran
PR fortran/102689
* trans-array.cc (get_array_ref_dim_for_loop_dim): Use the arg1
class container carried in ss->info as the seed for a lhs in
class valued transformational intrinsic calls that are not the
rhs of an assignment. Otherwise, the lhs variable expression is
taken from the loop chain. For this latter case, the _vptr and
_len fields are set.
(gfc_trans_create_temp_array): Use either the lhs expression
seeds to build a class variable that will take the returned
descriptor as its _data field. In the case that the arg1 expr.
is used, a class typespec must be built with the correct rank
and the _vptr and _len fields set. The element size is provided
for the temporary allocation and to set the descriptor span.
(gfc_array_init_size): When an intrinsic type scalar expr3 is
used in allocation of a class array, use its element size in
the descriptor dtype.
* trans-expr.cc (gfc_conv_class_to_class): Class valued
transformational intrinsics return the pointer to the array
descriptor as the _data field of a class temporary. Extract
directly and return the address of the class temporary.
(gfc_conv_procedure_call): store the expression for the first
argument of a class valued transformational intrinsic function
in the ss info class_container field. Later, use its type as
the element type in the call to gfc_trans_create_temp_array.
(fcncall_realloc_result): Add a dtype argument and use it in
the descriptor, when available.
(gfc_trans_arrayfunc_assign): For class lhs, build a dtype with
the lhs rank and the rhs element size and use it in the call to
fcncall_realloc_result.
gcc/testsuite/
PR fortran/102689
* gfortran.dg/class_transformational_1.f90: New test for class-
valued reshape.
* gfortran.dg/class_transformational_2.f90: New test for other
class_valued transformational intrinsics.
Diff:
---
gcc/fortran/trans-array.cc | 146 ---
gcc/fortran/trans-expr.cc | 57 +-
.../gfortran.dg/class_transformational_1.f90 | 204 +
.../gfortran.dg/class_transformational_2.f90 | 103 +++
4 files changed, 475 insertions(+), 35 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index c93a5f1e7543..9fb0b2b398d2 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1301,23 +1301,28 @@ get_array_ref_dim_for_loop_dim (gfc_ss *ss, int
loop_dim)
is a class expression. */
static tree
-get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype)
+get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype,
+ gfc_ss **fcnss)
{
+ gfc_ss *loop_ss = ss->loop->ss;
gfc_ss *lhs_ss;
gfc_ss *rhs_ss;
+ gfc_ss *fcn_ss = NULL;
tree tmp;
tree tmp2;
tree vptr;
- tree rhs_class_expr = NULL_TREE;
+ tree class_expr = NULL_TREE;
tree lhs_class_expr = NULL_TREE;
bool unlimited_rhs = false;
bool unlimited_lhs = false;
bool rhs_function = false;
+ bool unlimited_arg1 = false;
gfc_symbol *vtab;
+ tree cntnr = NULL_TREE;
/* The second element in the loop chain contains the source for the
- temporary; ie. the rhs of the assignment. */
- rhs_ss = ss->loop->ss->loop_chain;
+ class temporary created in gfc_trans_create_temp_array. */
+ rhs_ss = loop_ss->loop_chain;
if (rhs_ss != gfc_ss_terminator
&& rhs_ss->info
@@ -1326,28 +1331,58 @@ get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss,
tree *eltype)
&& rhs_ss->info->data.array.descriptor)
{
if (rhs_ss->info->expr->expr_type != EXPR_VARIABLE)
- rhs_class_expr
+ class_expr
= gfc_get_class_from_expr (rhs_ss->info->data.array.descriptor);
else
- rhs_class_expr = gfc_get_class_from_gfc_expr (rhs_ss->info->expr);
+ class_expr = gfc_get_class_from_gfc_expr (rhs_ss->info->expr);
unlimited_rhs = UNLIMITED_POLY (rhs_ss->info->expr);
if (rhs_ss->info->expr->expr_type == EXPR_FUNCTION)
rhs_function = true;
}
+ /* Usually, ss points to the function. When the function call is an actual
+ argument, it is instead rhs_ss because the ss chain is shifted by one. */
+ *fcnss = fcn_ss = rhs_function ? rhs_ss : ss;
+
+ /* If this is a transformational
[gcc r15-788] Fortran: Fix ICEs due to comp calls in initialization exprs [PR103312]
https://gcc.gnu.org/g:2ce90517ed75c4af9fc0616f2670cf6dfcfa8a91
commit r15-788-g2ce90517ed75c4af9fc0616f2670cf6dfcfa8a91
Author: Paul Thomas
Date: Thu May 23 07:59:46 2024 +0100
Fortran: Fix ICEs due to comp calls in initialization exprs [PR103312]
2024-05-23 Paul Thomas
gcc/fortran
PR fortran/103312
* dependency.cc (gfc_dep_compare_expr): Handle component call
expressions. Return -2 as default and return 0 if compared with
a function expression that is from an interface body and has
the same name.
* expr.cc (gfc_reduce_init_expr): If the expression is a comp
call do not attempt to reduce, defer to resolution and return
false.
* trans-types.cc (gfc_get_dtype_rank_type,
gfc_get_nodesc_array_type): Fix whitespace.
gcc/testsuite/
PR fortran/103312
* gfortran.dg/pr103312.f90: New test.
Diff:
---
gcc/fortran/dependency.cc | 32 +
gcc/fortran/expr.cc| 5 ++
gcc/fortran/trans-types.cc | 4 +-
gcc/testsuite/gfortran.dg/pr103312.f90 | 87 ++
4 files changed, 126 insertions(+), 2 deletions(-)
diff --git a/gcc/fortran/dependency.cc b/gcc/fortran/dependency.cc
index fb4d94de641..bafe8cbc5bc 100644
--- a/gcc/fortran/dependency.cc
+++ b/gcc/fortran/dependency.cc
@@ -440,6 +440,38 @@ gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2)
return mpz_sgn (e2->value.op.op2->value.integer);
}
+
+ if (e1->expr_type == EXPR_COMPCALL)
+{
+ /* This will have emerged from interface.cc(gfc_check_typebound_override)
+via gfc_check_result_characteristics. It is possible that other
+variants exist that are 'equal' but play it safe for now by setting
+the relationship as 'indeterminate'. */
+ if (e2->expr_type == EXPR_FUNCTION && e2->ref)
+ {
+ gfc_ref *ref = e2->ref;
+ gfc_symbol *s = NULL;
+
+ if (e1->value.compcall.tbp->u.specific)
+ s = e1->value.compcall.tbp->u.specific->n.sym;
+
+ /* Check if the proc ptr points to an interface declaration and the
+names are the same; ie. the overriden proc. of an abstract type.
+The checking of the arguments will already have been done. */
+ for (; ref && s; ref = ref->next)
+ if (!ref->next && ref->type == REF_COMPONENT
+ && ref->u.c.component->attr.proc_pointer
+ && ref->u.c.component->ts.interface
+ && ref->u.c.component->ts.interface->attr.if_source
+ == IFSRC_IFBODY
+ && !strcmp (s->name, ref->u.c.component->name))
+ return 0;
+ }
+
+ /* Assume as default that TKR checking is sufficient. */
+ return -2;
+ }
+
if (e1->expr_type != e2->expr_type)
return -3;
diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc
index c883966646c..a162744c719 100644
--- a/gcc/fortran/expr.cc
+++ b/gcc/fortran/expr.cc
@@ -3210,6 +3210,11 @@ gfc_reduce_init_expr (gfc_expr *expr)
{
bool t;
+ /* It is far too early to resolve a class compcall. Punt to resolution. */
+ if (expr && expr->expr_type == EXPR_COMPCALL
+ && expr->symtree->n.sym->ts.type == BT_CLASS)
+return false;
+
gfc_init_expr_flag = true;
t = gfc_resolve_expr (expr);
if (t)
diff --git a/gcc/fortran/trans-types.cc b/gcc/fortran/trans-types.cc
index 676014e9b98..8466c595e06 100644
--- a/gcc/fortran/trans-types.cc
+++ b/gcc/fortran/trans-types.cc
@@ -1591,7 +1591,7 @@ gfc_get_dtype_rank_type (int rank, tree etype)
size = size_in_bytes (etype);
break;
}
-
+
gcc_assert (size);
STRIP_NOPS (size);
@@ -1740,7 +1740,7 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec *
as, gfc_packed packed,
tmp = gfc_conv_mpz_to_tree (expr->value.integer,
gfc_index_integer_kind);
else
- tmp = NULL_TREE;
+ tmp = NULL_TREE;
GFC_TYPE_ARRAY_LBOUND (type, n) = tmp;
expr = as->upper[n];
diff --git a/gcc/testsuite/gfortran.dg/pr103312.f90
b/gcc/testsuite/gfortran.dg/pr103312.f90
new file mode 100644
index 000..deacc70bf5d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr103312.f90
@@ -0,0 +1,87 @@
+! { dg-do run }
+!
+! Test the fix for pr103312, in which the use of a component call in
+! initialization expressions, eg. character(this%size()), caused ICEs.
+!
+! Contributed by Arseny Solokha
+!
+module example
+
+ type, abstract :: foo
+integer :: i
+ contains
+procedure(foo_size), deferred :: size
+procedure(foo_func), deferred :: func
+ end type
+
+ interface
+function foo_func (this) result (string)
+ import :: foo
+ class(foo) :: this
+ character(this%size()) :: string
+end function
+pure integer function foo_size (this)
+
[gcc r15-1468] Fortran: Auto array allocation with function dependencies [PR59104]
https://gcc.gnu.org/g:ccaa39a268bef2a1d8880022696ff2dcaa6af941
commit r15-1468-gccaa39a268bef2a1d8880022696ff2dcaa6af941
Author: Paul Thomas
Date: Thu Jun 20 08:01:36 2024 +0100
Fortran: Auto array allocation with function dependencies [PR59104]
2024-06-20 Paul Thomas
gcc/fortran
PR fortran/59104
* dependency.cc (dependency_fcn, gfc_function_dependency): New
functions to detect dependency in array bounds and character
lengths on old style function results.
* dependency.h : Add prototype for gfc_function_dependency.
* error.cc (error_print): Remove trailing space.
* gfortran.h : Remove dummy_order and add fn_result_spec.
* symbol.cc : Remove declaration of next_dummy_order..
(gfc_set_sym_referenced): remove setting of symbol dummy order.
* trans-array.cc (gfc_trans_auto_array_allocation): Detect
non-dummy symbols with function dependencies and put the
allocation at the end of the initialization code.
* trans-decl.cc : Include dependency.h.
(decl_order): New function that determines uses the location
field of the symbol 'declared_at' to determine the order of two
declarations.
(gfc_defer_symbol_init): Call gfc_function_dependency to put
dependent symbols in the right part of the tlink chain. Use
the location field of the symbol declared_at to determine the
order of declarations.
(gfc_trans_auto_character_variable): Put character length
initialization of dependent symbols at the end of the chain.
* trans.cc (gfc_add_init_cleanup): Add boolean argument with
default false that determines whther an expression is placed at
the back or the front of the initialization chain.
* trans.h : Update the prototype for gfc_add_init_cleanup.
gcc/testsuite/
PR fortran/59104
* gfortran.dg/dependent_decls_2.f90: New test.
Diff:
---
gcc/fortran/dependency.cc | 82 +++
gcc/fortran/dependency.h| 4 +-
gcc/fortran/error.cc| 2 +-
gcc/fortran/gfortran.h | 6 +-
gcc/fortran/symbol.cc | 10 ---
gcc/fortran/trans-array.cc | 15 -
gcc/fortran/trans-decl.cc | 51 --
gcc/fortran/trans.cc| 5 +-
gcc/fortran/trans.h | 3 +-
gcc/testsuite/gfortran.dg/dependent_decls_2.f90 | 89 +
10 files changed, 238 insertions(+), 29 deletions(-)
diff --git a/gcc/fortran/dependency.cc b/gcc/fortran/dependency.cc
index bafe8cbc5bc3..15edf1af9dff 100644
--- a/gcc/fortran/dependency.cc
+++ b/gcc/fortran/dependency.cc
@@ -2497,3 +2497,85 @@ gfc_omp_expr_prefix_same (gfc_expr *lexpr, gfc_expr
*rexpr)
return true;
}
+
+
+/* gfc_function_dependency returns true for non-dummy symbols with dependencies
+ on an old-fashioned function result (ie. proc_name = proc_name->result).
+ This is used to ensure that initialization code appears after the function
+ result is treated and that any mutual dependencies between these symbols are
+ respected. */
+
+static bool
+dependency_fcn (gfc_expr *e, gfc_symbol *sym,
+int *f ATTRIBUTE_UNUSED)
+{
+ if (e == NULL)
+return false;
+
+ if (e && e->expr_type == EXPR_VARIABLE)
+{
+ if (e->symtree && e->symtree->n.sym == sym)
+ return true;
+ /* Recurse to see if this symbol is dependent on the function result. If
+so an indirect dependence exists, which should be handled in the same
+way as a direct dependence. The recursion is prevented from being
+infinite by statement order. */
+ else if (e->symtree && e->symtree->n.sym)
+ return gfc_function_dependency (e->symtree->n.sym, sym);
+}
+
+ return false;
+}
+
+
+bool
+gfc_function_dependency (gfc_symbol *sym, gfc_symbol *proc_name)
+{
+ bool dep = false;
+
+ if (proc_name && proc_name->attr.function
+ && proc_name == proc_name->result
+ && !(sym->attr.dummy || sym->attr.result))
+{
+ if (sym->fn_result_dep)
+ return true;
+
+ if (sym->as && sym->as->type == AS_EXPLICIT)
+ {
+ for (int dim = 0; dim < sym->as->rank; dim++)
+ {
+ if (sym->as->lower[dim]
+ && sym->as->lower[dim]->expr_type != EXPR_CONSTANT)
+ dep = gfc_traverse_expr (sym->as->lower[dim], proc_name,
+dependency_fcn, 0);
+ if (dep)
+ {
+ sym->fn_result_dep = 1;
+ return true;
+ }
+ if (sym->as->upper[dim]
+ && sym->as->upper[dim]->expr_typ
[gcc r14-10886] Fortran: Fix regressions with intent(out) class[PR115070, PR115348].
https://gcc.gnu.org/g:c16e4ecd8fdc2230a313fe795333fa97652ba19f
commit r14-10886-gc16e4ecd8fdc2230a313fe795333fa97652ba19f
Author: Paul Thomas
Date: Tue Nov 5 15:54:45 2024 +
Fortran: Fix regressions with intent(out) class[PR115070, PR115348].
2024-11-05 Paul Thomas
gcc/fortran
PR fortran/115070
PR fortran/115348
* trans-expr.cc (gfc_trans_class_init_assign): If all the
components of the default initializer are null for a scalar,
build an empty statement to prevent prior declarations from
disappearing.
gcc/testsuite/
PR fortran/115070
* gfortran.dg/ieee/pr115070.f90: New test.
PR fortran/115348
* gfortran.dg/pr115348.f90: New test.
Diff:
---
gcc/fortran/trans-expr.cc | 29 ++--
gcc/testsuite/gfortran.dg/ieee/pr115070.f90 | 28 +++
gcc/testsuite/gfortran.dg/pr115348.f90 | 35 +
3 files changed, 80 insertions(+), 12 deletions(-)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 3a5a41401858..f182ea2ee1cd 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -1723,10 +1723,12 @@ gfc_trans_class_init_assign (gfc_code *code)
{
stmtblock_t block;
tree tmp;
+ bool cmp_flag = true;
gfc_se dst,src,memsz;
gfc_expr *lhs, *rhs, *sz;
gfc_component *cmp;
gfc_symbol *sym;
+ gfc_ref *ref;
gfc_start_block (&block);
@@ -1744,24 +1746,25 @@ gfc_trans_class_init_assign (gfc_code *code)
rhs->rank = 0;
/* Check def_init for initializers. If this is an INTENT(OUT) dummy with all
- default initializer components NULL, return NULL_TREE and use the passed
- value as required by F2018(8.5.10). */
+ default initializer components NULL, use the passed value even though
+ F2018(8.5.10) asserts that it should considered to be undefined. This is
+ needed for consistency with other brands. */
sym = code->expr1->expr_type == EXPR_VARIABLE ? code->expr1->symtree->n.sym
: NULL;
if (code->op != EXEC_ALLOCATE
&& sym && sym->attr.dummy
&& sym->attr.intent == INTENT_OUT)
{
- if (!lhs->ref && lhs->symtree->n.sym->attr.dummy)
+ ref = rhs->ref;
+ while (ref && ref->next)
+ ref = ref->next;
+ cmp = ref->u.c.component->ts.u.derived->components;
+ for (; cmp; cmp = cmp->next)
{
- cmp = rhs->ref->next->u.c.component->ts.u.derived->components;
- for (; cmp; cmp = cmp->next)
- {
- if (cmp->initializer)
- break;
- else if (!cmp->next)
- return NULL_TREE;
- }
+ if (cmp->initializer)
+ break;
+ else if (!cmp->next)
+ cmp_flag = false;
}
}
@@ -1775,7 +1778,7 @@ gfc_trans_class_init_assign (gfc_code *code)
gfc_add_full_array_ref (lhs, tmparr);
tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
}
- else
+ else if (cmp_flag)
{
/* Scalar initialization needs the _data component. */
gfc_add_data_component (lhs);
@@ -1805,6 +1808,8 @@ gfc_trans_class_init_assign (gfc_code *code)
tmp, build_empty_stmt (input_location));
}
}
+ else
+tmp = build_empty_stmt (input_location);
if (code->expr1->symtree->n.sym->attr.dummy
&& (code->expr1->symtree->n.sym->attr.optional
diff --git a/gcc/testsuite/gfortran.dg/ieee/pr115070.f90
b/gcc/testsuite/gfortran.dg/ieee/pr115070.f90
new file mode 100644
index ..9378f770e2c6
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/ieee/pr115070.f90
@@ -0,0 +1,28 @@
+! { dg-do compile }
+!
+! Test the fix for PR115070
+!
+! Contributed by Sebastien Bardeau
+!
+module my_mod
+ type my_type
+integer :: a
+ contains
+final :: myfinal
+ end type my_type
+contains
+ subroutine my_sub(obs)
+use ieee_arithmetic
+class(my_type), intent(out) :: obs
+ end subroutine my_sub
+ subroutine myfinal (arg)
+type (my_type) :: arg
+print *, arg%a
+ end
+end module my_mod
+
+ use my_mod
+ type (my_type) :: z
+ z%a = 42
+ call my_sub (z)
+end
diff --git a/gcc/testsuite/gfortran.dg/pr115348.f90
b/gcc/testsuite/gfortran.dg/pr115348.f90
new file mode 100644
index ..bc644b2f1c0c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr115348.f90
@@ -0,0 +1,35 @@
+! { dg-do compile }
+! { dg-options "-fcheck=recursion" }
+!
+! Test the fix for pr115348.
+!
+! Contributed by Maxime van den Bossche
+!
+module mymodule
+implicit none
+
+type mytype
+integer :: mynumber
+contains
+procedure :: myroutine
+end type mytype
+
+contains
+
+subroutine myroutine(self)
+class(mytype), intent(out) :: self
+
+self%mynumber = 1
+end subroutine myroutine
+end
[gcc r15-4869] Fortran: Fix associate_69.f90 that fails on some platforms [PR115700]
https://gcc.gnu.org/g:4ed02814c2191d5febe0972c3e43c80c004f4799
commit r15-4869-g4ed02814c2191d5febe0972c3e43c80c004f4799
Author: Paul Thomas
Date: Sun Nov 3 18:02:16 2024 +
Fortran: Fix associate_69.f90 that fails on some platforms [PR115700]
2024-11-03 Paul Thomas
gcc/testsuite/
PR fortran/115700
* gfortran.dg/associate_69.f90: Remove the test that produces a
variable string length because the optimized count depends on
the platform. This is tested in associate_70.f90.
Diff:
---
gcc/testsuite/gfortran.dg/associate_69.f90 | 5 -
1 file changed, 5 deletions(-)
diff --git a/gcc/testsuite/gfortran.dg/associate_69.f90
b/gcc/testsuite/gfortran.dg/associate_69.f90
index 35db417867d4..3839718e7f0e 100644
--- a/gcc/testsuite/gfortran.dg/associate_69.f90
+++ b/gcc/testsuite/gfortran.dg/associate_69.f90
@@ -30,11 +30,6 @@ subroutine mvce(x)
associate (tmp5 => x(1:)(1:))
if (len (tmp5) /= len (x)) stop 5
end associate
-
- associate (temp6 => x(:)(1:i/2))
-if (len (temp6) /= i/2) stop 6
- end associate
end
! { dg-final { scan-tree-dump-not " \\.tmp" "optimized" } }
-! { dg-final { scan-tree-dump-times " \\.temp6" 7 "optimized" } }
[gcc r13-9165] Fortran: Fix regression in 13-branch due to pr113363.f90 [PR116040]
https://gcc.gnu.org/g:3937e01b4eba511a4a5fd2bcd0c81c62fe3ec68a
commit r13-9165-g3937e01b4eba511a4a5fd2bcd0c81c62fe3ec68a
Author: Paul Thomas
Date: Sun Nov 3 15:45:32 2024 +
Fortran: Fix regression in 13-branch due to pr113363.f90 [PR116040]
2023-11-03 Paul Thomas
gcc/fortran
PR fortran/116040
* trans-stmt.cc (trans_associate_var): Copy chunk in 14-branch
that correctly handles class function selectors.
Diff:
---
gcc/fortran/trans-stmt.cc | 11 ++-
1 file changed, 10 insertions(+), 1 deletion(-)
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index 11a8a9c74ca6..51d008cacb8d 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -2039,7 +2039,16 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block
*block)
/* Class associate-names come this way because they are
unconditionally associate pointers and the symbol is scalar. */
- if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.dimension)
+ if (sym->ts.type == BT_CLASS && e->expr_type == EXPR_FUNCTION)
+ {
+ gfc_conv_expr (&se, e);
+ se.expr = gfc_evaluate_now (se.expr, &se.pre);
+ /* Finalize the expression and free if it is allocatable. */
+ gfc_finalize_tree_expr (&se, NULL, gfc_expr_attr (e), e->rank);
+ gfc_add_block_to_block (&se.post, &se.finalblock);
+ need_len_assign = false;
+ }
+ else if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.dimension)
{
tree target_expr;
/* For a class array we need a descriptor for the selector. */
[gcc r13-9171] Fortran: Fix regressions with intent(out) class[PR115070, PR115348].
https://gcc.gnu.org/g:43522516e5a5c95807a1bf31c3d11014fb1ffb77
commit r13-9171-g43522516e5a5c95807a1bf31c3d11014fb1ffb77
Author: Paul Thomas
Date: Tue Nov 5 21:09:26 2024 +
Fortran: Fix regressions with intent(out) class[PR115070, PR115348].
2024-11-05 Paul Thomas
gcc/fortran
PR fortran/115070
PR fortran/115348
* trans-expr.cc (gfc_trans_class_init_assign): If all the
components of the default initializer are null for a scalar,
build an empty statement to prevent prior declarations from
disappearing.
gcc/testsuite/
PR fortran/115070
* gfortran.dg/ieee/pr115070.f90: New test.
PR fortran/115348
* gfortran.dg/pr115348.f90: New test.
Diff:
---
gcc/fortran/trans-expr.cc | 6 -
gcc/testsuite/gfortran.dg/ieee/pr115070.f90 | 28 +++
gcc/testsuite/gfortran.dg/pr115348.f90 | 35 +
3 files changed, 68 insertions(+), 1 deletion(-)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 46348d7df456..59a7ff8d8d06 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -1722,7 +1722,11 @@ gfc_trans_class_init_assign (gfc_code *code)
if (cmp->initializer)
break;
else if (!cmp->next)
- return build_empty_stmt (input_location);
+ {
+ tmp = build_empty_stmt (input_location);
+ gfc_add_expr_to_block (&block, tmp);
+ return gfc_finish_block (&block);
+ }
}
}
diff --git a/gcc/testsuite/gfortran.dg/ieee/pr115070.f90
b/gcc/testsuite/gfortran.dg/ieee/pr115070.f90
new file mode 100644
index ..9378f770e2c6
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/ieee/pr115070.f90
@@ -0,0 +1,28 @@
+! { dg-do compile }
+!
+! Test the fix for PR115070
+!
+! Contributed by Sebastien Bardeau
+!
+module my_mod
+ type my_type
+integer :: a
+ contains
+final :: myfinal
+ end type my_type
+contains
+ subroutine my_sub(obs)
+use ieee_arithmetic
+class(my_type), intent(out) :: obs
+ end subroutine my_sub
+ subroutine myfinal (arg)
+type (my_type) :: arg
+print *, arg%a
+ end
+end module my_mod
+
+ use my_mod
+ type (my_type) :: z
+ z%a = 42
+ call my_sub (z)
+end
diff --git a/gcc/testsuite/gfortran.dg/pr115348.f90
b/gcc/testsuite/gfortran.dg/pr115348.f90
new file mode 100644
index ..bc644b2f1c0c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr115348.f90
@@ -0,0 +1,35 @@
+! { dg-do compile }
+! { dg-options "-fcheck=recursion" }
+!
+! Test the fix for pr115348.
+!
+! Contributed by Maxime van den Bossche
+!
+module mymodule
+implicit none
+
+type mytype
+integer :: mynumber
+contains
+procedure :: myroutine
+end type mytype
+
+contains
+
+subroutine myroutine(self)
+class(mytype), intent(out) :: self
+
+self%mynumber = 1
+end subroutine myroutine
+end module mymodule
+
+
+program myprogram
+use mymodule, only: mytype
+implicit none
+
+type(mytype) :: myobject
+
+call myobject%myroutine()
+print *, myobject%mynumber
+end program myprogram
[gcc r15-4677] Fortran: Fix ICE with structure constructor in data statement [PR79685]
https://gcc.gnu.org/g:6cb1da72cac166bd3b005c0430557b68b9761da5
commit r15-4677-g6cb1da72cac166bd3b005c0430557b68b9761da5
Author: Paul Thomas
Date: Fri Oct 25 17:59:03 2024 +0100
Fortran: Fix ICE with structure constructor in data statement [PR79685]
2024-10-25 Paul Thomas
gcc/fortran
PR fortran/79685
* decl.cc (match_data_constant): Find the symtree instead of
the symbol so the use renamed symbols are found. Pass this and
the derived type to gfc_match_structure_constructor.
* match.h: Update prototype of gfc_match_structure_contructor.
* primary.cc (gfc_match_structure_constructor): Remove call to
gfc_get_ha_sym_tree and use caller supplied symtree instead.
gcc/testsuite/
PR fortran/79685
* gfortran.dg/use_rename_13.f90: New test.
Diff:
---
gcc/fortran/decl.cc | 7 --
gcc/fortran/match.h | 2 +-
gcc/fortran/primary.cc | 8 +++
gcc/testsuite/gfortran.dg/use_rename_13.f90 | 37 +
4 files changed, 46 insertions(+), 8 deletions(-)
diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index 499a8462629e..000c8dcf34ed 100644
--- a/gcc/fortran/decl.cc
+++ b/gcc/fortran/decl.cc
@@ -377,6 +377,7 @@ match_data_constant (gfc_expr **result)
gfc_expr *expr;
match m;
locus old_loc;
+ gfc_symtree *symtree;
m = gfc_match_literal_constant (&expr, 1);
if (m == MATCH_YES)
@@ -437,9 +438,11 @@ match_data_constant (gfc_expr **result)
if (m != MATCH_YES)
return m;
- if (gfc_find_symbol (name, NULL, 1, &sym))
+ if (gfc_find_sym_tree (name, NULL, 1, &symtree))
return MATCH_ERROR;
+ sym = symtree->n.sym;
+
if (sym && sym->attr.generic)
dt_sym = gfc_find_dt_in_generic (sym);
@@ -453,7 +456,7 @@ match_data_constant (gfc_expr **result)
return MATCH_ERROR;
}
else if (dt_sym && gfc_fl_struct (dt_sym->attr.flavor))
-return gfc_match_structure_constructor (dt_sym, result);
+return gfc_match_structure_constructor (dt_sym, symtree, result);
/* Check to see if the value is an initialization array expression. */
if (sym->value->expr_type == EXPR_ARRAY)
diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h
index b2158e12a92f..13972bfe3e10 100644
--- a/gcc/fortran/match.h
+++ b/gcc/fortran/match.h
@@ -303,7 +303,7 @@ match gfc_match_bind_c_stmt (void);
match gfc_match_bind_c (gfc_symbol *, bool);
/* primary.cc. */
-match gfc_match_structure_constructor (gfc_symbol *, gfc_expr **);
+match gfc_match_structure_constructor (gfc_symbol *, gfc_symtree *, gfc_expr
**);
match gfc_match_variable (gfc_expr **, int);
match gfc_match_equiv_variable (gfc_expr **);
match gfc_match_actual_arglist (int, gfc_actual_arglist **, bool = false);
diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index f3f659cf8dfe..0f258edd1294 100644
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
@@ -3648,18 +3648,16 @@ gfc_convert_to_structure_constructor (gfc_expr *e,
gfc_symbol *sym, gfc_expr **c
match
-gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result)
+gfc_match_structure_constructor (gfc_symbol *sym, gfc_symtree *symtree,
+gfc_expr **result)
{
match m;
gfc_expr *e;
- gfc_symtree *symtree;
bool t = true;
- gfc_get_ha_sym_tree (sym->name, &symtree);
-
e = gfc_get_expr ();
- e->symtree = symtree;
e->expr_type = EXPR_FUNCTION;
+ e->symtree = symtree;
e->where = gfc_current_locus;
gcc_assert (gfc_fl_struct (sym->attr.flavor)
diff --git a/gcc/testsuite/gfortran.dg/use_rename_13.f90
b/gcc/testsuite/gfortran.dg/use_rename_13.f90
new file mode 100644
index ..97f26f42f762
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/use_rename_13.f90
@@ -0,0 +1,37 @@
+! { dg-do compile }
+!
+! Test the fix for pr79685, which failed as in the comments below.
+!
+! Contributed by Juergen Reuter
+!
+module omega_color
+ implicit none
+
+ type omega_color_factor
+ integer :: i
+ end type
+
+ type(omega_color_factor), parameter :: op = omega_color_factor (199)
+
+end module
+
+module foo
+ use omega_color, ocf => omega_color_factor, ocfp => op
+ implicit none
+
+ type(ocf) :: table_color_factors1 = ocf(42)
+ type(ocf) :: table_color_factors2
+ type(ocf) :: table_color_factors3 (2)
+ type(ocf) :: table_color_factors4
+ data table_color_factors2 / ocf(99) /! This failed in
gfc_match_structure_constructor.
+ data table_color_factors3 / ocf(1), ocf(2) / ! ditto.
+ data table_color_factors4 / ocfp /
+end module
+
+ use foo
+ if (table_color_factors1%i .ne. 42) stop 1
+ if (table_color_factors2%i .ne. 99) stop 2
+ if (any (table_color_factors3%i .ne. [1,2])) stop 3
+ if (table_color_factors4%i .ne. 199) stop 4
+end
+
[gcc r15-4573] Fortran: Generic processing of assumed rank objects (f202y) [PR116733]
https://gcc.gnu.org/g:c5fa2108ce0f3030cb28f47a18bc974c4224b66d commit r15-4573-gc5fa2108ce0f3030cb28f47a18bc974c4224b66d Author: Paul Thomas Date: Wed Oct 23 14:34:20 2024 +0100 Fortran: Generic processing of assumed rank objects (f202y) [PR116733] 2024-10-23 Paul Thomas gcc/fortran PR fortran/116733 * array.cc : White space corrections. * expr.cc (gfc_check_pointer_assign): Permit assumed rank target with -std=f202y. Add constraints that the data pointer object must have rank remapping specified and the that the data target be contiguous. * gfortran.h : Add a gfc_array_ref field 'ar' to the structure 'gfc_association_list'. * interface.cc (gfc_compare_actual_formal): If -Wsurprising is set, emit a warning if an assumed size array is passed to an assumed rank dummy. * intrinsic.cc (do_ts29113_check): Permit an assumed rank arg. for reshape if -std=f202y and the argument is contiguous. * invoke.texi : Introduce -std=f202y. Whitespace errors. * lang.opt : Accept -std=f202y. * libgfortran.h : Define GFC_STD_F202Y. * match.cc (gfc_match_associate): If -std=f202y an assumed rank selector is allowed if it is contiguous and the associate name has rank remapping specified. * options.cc (gfc_init_options): -std=f202y is equivalent to -std=f2023 with experimental f202y features. White space issues * parse.cc (parse_associate): If the selector is assumed rank, use the 'ar' field of the association list to build an array specification. * primary.cc (gfc_match_varspec): Do not resolve the assumed rank selector of a class associate name at this stage to avoid the rank change. * resolve.cc (find_array_spec): If an array_ref dimension is -1 reset it with the rank in the object's array_spec. (gfc_expression_rank): Do not check dimen types for an assumed rank variable expression. (resolve_variable): Do not emit the assumed rank context error if the context is pointer assignment and the variable is a target. (resolve_assoc_var): Resolve the bounds and check for missing bounds in the rank remap of an associate name with an assumed rank selector. Do not correct the rank of an associate name with an assumed rank selector. (resolve_symbol): Allow the reference to an assumed rank object if -std-f202y is enabled and the current operation is EXEC_BLOCK. * st.cc (gfc_free_association_list): Free bounds expressions of the 'ar' field, if present. * trans-array.cc (gfc_conv_ss_startstride): If -std=f202y and bounds checking activated, do not apply the assertion. * trans-expr.cc (gfc_trans_pointer_assignment): An assumed rank target has its offset set to zero. * trans-stmt.cc (trans_associate_var): If the selector is assumed rank, call gfc_trans_pointer_assignment using the 'ar' field in the association list as the array reference for expr1. The data target, expr2, is a copy of the selector expression. gcc/testsuite/ PR fortran/116733 * gfortran.dg/associate_3.f03: Change error message. * gfortran.dg/f202y/f202y.exp: Enable tests of f202y features. * gfortran.dg/f202y/generic_assumed_rank_1.f90: New test. * gfortran.dg/f202y/generic_assumed_rank_2.f90: New test. * gfortran.dg/f202y/generic_assumed_rank_3.f90: New test. Diff: --- gcc/fortran/array.cc | 6 +- gcc/fortran/expr.cc| 26 ++- gcc/fortran/gfortran.h | 2 + gcc/fortran/interface.cc | 10 +++ gcc/fortran/intrinsic.cc | 17 - gcc/fortran/invoke.texi| 31 gcc/fortran/lang.opt | 8 +- gcc/fortran/libgfortran.h | 1 + gcc/fortran/match.cc | 53 +- gcc/fortran/options.cc | 27 --- gcc/fortran/parse.cc | 27 ++- gcc/fortran/primary.cc | 1 + gcc/fortran/resolve.cc | 36 +++-- gcc/fortran/st.cc | 16 gcc/fortran/trans-array.cc | 9 ++- gcc/fortran/trans-expr.cc | 65 + gcc/fortran/trans-stmt.cc | 56 +- gcc/testsuite/gfortran.dg/a
[gcc r15-4702] Fortran: Fix regressions with intent(out) class[PR115070, PR115348].
https://gcc.gnu.org/g:ed8ca972f8857869d2bb4a416994bb896eb1c34e
commit r15-4702-ged8ca972f8857869d2bb4a416994bb896eb1c34e
Author: Paul Thomas
Date: Sun Oct 27 12:40:42 2024 +
Fortran: Fix regressions with intent(out) class[PR115070, PR115348].
2024-10-27 Paul Thomas
gcc/fortran
PR fortran/115070
PR fortran/115348
* trans-expr.cc (gfc_trans_class_init_assign): If all the
components of the default initializer are null for a scalar,
build an empty statement to prevent prior declarations from
disappearing.
gcc/testsuite/
PR fortran/115070
* gfortran.dg/pr115070.f90: New test.
PR fortran/115348
* gfortran.dg/pr115348.f90: New test.
Diff:
---
gcc/fortran/trans-expr.cc | 29
gcc/testsuite/gfortran.dg/pr115070.f90 | 28 +++
gcc/testsuite/gfortran.dg/pr115348.f90 | 35 ++
3 files changed, 80 insertions(+), 12 deletions(-)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 663d762df88d..ff8cde93ef4f 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -1791,10 +1791,12 @@ gfc_trans_class_init_assign (gfc_code *code)
{
stmtblock_t block;
tree tmp;
+ bool cmp_flag = true;
gfc_se dst,src,memsz;
gfc_expr *lhs, *rhs, *sz;
gfc_component *cmp;
gfc_symbol *sym;
+ gfc_ref *ref;
gfc_start_block (&block);
@@ -1812,24 +1814,25 @@ gfc_trans_class_init_assign (gfc_code *code)
rhs->rank = 0;
/* Check def_init for initializers. If this is an INTENT(OUT) dummy with all
- default initializer components NULL, return NULL_TREE and use the passed
- value as required by F2018(8.5.10). */
+ default initializer components NULL, use the passed value even though
+ F2018(8.5.10) asserts that it should considered to be undefined. This is
+ needed for consistency with other brands. */
sym = code->expr1->expr_type == EXPR_VARIABLE ? code->expr1->symtree->n.sym
: NULL;
if (code->op != EXEC_ALLOCATE
&& sym && sym->attr.dummy
&& sym->attr.intent == INTENT_OUT)
{
- if (!lhs->ref && lhs->symtree->n.sym->attr.dummy)
+ ref = rhs->ref;
+ while (ref && ref->next)
+ ref = ref->next;
+ cmp = ref->u.c.component->ts.u.derived->components;
+ for (; cmp; cmp = cmp->next)
{
- cmp = rhs->ref->next->u.c.component->ts.u.derived->components;
- for (; cmp; cmp = cmp->next)
- {
- if (cmp->initializer)
- break;
- else if (!cmp->next)
- return NULL_TREE;
- }
+ if (cmp->initializer)
+ break;
+ else if (!cmp->next)
+ cmp_flag = false;
}
}
@@ -1843,7 +1846,7 @@ gfc_trans_class_init_assign (gfc_code *code)
gfc_add_full_array_ref (lhs, tmparr);
tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
}
- else
+ else if (cmp_flag)
{
/* Scalar initialization needs the _data component. */
gfc_add_data_component (lhs);
@@ -1873,6 +1876,8 @@ gfc_trans_class_init_assign (gfc_code *code)
tmp, build_empty_stmt (input_location));
}
}
+ else
+tmp = build_empty_stmt (input_location);
if (code->expr1->symtree->n.sym->attr.dummy
&& (code->expr1->symtree->n.sym->attr.optional
diff --git a/gcc/testsuite/gfortran.dg/pr115070.f90
b/gcc/testsuite/gfortran.dg/pr115070.f90
new file mode 100644
index ..9378f770e2c6
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr115070.f90
@@ -0,0 +1,28 @@
+! { dg-do compile }
+!
+! Test the fix for PR115070
+!
+! Contributed by Sebastien Bardeau
+!
+module my_mod
+ type my_type
+integer :: a
+ contains
+final :: myfinal
+ end type my_type
+contains
+ subroutine my_sub(obs)
+use ieee_arithmetic
+class(my_type), intent(out) :: obs
+ end subroutine my_sub
+ subroutine myfinal (arg)
+type (my_type) :: arg
+print *, arg%a
+ end
+end module my_mod
+
+ use my_mod
+ type (my_type) :: z
+ z%a = 42
+ call my_sub (z)
+end
diff --git a/gcc/testsuite/gfortran.dg/pr115348.f90
b/gcc/testsuite/gfortran.dg/pr115348.f90
new file mode 100644
index ..bc644b2f1c0c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr115348.f90
@@ -0,0 +1,35 @@
+! { dg-do compile }
+! { dg-options "-fcheck=recursion" }
+!
+! Test the fix for pr115348.
+!
+! Contributed by Maxime van den Bossche
+!
+module mymodule
+implicit none
+
+type mytype
+integer :: mynumber
+contains
+procedure :: myroutine
+end type mytype
+
+contains
+
+subroutine myroutine(self)
+class(mytype), intent(out) :: self
+
+self%mynumber = 1
+end subroutine myroutine
+end module mymodule
+
+
+
[gcc r15-5078] Fortran: Suppress invalid finalization of artificial variable [PR116388]
https://gcc.gnu.org/g:42a2df0b7985b2a4732ba1c29726ac7aabd5eeae
commit r15-5078-g42a2df0b7985b2a4732ba1c29726ac7aabd5eeae
Author: Paul Thomas
Date: Mon Nov 11 09:01:11 2024 +
Fortran: Suppress invalid finalization of artificial variable [PR116388]
2024-11-11 Tomas Trnka
Paul Thomas
gcc/fortran
PR fortran/116388
* class.cc (finalize_component): Leading underscore in the name
of 'byte_stride' to suppress invalid finalization.
gcc/testsuite/
PR fortran/116388
* gfortran.dg/finalize_58.f90: New test.
Diff:
---
gcc/fortran/class.cc | 5 +-
gcc/testsuite/gfortran.dg/finalize_58.f90 | 77 +++
2 files changed, 80 insertions(+), 2 deletions(-)
diff --git a/gcc/fortran/class.cc b/gcc/fortran/class.cc
index 4b2234a958fc..fc709fec322c 100644
--- a/gcc/fortran/class.cc
+++ b/gcc/fortran/class.cc
@@ -1152,8 +1152,9 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived,
gfc_component *comp,
gcc_assert (c);
- /* Set scalar argument for storage_size. */
- gfc_get_symbol ("comp_byte_stride", sub_ns, &byte_stride);
+ /* Set scalar argument for storage_size. A leading underscore in
+the name prevents an unwanted finalization. */
+ gfc_get_symbol ("_comp_byte_stride", sub_ns, &byte_stride);
byte_stride->ts = e->ts;
byte_stride->attr.flavor = FL_VARIABLE;
byte_stride->attr.value = 1;
diff --git a/gcc/testsuite/gfortran.dg/finalize_58.f90
b/gcc/testsuite/gfortran.dg/finalize_58.f90
new file mode 100644
index ..54960e6b0305
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/finalize_58.f90
@@ -0,0 +1,77 @@
+! { dg-do run }
+!
+! Test fix for PR116388 in which an artificial variable in the finalization
+! wrapper was generating an invalid finalization.
+!
+! Contributed by Tomas Trnka
+!
+module FinalizerTestModule
+
+ use, intrinsic :: ISO_C_BINDING
+
+ implicit none
+
+ type, public :: AType
+ type(C_ptr) :: cptr = C_null_ptr
+ logical :: cptr_invalid = .true.
+ integer, allocatable :: x(:)
+ contains
+ final :: FinalizerA
+ end type
+
+ type, public :: BType
+ type(C_ptr) :: cptr = C_null_ptr
+ type(AType) :: a
+ contains
+ procedure, public :: New => NewB
+ final :: FinalizerB
+ end type
+
+ type, public :: CType
+ type(BType) :: b
+ contains
+ procedure, public :: New => NewC
+ end type
+
+ integer :: final_A = 0
+ integer :: final_B = 0
+contains
+
+ impure elemental subroutine FinalizerA(self)
+ type(AType), intent(inout) :: self
+ final_A = final_A + 1
+ if (.not. self%cptr_invalid) stop 1
+ end subroutine
+
+ subroutine NewB(self)
+ class(BType), intent(out) :: self
+
+ end subroutine
+
+ impure elemental subroutine FinalizerB(self)
+ type(BType), intent(inout) :: self
+ final_B = final_B + 1
+ if (transfer (self%cptr, C_LONG_LONG) /= 0) stop 2
+ end subroutine
+
+ subroutine NewC(self, b)
+ class(CType), intent(out) :: self
+ type(BType), intent(in) :: b
+
+ self%b = b
+ end subroutine
+
+end module
+
+program finalizing_uninitialized
+ use FinalizerTestModule
+ implicit none
+
+ type(BType) :: b
+ type(CType) :: c
+
+ call b%New()
+ call c%New(b)
+ if (final_A /= 3) stop 3
+ if (final_B /= 3) stop 4
+end program
[gcc r15-5083] Fortran: Fix elemental array refs in SELECT TYPE [PR109345]
https://gcc.gnu.org/g:e22d80d4f0f8d33f538c1a4bad07b2c819a6d55c
commit r15-5083-ge22d80d4f0f8d33f538c1a4bad07b2c819a6d55c
Author: Paul Thomas
Date: Mon Nov 11 12:21:57 2024 +
Fortran: Fix elemental array refs in SELECT TYPE [PR109345]
2024-11-10 Paul Thomas
gcc/fortran
PR fortran/109345
* trans-array.cc (gfc_get_array_span): Unlimited polymorphic
expressions are now treated separately since the span need not
be the same as the element size.
gcc/testsuite/
PR fortran/109345
* gfortran.dg/character_workout_1.f90: Cut trailing whitespace.
* gfortran.dg/pr109345.f90: New test.
Diff:
---
gcc/fortran/trans-array.cc| 44 +
gcc/testsuite/gfortran.dg/character_workout_1.f90 | 8 +--
gcc/testsuite/gfortran.dg/pr109345.f90| 77 +++
3 files changed, 113 insertions(+), 16 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index a52bde90bd2c..e888b737bec3 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -962,6 +962,8 @@ tree
gfc_get_array_span (tree desc, gfc_expr *expr)
{
tree tmp;
+ gfc_symbol *sym = expr->expr_type == EXPR_VARIABLE
+ ? expr->symtree->n.sym : NULL;
if (is_pointer_array (desc)
|| (get_CFI_desc (NULL, expr, &desc, NULL)
@@ -983,25 +985,43 @@ gfc_get_array_span (tree desc, gfc_expr *expr)
desc = build_fold_indirect_ref_loc (input_location, desc);
tmp = gfc_conv_descriptor_span_get (desc);
}
+ else if (UNLIMITED_POLY (expr)
+ || (sym && UNLIMITED_POLY (sym)))
+{
+ /* Treat unlimited polymorphic expressions separately because
+the element size need not be the same as the span. Obtain
+the class container, which is simplified here by their being
+no component references. */
+ if (sym && sym->attr.dummy)
+ {
+ tmp = gfc_get_symbol_decl (sym);
+ tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp);
+ if (INDIRECT_REF_P (tmp))
+ tmp = TREE_OPERAND (tmp, 0);
+ }
+ else
+ {
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
+ tmp = TREE_OPERAND (desc, 0);
+ }
+ tmp = gfc_class_data_get (tmp);
+ tmp = gfc_conv_descriptor_span_get (tmp);
+}
else if (TREE_CODE (desc) == COMPONENT_REF
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
&& GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (desc, 0
{
- /* The descriptor is a class _data field and so use the vtable
-size for the receiving span field. */
- tmp = gfc_get_vptr_from_expr (desc);
+ /* The descriptor is a class _data field. Use the vtable size
+since it is guaranteed to have been set and is always OK for
+class array descriptors that are not unlimited. */
+ tmp = gfc_class_vptr_get (TREE_OPERAND (desc, 0));
tmp = gfc_vptr_size_get (tmp);
}
- else if (expr && expr->expr_type == EXPR_VARIABLE
- && expr->symtree->n.sym->ts.type == BT_CLASS
- && expr->ref->type == REF_COMPONENT
- && expr->ref->next->type == REF_ARRAY
- && expr->ref->next->next == NULL
- && CLASS_DATA (expr->symtree->n.sym)->attr.dimension)
+ else if (sym && sym->ts.type == BT_CLASS && sym->attr.dummy)
{
- /* Dummys come in sometimes with the descriptor detached from
-the class field or declaration. */
- tmp = gfc_class_vptr_get (expr->symtree->n.sym->backend_decl);
+ /* Class dummys usually requires extraction from the saved
+descriptor, which gfc_class_vptr_get does for us. */
+ tmp = gfc_class_vptr_get (sym->backend_decl);
tmp = gfc_vptr_size_get (tmp);
}
else
diff --git a/gcc/testsuite/gfortran.dg/character_workout_1.f90
b/gcc/testsuite/gfortran.dg/character_workout_1.f90
index 98133b48960a..8f8bdbf00690 100644
--- a/gcc/testsuite/gfortran.dg/character_workout_1.f90
+++ b/gcc/testsuite/gfortran.dg/character_workout_1.f90
@@ -1,7 +1,7 @@
! { dg-do run }
!
! Tests fix for PR100120/100816/100818/100819/100821
-!
+!
program main_p
@@ -27,10 +27,10 @@ program main_p
character(len=m, kind=k), pointer :: pm(:)
character(len=e, kind=k), pointer :: pe(:)
character(len=:, kind=k), pointer :: pd(:)
-
+
class(*), pointer :: su
class(*), pointer :: pu(:)
-
+
integer :: i, j
nullify(s1, sm, se, sd, su)
@@ -41,7 +41,7 @@ program main_p
cm(i)(j:j) = char(i*m+j+c-m, kind=k)
end do
end do
-
+
s1 => c1(n)
if(.not.associated(s1)) stop 1
if(.not.associated(s1, c1(n))) stop 2
diff --git a/gcc/testsuite/gfortran.dg/pr109345.f90
b/gcc/testsuite/gfortran.dg/pr109345.f90
new file mode 100644
index ..cff9aaa987a0
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr109345.f90
@@ -0,0
[gcc r15-5192] Fortran: Fix failing character pointer fcn assignment [PR105054]
https://gcc.gnu.org/g:f530a8c61383b174a476b64f46d56adeedf49dc4
commit r15-5192-gf530a8c61383b174a476b64f46d56adeedf49dc4
Author: Paul Thomas
Date: Wed Nov 13 08:57:55 2024 +
Fortran: Fix failing character pointer fcn assignment [PR105054]
2024-11-14 Paul Thomas
gcc/fortran
PR fortran/105054
* resolve.cc (get_temp_from_expr): If the pointer function has
a deferred character length, generate a new deferred charlen
for the temporary.
gcc/testsuite/
PR fortran/105054
* gfortran.dg/ptr_func_assign_6.f08: New test.
Diff:
---
gcc/fortran/resolve.cc | 11 +++
gcc/testsuite/gfortran.dg/ptr_func_assign_6.f08 | 89 +
2 files changed, 100 insertions(+)
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 51e0af410c1c..b8c908b51e92 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -12701,6 +12701,17 @@ resolve_ptr_fcn_assign (gfc_code **code, gfc_namespace
*ns)
tmp_ptr_expr->symtree->n.sym->attr.allocatable = 0;
tmp_ptr_expr->where = (*code)->loc;
+ /* A new charlen is required to ensure that the variable string length
+ is different to that of the original lhs for deferred results. */
+ if (s->result->ts.deferred && tmp_ptr_expr->ts.type == BT_CHARACTER)
+{
+ tmp_ptr_expr->ts.u.cl = gfc_get_charlen();
+ tmp_ptr_expr->ts.deferred = 1;
+ tmp_ptr_expr->ts.u.cl->next = gfc_current_ns->cl_list;
+ gfc_current_ns->cl_list = tmp_ptr_expr->ts.u.cl;
+ tmp_ptr_expr->symtree->n.sym->ts.u.cl = tmp_ptr_expr->ts.u.cl;
+}
+
this_code = build_assignment (EXEC_ASSIGN,
tmp_ptr_expr, (*code)->expr2,
NULL, NULL, (*code)->loc);
diff --git a/gcc/testsuite/gfortran.dg/ptr_func_assign_6.f08
b/gcc/testsuite/gfortran.dg/ptr_func_assign_6.f08
new file mode 100644
index ..d62815d7afad
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/ptr_func_assign_6.f08
@@ -0,0 +1,89 @@
+! { dg-do run }
+!
+! Test the fix for PR105054.
+!
+! Contributed by Arjen Markus
+!
+module string_pointers
+implicit none
+character(len=20), dimension(10), target :: array_strings
+character(len=:), dimension(:), target, allocatable :: array_strings2
+
+contains
+
+function pointer_to_string( i , flag)
+ integer, intent(in) :: i, flag
+
+ character(len=:), pointer :: pointer_to_string
+
+ if (flag == 1) then
+ pointer_to_string => array_strings(i)
+ return
+ endif
+
+ if (.not.allocated (array_strings2)) allocate (array_strings2(4), &
+mold = '')
+ pointer_to_string => array_strings2(i)
+end function pointer_to_string
+
+function pointer_to_string2( i , flag) result (res)
+ integer, intent(in) :: i, flag
+
+ character(len=:), pointer :: res
+
+ if (flag == 1) then
+ res => array_strings(i)
+ return
+ endif
+
+ if (.not.allocated (array_strings2)) allocate (array_strings2(4), &
+mold = '')
+ res => array_strings2(i)
+end function pointer_to_string2
+
+end module string_pointers
+
+program chk_string_pointer
+use string_pointers
+implicit none
+integer :: i
+character(*), parameter :: chr(4) = ['1234 ','ABCDefgh ', &
+ '12345678 ',' ']
+
+pointer_to_string(1, 1) = '1234567890'
+pointer_to_string(2, 1) = '12345678901234567890'
+
+if (len(pointer_to_string(3, 1)) /= 20) stop 1
+
+array_strings(1) = array_strings(1)(1:4) // 'ABC'
+if (pointer_to_string(1, 1) /= '1234ABC') stop 2
+
+pointer_to_string(1, 2) = '1234'
+pointer_to_string(2, 2) = 'ABCDefgh'
+pointer_to_string(3, 2) = '12345678'
+
+do i = 1, 3
+ if (trim (array_strings2(i)) /= trim(chr(i))) stop 3
+enddo
+
+! Clear the target arrays
+array_strings = repeat (' ', 20)
+deallocate (array_strings2)
+
+! Repeat with an explicit result.
+pointer_to_string2(1, 1) = '1234567890'
+pointer_to_string2(2, 1) = '12345678901234567890'
+
+if (len(pointer_to_string(3, 1)) /= 20) stop 4
+
+array_strings(1) = array_strings(1)(1:4) // 'ABC'
+if (pointer_to_string(1, 1) /= '1234ABC') stop 5
+
+pointer_to_string2(1, 2) = '1234'
+pointer_to_string2(2, 2) = 'ABCDefgh'
+pointer_to_string2(3, 2) = '12345678'
+
+do i = 1, 3
+ if (trim (array_strings2(i)) /= trim(chr(i))) stop 6
+enddo
+end program chk_string_pointer
[gcc r15-4793] Fortran: Fix problem with substring selectors in ASSOCIATE [PR115700]
https://gcc.gnu.org/g:159fb203231c503418e7ab9f45282957e40cb195
commit r15-4793-g159fb203231c503418e7ab9f45282957e40cb195
Author: Paul Thomas
Date: Thu Oct 31 07:22:36 2024 +
Fortran: Fix problem with substring selectors in ASSOCIATE [PR115700]
2024-10-31 Paul Thomas
gcc/fortran
PR fortran/115700
* resolve.cc (resolve_variable): The typespec of an expression,
which is not a substring, can be shared with a deferred length
associate name.
(resolve_assoc_var): Extract a substring reference with non-
constant start or end. Use it to flag up the need for array
associate name to be a pointer.
(resolve_block_construct): Change comment from past to future
tense.
gcc/testsuite/
PR fortran/115700
* gfortran.dg/associate_70.f90: New test.
Diff:
---
gcc/fortran/resolve.cc | 33
gcc/testsuite/gfortran.dg/associate_70.f90 | 40 ++
2 files changed, 68 insertions(+), 5 deletions(-)
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 565d4aa5fe9a..8045deddd8ad 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -6153,6 +6153,15 @@ resolve_variable (gfc_expr *e)
e->ref = newref;
}
}
+ else if (sym->assoc && sym->ts.type == BT_CHARACTER && sym->ts.deferred)
+{
+ gfc_ref *ref;
+ for (ref = e->ref; ref; ref = ref->next)
+ if (ref->type == REF_SUBSTRING)
+ break;
+ if (ref == NULL)
+ e->ts = sym->ts;
+}
if (e->ref && !gfc_resolve_ref (e))
return false;
@@ -9871,6 +9880,15 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
/* Fix up the type-spec for CHARACTER types. */
if (sym->ts.type == BT_CHARACTER && !sym->attr.select_type_temporary)
{
+ gfc_ref *ref;
+ for (ref = target->ref; ref; ref = ref->next)
+ if (ref->type == REF_SUBSTRING
+ && ((ref->u.ss.start
+&& ref->u.ss.start->expr_type != EXPR_CONSTANT)
+ || (ref->u.ss.end
+ && ref->u.ss.end->expr_type != EXPR_CONSTANT)))
+ break;
+
if (!sym->ts.u.cl)
sym->ts.u.cl = target->ts.u.cl;
@@ -9889,9 +9907,10 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
gfc_get_int_expr (gfc_charlen_int_kind, NULL,
target->value.character.length);
}
- else if ((!sym->ts.u.cl->length
- || sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
+ else if (((!sym->ts.u.cl->length
+|| sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
&& target->expr_type != EXPR_VARIABLE)
+ || ref)
{
if (!sym->ts.deferred)
{
@@ -9901,7 +9920,10 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
/* This is reset in trans-stmt.cc after the assignment
of the target expression to the associate name. */
- sym->attr.allocatable = 1;
+ if (ref && sym->as)
+ sym->attr.pointer = 1;
+ else
+ sym->attr.allocatable = 1;
}
}
@@ -11508,8 +11530,9 @@ resolve_block_construct (gfc_code* code)
{
gfc_namespace *ns = code->ext.block.ns;
- /* For an ASSOCIATE block, the associations (and their targets) are already
- resolved during resolve_symbol. Resolve the BLOCK's namespace. */
+ /* For an ASSOCIATE block, the associations (and their targets) will be
+ resolved by gfc_resolve_symbol, during resolution of the BLOCK's
+ namespace. */
gfc_resolve (ns);
}
diff --git a/gcc/testsuite/gfortran.dg/associate_70.f90
b/gcc/testsuite/gfortran.dg/associate_70.f90
new file mode 100644
index ..b8916f4c70fd
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/associate_70.f90
@@ -0,0 +1,40 @@
+! { dg-do run }
+! ( dg-options "-Wuninitialized" )
+!
+! Test fix for PR115700 comment 5, in which ‘.tmp1’ is used uninitialized and
+! both normal and scalarized array references did not work correctly.
+!
+! Contributed by Harald Anlauf
+!
+ character(4), dimension(3) :: chr = ['abcd', 'efgh', 'ijkl']
+ call mvce (chr)
+ if (any (chr /= ['ABcd', 'EFgh', 'IJkl'])) stop 1
+contains
+ subroutine mvce(x)
+implicit none
+character(len=*), dimension(:), intent(inOUT), target :: x
+integer :: i
+i = len(x)
+
+! This was broken
+associate (tmp1 => x(:)(1:i/2))
+ if (len (tmp1) /= i/2) stop 2
+ if (tmp1(2) /= 'ef') stop 3
+ if (any (tmp1 /= ['ab', 'ef', 'ij'])) stop 4
+ tmp1 = ['AB','EF','IJ']
+end associate
+
+! Retest things that worked previously.
+associate (tmp2 => x(:)(1:2))
+ if (len (tmp2) /= i/2) stop 5
+ if (tmp2(2) /= 'EF') stop 6
+ if (any (tmp2 /= ['AB','EF','IJ'])) stop 7
+end associate
+
+associate (tmp3 => x(3)(1:i/2))
+
[gcc r13-9160] Fortran: Prevent unwanted finalization with -w option [PR112459]
https://gcc.gnu.org/g:e4276844d09f648ba010a890ce7a5bdce17abc41
commit r13-9160-ge4276844d09f648ba010a890ce7a5bdce17abc41
Author: Paul Thomas
Date: Sat Dec 16 13:59:45 2023 +
Fortran: Prevent unwanted finalization with -w option [PR112459]
2023-12-16 Paul Thomas
gcc/fortran
PR fortran/112459
* trans-array.cc (gfc_trans_array_constructor_value): Replace
gfc_notification_std with explicit logical expression that
selects F2003/2008 and excludes -std=default/gnu.
* trans-expr.cc (gfc_conv_expr): Ditto.
gcc/testsuite/
PR fortran/112459
* gfortran.dg/pr112459.f90: New test.
(cherry picked from commit 9a1105b770df9a9b485705398abbb74b5c487a25)
Diff:
---
gcc/fortran/trans-array.cc | 4 +++-
gcc/fortran/trans-expr.cc | 4 +++-
gcc/testsuite/gfortran.dg/pr112459.f90 | 37 ++
3 files changed, 43 insertions(+), 2 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index eecb342f32af..fa432505c254 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -2310,7 +2310,9 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock,
Corrigenda 1 TO 4 for fortran 2008 (f08/0011).
Transmit finalization of this constructor through 'finalblock'. */
- if (!gfc_notification_std (GFC_STD_F2018_DEL) && finalblock != NULL
+ if ((gfc_option.allow_std & (GFC_STD_F2008 | GFC_STD_F2003))
+ && !(gfc_option.allow_std & GFC_STD_GNU)
+ && finalblock != NULL
&& gfc_may_be_finalized (ts)
&& ctr > 0 && desc != NULL_TREE
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 7e3c38e5f92d..46348d7df456 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -9561,7 +9561,9 @@ gfc_conv_expr (gfc_se * se, gfc_expr * expr)
executable construct containing the reference. This, in fact,
was later deleted by the Combined Techical Corrigenda 1 TO 4 for
fortran 2008 (f08/0011). */
- if (!gfc_notification_std (GFC_STD_F2018_DEL) && expr->must_finalize
+ if ((gfc_option.allow_std & (GFC_STD_F2008 | GFC_STD_F2003))
+ && !(gfc_option.allow_std & GFC_STD_GNU)
+ && expr->must_finalize
&& gfc_may_be_finalized (expr->ts))
{
gfc_warning (0, "The structure constructor at %C has been"
diff --git a/gcc/testsuite/gfortran.dg/pr112459.f90
b/gcc/testsuite/gfortran.dg/pr112459.f90
new file mode 100644
index ..7db243c224a2
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr112459.f90
@@ -0,0 +1,37 @@
+! { dg-do compile }
+! { dg-options "-w -fdump-tree-original" }
+!
+! Contributed by Sebastian Bardeau
+!
+module mymod
+ type mysubtype
+integer(kind=4), allocatable :: a(:)
+ end type mysubtype
+ type :: mytype
+integer :: i
+type(mysubtype) :: sub
+ contains
+final :: mytype_final
+ end type mytype
+contains
+ subroutine mysubtype_final(sub)
+type(mysubtype), intent(inout) :: sub
+print *,'MYSUBTYPE>FINAL'
+if (allocated(sub%a)) deallocate(sub%a)
+ end subroutine mysubtype_final
+ subroutine mytype_final(typ)
+type(mytype), intent(inout) :: typ
+print *,"MYTYPE>FINAL"
+call mysubtype_final(typ%sub)
+ end subroutine mytype_final
+end module mymod
+!
+program myprog
+ use mymod
+ type(mytype), pointer :: c
+ print *,"Before allocation"
+ allocate(c)
+ print *,"After allocation"
+end program myprog
+! Final subroutines were called with std=gnu and -w = > 14 "_final"s.
+! { dg-final { scan-tree-dump-times "_final" 12 "original" } }
[gcc r15-4835] Fortran: Fix problems with substring selectors in ASSOCIATE [PR115700]
https://gcc.gnu.org/g:7f93910a8b5d606ad742a3594750f0c2b20d8bda
commit r15-4835-g7f93910a8b5d606ad742a3594750f0c2b20d8bda
Author: Paul Thomas
Date: Fri Nov 1 07:45:00 2024 +
Fortran: Fix problems with substring selectors in ASSOCIATE [PR115700]
2024-11-01 Paul Thomas
gcc/fortran
PR fortran/115700
* resolve.cc (resolve_assoc_var): Extract a substring reference
with missing as well as non-constant start or end.
gcc/testsuite/
PR fortran/115700
* gfortran.dg/associate_69.f90: Activate commented out tests.
* gfortran.dg/associate_70.f90: Test correct functioning of
references in associate_69.f90 tests.
Diff:
---
gcc/fortran/resolve.cc | 8 ++---
gcc/testsuite/gfortran.dg/associate_69.f90 | 23 +-
gcc/testsuite/gfortran.dg/associate_70.f90 | 50 +-
3 files changed, 54 insertions(+), 27 deletions(-)
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 8045deddd8ad..b14d3e776ab7 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -9883,10 +9883,10 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
gfc_ref *ref;
for (ref = target->ref; ref; ref = ref->next)
if (ref->type == REF_SUBSTRING
- && ((ref->u.ss.start
-&& ref->u.ss.start->expr_type != EXPR_CONSTANT)
- || (ref->u.ss.end
- && ref->u.ss.end->expr_type != EXPR_CONSTANT)))
+ && (ref->u.ss.start == NULL
+ || ref->u.ss.start->expr_type != EXPR_CONSTANT
+ || ref->u.ss.end == NULL
+ || ref->u.ss.end->expr_type != EXPR_CONSTANT))
break;
if (!sym->ts.u.cl)
diff --git a/gcc/testsuite/gfortran.dg/associate_69.f90
b/gcc/testsuite/gfortran.dg/associate_69.f90
index 28f488bb2746..35db417867d4 100644
--- a/gcc/testsuite/gfortran.dg/associate_69.f90
+++ b/gcc/testsuite/gfortran.dg/associate_69.f90
@@ -2,10 +2,14 @@
! { dg-options "-Og -Wuninitialized -Wmaybe-uninitialized
-fdump-tree-optimized" }
!
! PR fortran/115700 - Bogus warning for associate with assumed-length
character array
+! This testcase checks for the suppression of the bogus error and associate_70
for
+! correct results.
!
subroutine mvce(x)
implicit none
character(len=*), dimension(:), intent(in) :: x
+ integer :: i
+ i = len(x)
associate (tmp1 => x)
if (len (tmp1) /= len (x)) stop 1
@@ -19,15 +23,18 @@ subroutine mvce(x)
if (len (tmp3) /= len (x)) stop 3
end associate
-! The following associate blocks still produce bogus warnings:
+ associate (tmp4 => x(:)(1:))
+if (len (tmp4) /= len (x)) stop 4
+ end associate
-! associate (tmp4 => x(:)(1:))
-! if (len (tmp4) /= len (x)) stop 4
-! end associate
-!
-! associate (tmp5 => x(1:)(1:))
-! if (len (tmp5) /= len (x)) stop 5
-! end associate
+ associate (tmp5 => x(1:)(1:))
+if (len (tmp5) /= len (x)) stop 5
+ end associate
+
+ associate (temp6 => x(:)(1:i/2))
+if (len (temp6) /= i/2) stop 6
+ end associate
end
! { dg-final { scan-tree-dump-not " \\.tmp" "optimized" } }
+! { dg-final { scan-tree-dump-times " \\.temp6" 7 "optimized" } }
diff --git a/gcc/testsuite/gfortran.dg/associate_70.f90
b/gcc/testsuite/gfortran.dg/associate_70.f90
index b8916f4c70fd..ddb38b84c4b3 100644
--- a/gcc/testsuite/gfortran.dg/associate_70.f90
+++ b/gcc/testsuite/gfortran.dg/associate_70.f90
@@ -3,37 +3,57 @@
!
! Test fix for PR115700 comment 5, in which ‘.tmp1’ is used uninitialized and
! both normal and scalarized array references did not work correctly.
+! This testcase checks for correct results and associate_69 for suppression
+! of the bogus error.
!
! Contributed by Harald Anlauf
!
character(4), dimension(3) :: chr = ['abcd', 'efgh', 'ijkl']
call mvce (chr)
if (any (chr /= ['ABcd', 'EFgh', 'IJkl'])) stop 1
+
contains
subroutine mvce(x)
implicit none
-character(len=*), dimension(:), intent(inOUT), target :: x
+character(len=*), dimension(:), intent(inOUT) :: x
integer :: i
i = len(x)
-! This was broken
-associate (tmp1 => x(:)(1:i/2))
- if (len (tmp1) /= i/2) stop 2
- if (tmp1(2) /= 'ef') stop 3
- if (any (tmp1 /= ['ab', 'ef', 'ij'])) stop 4
- tmp1 = ['AB','EF','IJ']
+associate (tmp1 => x)
+ if (len (tmp1) /= len (x)) stop 2
+ tmp1(2)(3:4) = '12'
+end associate
+if (any (x /= ['abcd', 'ef12', 'ijkl'])) stop 3
+
+associate (tmp2 => x(1:))
+ if (len (tmp2) /= len (x)) stop 4
+ tmp2(2)(1:2) = '34'
+end associate
+if (any (x /= ['abcd', '3412', 'ijkl'])) stop 5
+
+associate (tmp3 => x(1:)(:))
+ if (len (tmp3) /= len (x)) stop 6
+ tmp3(3)(3:4) = '56'
+end associate
+if (any (x /= ['abcd', '3412', 'ij56'])) stop 7
+
+associate (tmp4 => x(:)(1:))
+ if (len (tmp4) /= len (x)) stop 8
+ tmp4(3)(1:2) = '78'
[gcc r12-10796] Fortran: Fix ICE with structure constructor in data statement [PR79685]
https://gcc.gnu.org/g:5210bf4d494d6ea60722193c7eb97827e73f5295
commit r12-10796-g5210bf4d494d6ea60722193c7eb97827e73f5295
Author: Paul Thomas
Date: Fri Oct 25 17:59:03 2024 +0100
Fortran: Fix ICE with structure constructor in data statement [PR79685]
2024-10-25 Paul Thomas
gcc/fortran
PR fortran/79685
* decl.cc (match_data_constant): Find the symtree instead of
the symbol so the use renamed symbols are found. Pass this and
the derived type to gfc_match_structure_constructor.
* match.h: Update prototype of gfc_match_structure_contructor.
* primary.cc (gfc_match_structure_constructor): Remove call to
gfc_get_ha_sym_tree and use caller supplied symtree instead.
gcc/testsuite/
PR fortran/79685
* gfortran.dg/use_rename_13.f90: New test.
(cherry picked from commit 6cb1da72cac166bd3b005c0430557b68b9761da5)
Diff:
---
gcc/fortran/decl.cc | 7 --
gcc/fortran/match.h | 2 +-
gcc/fortran/primary.cc | 8 +++
gcc/testsuite/gfortran.dg/use_rename_13.f90 | 37 +
4 files changed, 46 insertions(+), 8 deletions(-)
diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index d98f98d7ec61..8c101b0daf79 100644
--- a/gcc/fortran/decl.cc
+++ b/gcc/fortran/decl.cc
@@ -376,6 +376,7 @@ match_data_constant (gfc_expr **result)
gfc_expr *expr;
match m;
locus old_loc;
+ gfc_symtree *symtree;
m = gfc_match_literal_constant (&expr, 1);
if (m == MATCH_YES)
@@ -435,9 +436,11 @@ match_data_constant (gfc_expr **result)
if (m != MATCH_YES)
return m;
- if (gfc_find_symbol (name, NULL, 1, &sym))
+ if (gfc_find_sym_tree (name, NULL, 1, &symtree))
return MATCH_ERROR;
+ sym = symtree->n.sym;
+
if (sym && sym->attr.generic)
dt_sym = gfc_find_dt_in_generic (sym);
@@ -451,7 +454,7 @@ match_data_constant (gfc_expr **result)
return MATCH_ERROR;
}
else if (dt_sym && gfc_fl_struct (dt_sym->attr.flavor))
-return gfc_match_structure_constructor (dt_sym, result);
+return gfc_match_structure_constructor (dt_sym, symtree, result);
/* Check to see if the value is an initialization array expression. */
if (sym->value->expr_type == EXPR_ARRAY)
diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h
index 495c93e0b5ce..d22733568581 100644
--- a/gcc/fortran/match.h
+++ b/gcc/fortran/match.h
@@ -296,7 +296,7 @@ match gfc_match_bind_c_stmt (void);
match gfc_match_bind_c (gfc_symbol *, bool);
/* primary.cc. */
-match gfc_match_structure_constructor (gfc_symbol *, gfc_expr **);
+match gfc_match_structure_constructor (gfc_symbol *, gfc_symtree *, gfc_expr
**);
match gfc_match_variable (gfc_expr **, int);
match gfc_match_equiv_variable (gfc_expr **);
match gfc_match_actual_arglist (int, gfc_actual_arglist **, bool = false);
diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index 4f8bd129ee94..328e92b5aefe 100644
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
@@ -3380,18 +3380,16 @@ gfc_convert_to_structure_constructor (gfc_expr *e,
gfc_symbol *sym, gfc_expr **c
match
-gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result)
+gfc_match_structure_constructor (gfc_symbol *sym, gfc_symtree *symtree,
+gfc_expr **result)
{
match m;
gfc_expr *e;
- gfc_symtree *symtree;
bool t = true;
- gfc_get_ha_sym_tree (sym->name, &symtree);
-
e = gfc_get_expr ();
- e->symtree = symtree;
e->expr_type = EXPR_FUNCTION;
+ e->symtree = symtree;
e->where = gfc_current_locus;
gcc_assert (gfc_fl_struct (sym->attr.flavor)
diff --git a/gcc/testsuite/gfortran.dg/use_rename_13.f90
b/gcc/testsuite/gfortran.dg/use_rename_13.f90
new file mode 100644
index ..97f26f42f762
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/use_rename_13.f90
@@ -0,0 +1,37 @@
+! { dg-do compile }
+!
+! Test the fix for pr79685, which failed as in the comments below.
+!
+! Contributed by Juergen Reuter
+!
+module omega_color
+ implicit none
+
+ type omega_color_factor
+ integer :: i
+ end type
+
+ type(omega_color_factor), parameter :: op = omega_color_factor (199)
+
+end module
+
+module foo
+ use omega_color, ocf => omega_color_factor, ocfp => op
+ implicit none
+
+ type(ocf) :: table_color_factors1 = ocf(42)
+ type(ocf) :: table_color_factors2
+ type(ocf) :: table_color_factors3 (2)
+ type(ocf) :: table_color_factors4
+ data table_color_factors2 / ocf(99) /! This failed in
gfc_match_structure_constructor.
+ data table_color_factors3 / ocf(1), ocf(2) / ! ditto.
+ data table_color_factors4 / ocfp /
+end module
+
+ use foo
+ if (table_color_factors1%i .ne. 42) stop 1
+ if (table_color_factors2%i .ne. 99) stop 2
+ if (any (table_color_factors3%i .ne. [1,2])) stop 3
+ if (table_color_factors4%i .ne. 199) stop 4
+end
+
[gcc r14-10863] Fortran: Fix ICE with structure constructor in data statement [PR79685]
https://gcc.gnu.org/g:9a5ee8da09b705fc2a4197453789db0749387db3
commit r14-10863-g9a5ee8da09b705fc2a4197453789db0749387db3
Author: Paul Thomas
Date: Fri Oct 25 17:59:03 2024 +0100
Fortran: Fix ICE with structure constructor in data statement [PR79685]
2024-10-25 Paul Thomas
gcc/fortran
PR fortran/79685
* decl.cc (match_data_constant): Find the symtree instead of
the symbol so the use renamed symbols are found. Pass this and
the derived type to gfc_match_structure_constructor.
* match.h: Update prototype of gfc_match_structure_contructor.
* primary.cc (gfc_match_structure_constructor): Remove call to
gfc_get_ha_sym_tree and use caller supplied symtree instead.
gcc/testsuite/
PR fortran/79685
* gfortran.dg/use_rename_13.f90: New test.
(cherry picked from commit 6cb1da72cac166bd3b005c0430557b68b9761da5)
Diff:
---
gcc/fortran/decl.cc | 7 --
gcc/fortran/match.h | 2 +-
gcc/fortran/primary.cc | 8 +++
gcc/testsuite/gfortran.dg/use_rename_13.f90 | 37 +
4 files changed, 46 insertions(+), 8 deletions(-)
diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index b8308aeee550..119c9dffa033 100644
--- a/gcc/fortran/decl.cc
+++ b/gcc/fortran/decl.cc
@@ -376,6 +376,7 @@ match_data_constant (gfc_expr **result)
gfc_expr *expr;
match m;
locus old_loc;
+ gfc_symtree *symtree;
m = gfc_match_literal_constant (&expr, 1);
if (m == MATCH_YES)
@@ -436,9 +437,11 @@ match_data_constant (gfc_expr **result)
if (m != MATCH_YES)
return m;
- if (gfc_find_symbol (name, NULL, 1, &sym))
+ if (gfc_find_sym_tree (name, NULL, 1, &symtree))
return MATCH_ERROR;
+ sym = symtree->n.sym;
+
if (sym && sym->attr.generic)
dt_sym = gfc_find_dt_in_generic (sym);
@@ -452,7 +455,7 @@ match_data_constant (gfc_expr **result)
return MATCH_ERROR;
}
else if (dt_sym && gfc_fl_struct (dt_sym->attr.flavor))
-return gfc_match_structure_constructor (dt_sym, result);
+return gfc_match_structure_constructor (dt_sym, symtree, result);
/* Check to see if the value is an initialization array expression. */
if (sym->value->expr_type == EXPR_ARRAY)
diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h
index b09921357fd1..e84ec913f78c 100644
--- a/gcc/fortran/match.h
+++ b/gcc/fortran/match.h
@@ -300,7 +300,7 @@ match gfc_match_bind_c_stmt (void);
match gfc_match_bind_c (gfc_symbol *, bool);
/* primary.cc. */
-match gfc_match_structure_constructor (gfc_symbol *, gfc_expr **);
+match gfc_match_structure_constructor (gfc_symbol *, gfc_symtree *, gfc_expr
**);
match gfc_match_variable (gfc_expr **, int);
match gfc_match_equiv_variable (gfc_expr **);
match gfc_match_actual_arglist (int, gfc_actual_arglist **, bool = false);
diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index c4821030ebb5..478fbe2be61e 100644
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
@@ -3520,18 +3520,16 @@ gfc_convert_to_structure_constructor (gfc_expr *e,
gfc_symbol *sym, gfc_expr **c
match
-gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result)
+gfc_match_structure_constructor (gfc_symbol *sym, gfc_symtree *symtree,
+gfc_expr **result)
{
match m;
gfc_expr *e;
- gfc_symtree *symtree;
bool t = true;
- gfc_get_ha_sym_tree (sym->name, &symtree);
-
e = gfc_get_expr ();
- e->symtree = symtree;
e->expr_type = EXPR_FUNCTION;
+ e->symtree = symtree;
e->where = gfc_current_locus;
gcc_assert (gfc_fl_struct (sym->attr.flavor)
diff --git a/gcc/testsuite/gfortran.dg/use_rename_13.f90
b/gcc/testsuite/gfortran.dg/use_rename_13.f90
new file mode 100644
index ..97f26f42f762
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/use_rename_13.f90
@@ -0,0 +1,37 @@
+! { dg-do compile }
+!
+! Test the fix for pr79685, which failed as in the comments below.
+!
+! Contributed by Juergen Reuter
+!
+module omega_color
+ implicit none
+
+ type omega_color_factor
+ integer :: i
+ end type
+
+ type(omega_color_factor), parameter :: op = omega_color_factor (199)
+
+end module
+
+module foo
+ use omega_color, ocf => omega_color_factor, ocfp => op
+ implicit none
+
+ type(ocf) :: table_color_factors1 = ocf(42)
+ type(ocf) :: table_color_factors2
+ type(ocf) :: table_color_factors3 (2)
+ type(ocf) :: table_color_factors4
+ data table_color_factors2 / ocf(99) /! This failed in
gfc_match_structure_constructor.
+ data table_color_factors3 / ocf(1), ocf(2) / ! ditto.
+ data table_color_factors4 / ocfp /
+end module
+
+ use foo
+ if (table_color_factors1%i .ne. 42) stop 1
+ if (table_color_factors2%i .ne. 99) stop 2
+ if (any (table_color_factors3%i .ne. [1,2])) stop 3
+ if (table_color_factors4%i .ne. 199) stop 4
+end
+
[gcc r13-9161] Fortran: Fix ICE with structure constructor in data statement [PR79685]
https://gcc.gnu.org/g:5904017a5e2887ca094b0bb8eb9761435d2a53d1
commit r13-9161-g5904017a5e2887ca094b0bb8eb9761435d2a53d1
Author: Paul Thomas
Date: Fri Oct 25 17:59:03 2024 +0100
Fortran: Fix ICE with structure constructor in data statement [PR79685]
2024-10-25 Paul Thomas
gcc/fortran
PR fortran/79685
* decl.cc (match_data_constant): Find the symtree instead of
the symbol so the use renamed symbols are found. Pass this and
the derived type to gfc_match_structure_constructor.
* match.h: Update prototype of gfc_match_structure_contructor.
* primary.cc (gfc_match_structure_constructor): Remove call to
gfc_get_ha_sym_tree and use caller supplied symtree instead.
gcc/testsuite/
PR fortran/79685
* gfortran.dg/use_rename_13.f90: New test.
(cherry picked from commit 6cb1da72cac166bd3b005c0430557b68b9761da5)
Diff:
---
gcc/fortran/decl.cc | 7 --
gcc/fortran/match.h | 2 +-
gcc/fortran/primary.cc | 8 +++
gcc/testsuite/gfortran.dg/use_rename_13.f90 | 37 +
4 files changed, 46 insertions(+), 8 deletions(-)
diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index 19321685e550..016b8367af86 100644
--- a/gcc/fortran/decl.cc
+++ b/gcc/fortran/decl.cc
@@ -376,6 +376,7 @@ match_data_constant (gfc_expr **result)
gfc_expr *expr;
match m;
locus old_loc;
+ gfc_symtree *symtree;
m = gfc_match_literal_constant (&expr, 1);
if (m == MATCH_YES)
@@ -436,9 +437,11 @@ match_data_constant (gfc_expr **result)
if (m != MATCH_YES)
return m;
- if (gfc_find_symbol (name, NULL, 1, &sym))
+ if (gfc_find_sym_tree (name, NULL, 1, &symtree))
return MATCH_ERROR;
+ sym = symtree->n.sym;
+
if (sym && sym->attr.generic)
dt_sym = gfc_find_dt_in_generic (sym);
@@ -452,7 +455,7 @@ match_data_constant (gfc_expr **result)
return MATCH_ERROR;
}
else if (dt_sym && gfc_fl_struct (dt_sym->attr.flavor))
-return gfc_match_structure_constructor (dt_sym, result);
+return gfc_match_structure_constructor (dt_sym, symtree, result);
/* Check to see if the value is an initialization array expression. */
if (sym->value->expr_type == EXPR_ARRAY)
diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h
index 4430aff001ce..279cb462501b 100644
--- a/gcc/fortran/match.h
+++ b/gcc/fortran/match.h
@@ -298,7 +298,7 @@ match gfc_match_bind_c_stmt (void);
match gfc_match_bind_c (gfc_symbol *, bool);
/* primary.cc. */
-match gfc_match_structure_constructor (gfc_symbol *, gfc_expr **);
+match gfc_match_structure_constructor (gfc_symbol *, gfc_symtree *, gfc_expr
**);
match gfc_match_variable (gfc_expr **, int);
match gfc_match_equiv_variable (gfc_expr **);
match gfc_match_actual_arglist (int, gfc_actual_arglist **, bool = false);
diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index a1b6b74765aa..7093ded9d6d1 100644
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
@@ -3388,18 +3388,16 @@ gfc_convert_to_structure_constructor (gfc_expr *e,
gfc_symbol *sym, gfc_expr **c
match
-gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result)
+gfc_match_structure_constructor (gfc_symbol *sym, gfc_symtree *symtree,
+gfc_expr **result)
{
match m;
gfc_expr *e;
- gfc_symtree *symtree;
bool t = true;
- gfc_get_ha_sym_tree (sym->name, &symtree);
-
e = gfc_get_expr ();
- e->symtree = symtree;
e->expr_type = EXPR_FUNCTION;
+ e->symtree = symtree;
e->where = gfc_current_locus;
gcc_assert (gfc_fl_struct (sym->attr.flavor)
diff --git a/gcc/testsuite/gfortran.dg/use_rename_13.f90
b/gcc/testsuite/gfortran.dg/use_rename_13.f90
new file mode 100644
index ..97f26f42f762
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/use_rename_13.f90
@@ -0,0 +1,37 @@
+! { dg-do compile }
+!
+! Test the fix for pr79685, which failed as in the comments below.
+!
+! Contributed by Juergen Reuter
+!
+module omega_color
+ implicit none
+
+ type omega_color_factor
+ integer :: i
+ end type
+
+ type(omega_color_factor), parameter :: op = omega_color_factor (199)
+
+end module
+
+module foo
+ use omega_color, ocf => omega_color_factor, ocfp => op
+ implicit none
+
+ type(ocf) :: table_color_factors1 = ocf(42)
+ type(ocf) :: table_color_factors2
+ type(ocf) :: table_color_factors3 (2)
+ type(ocf) :: table_color_factors4
+ data table_color_factors2 / ocf(99) /! This failed in
gfc_match_structure_constructor.
+ data table_color_factors3 / ocf(1), ocf(2) / ! ditto.
+ data table_color_factors4 / ocfp /
+end module
+
+ use foo
+ if (table_color_factors1%i .ne. 42) stop 1
+ if (table_color_factors2%i .ne. 99) stop 2
+ if (any (table_color_factors3%i .ne. [1,2])) stop 3
+ if (table_color_factors4%i .ne. 199) stop 4
+end
+
[gcc r15-4768] Fortran: Move pr115070.f90 to ieee directory [PR117335].
https://gcc.gnu.org/g:6f0f202b9f2bc45d82dc3e524508f7a8849be60f
commit r15-4768-g6f0f202b9f2bc45d82dc3e524508f7a8849be60f
Author: Paul Thomas
Date: Wed Oct 30 07:49:52 2024 +
Fortran: Move pr115070.f90 to ieee directory [PR117335].
2024-10-30 Paul Thomas
gcc/testsuite/
PR fortran/117335
* gfortran.dg/pr115070.f90: Delete.
* gfortran.dg/ieee/pr115070.f90: Moved to ieee directory to
prevent failures on incompatible architectures.
Diff:
---
gcc/testsuite/gfortran.dg/{ => ieee}/pr115070.f90 | 0
1 file changed, 0 insertions(+), 0 deletions(-)
diff --git a/gcc/testsuite/gfortran.dg/pr115070.f90
b/gcc/testsuite/gfortran.dg/ieee/pr115070.f90
similarity index 100%
rename from gcc/testsuite/gfortran.dg/pr115070.f90
rename to gcc/testsuite/gfortran.dg/ieee/pr115070.f90
[gcc r12-10785] Fortran: Simplify len_trim with array ref and fix mapping bug[PR84868].
https://gcc.gnu.org/g:b5211c13cf2ca3576ae287b204640516de20ecff
commit r12-10785-gb5211c13cf2ca3576ae287b204640516de20ecff
Author: Paul Thomas
Date: Tue Jul 16 15:56:44 2024 +0100
Fortran: Simplify len_trim with array ref and fix mapping bug[PR84868].
2024-07-16 Paul Thomas
gcc/fortran
PR fortran/84868
* simplify.cc (gfc_simplify_len_trim): If the argument is an
element of a parameter array, simplify all the elements and
build a new parameter array to hold the result, after checking
that it doesn't already exist.
* trans-expr.cc (gfc_get_interface_mapping_array) if a string
length is available, use it for the typespec.
(gfc_add_interface_mapping): Supply the se string length.
gcc/testsuite/
PR fortran/84868
* gfortran.dg/pr84868.f90: New test.
(cherry picked from commit 9f966b6a8ff0244dd6f8bf36d876799d5f9bbaee)
Diff:
---
gcc/fortran/simplify.cc | 75 +++
gcc/fortran/trans-expr.cc | 18 +---
gcc/testsuite/gfortran.dg/pr84868.f90 | 84 +++
3 files changed, 171 insertions(+), 6 deletions(-)
diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc
index a10f79c4a932..b8935eb0118b 100644
--- a/gcc/fortran/simplify.cc
+++ b/gcc/fortran/simplify.cc
@@ -4582,6 +4582,81 @@ gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind)
if (k == -1)
return &gfc_bad_expr;
+ /* If the expression is either an array element or section, an array
+ parameter must be built so that the reference can be applied. Constant
+ references should have already been simplified away. All other cases
+ can proceed to translation, where kind conversion will occur silently. */
+ if (e->expr_type == EXPR_VARIABLE
+ && e->ts.type == BT_CHARACTER
+ && e->symtree->n.sym->attr.flavor == FL_PARAMETER
+ && e->ref && e->ref->type == REF_ARRAY
+ && e->ref->u.ar.type != AR_FULL
+ && e->symtree->n.sym->value)
+{
+ char name[2*GFC_MAX_SYMBOL_LEN + 12];
+ gfc_namespace *ns = e->symtree->n.sym->ns;
+ gfc_symtree *st;
+ gfc_expr *expr;
+ gfc_expr *p;
+ gfc_constructor *c;
+ int cnt = 0;
+
+ sprintf (name, "_len_trim_%s_%s", e->symtree->n.sym->name,
+ ns->proc_name->name);
+ st = gfc_find_symtree (ns->sym_root, name);
+ if (st)
+ goto already_built;
+
+ /* Recursively call this fcn to simplify the constructor elements. */
+ expr = gfc_copy_expr (e->symtree->n.sym->value);
+ expr->ts.type = BT_INTEGER;
+ expr->ts.kind = k;
+ expr->ts.u.cl = NULL;
+ c = gfc_constructor_first (expr->value.constructor);
+ for (; c; c = gfc_constructor_next (c))
+ {
+ if (c->iterator)
+ continue;
+
+ if (c->expr && c->expr->ts.type == BT_CHARACTER)
+ {
+ p = gfc_simplify_len_trim (c->expr, kind);
+ if (p == NULL)
+ goto clean_up;
+ gfc_replace_expr (c->expr, p);
+ cnt++;
+ }
+ }
+
+ if (cnt)
+ {
+ /* Build a new parameter to take the result. */
+ st = gfc_new_symtree (&ns->sym_root, name);
+ st->n.sym = gfc_new_symbol (st->name, ns);
+ st->n.sym->value = expr;
+ st->n.sym->ts = expr->ts;
+ st->n.sym->attr.dimension = 1;
+ st->n.sym->attr.save = SAVE_IMPLICIT;
+ st->n.sym->attr.flavor = FL_PARAMETER;
+ st->n.sym->as = gfc_copy_array_spec (e->symtree->n.sym->as);
+ gfc_set_sym_referenced (st->n.sym);
+ st->n.sym->refs++;
+ gfc_commit_symbol (st->n.sym);
+
+already_built:
+ /* Build a return expression. */
+ expr = gfc_copy_expr (e);
+ expr->ts = st->n.sym->ts;
+ expr->symtree = st;
+ gfc_expression_rank (expr);
+ return expr;
+ }
+
+clean_up:
+ gfc_free_expr (expr);
+ return NULL;
+}
+
if (e->expr_type != EXPR_CONSTANT)
return NULL;
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index e78a01003c9c..54cf246fd0d7 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -4326,12 +4326,15 @@ gfc_get_interface_mapping_charlen
(gfc_interface_mapping * mapping,
static tree
gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
-gfc_packed packed, tree data)
+gfc_packed packed, tree data, tree len)
{
tree type;
tree var;
- type = gfc_typenode_for_spec (&sym->ts);
+ if (len != NULL_TREE && (TREE_CONSTANT (len) || VAR_P (len)))
+type = gfc_get_character_type_len (sym->ts.kind, len);
+ else
+type = gfc_typenode_for_spec (&sym->ts);
type = gfc_get_nodesc_array_type (type, sym->as, packed,
!sym->attr.tar
[gcc r14-10834] Fortran: Simplify len_trim with array ref and fix mapping bug[PR84868].
https://gcc.gnu.org/g:944d585d8a566e50a287eb64caf9af0e90daf5dd
commit r14-10834-g944d585d8a566e50a287eb64caf9af0e90daf5dd
Author: Paul Thomas
Date: Tue Jul 16 15:56:44 2024 +0100
Fortran: Simplify len_trim with array ref and fix mapping bug[PR84868].
2024-07-16 Paul Thomas
gcc/fortran
PR fortran/84868
* simplify.cc (gfc_simplify_len_trim): If the argument is an
element of a parameter array, simplify all the elements and
build a new parameter array to hold the result, after checking
that it doesn't already exist.
* trans-expr.cc (gfc_get_interface_mapping_array) if a string
length is available, use it for the typespec.
(gfc_add_interface_mapping): Supply the se string length.
gcc/testsuite/
PR fortran/84868
* gfortran.dg/pr84868.f90: New test.
(cherry picked from commit 9f966b6a8ff0244dd6f8bf36d876799d5f9bbaee)
Diff:
---
gcc/fortran/simplify.cc | 75 +++
gcc/fortran/trans-expr.cc | 18 +---
gcc/testsuite/gfortran.dg/pr84868.f90 | 84 +++
3 files changed, 171 insertions(+), 6 deletions(-)
diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc
index 3043483daa90..cc2ccfe13afe 100644
--- a/gcc/fortran/simplify.cc
+++ b/gcc/fortran/simplify.cc
@@ -4637,6 +4637,81 @@ gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind)
if (k == -1)
return &gfc_bad_expr;
+ /* If the expression is either an array element or section, an array
+ parameter must be built so that the reference can be applied. Constant
+ references should have already been simplified away. All other cases
+ can proceed to translation, where kind conversion will occur silently. */
+ if (e->expr_type == EXPR_VARIABLE
+ && e->ts.type == BT_CHARACTER
+ && e->symtree->n.sym->attr.flavor == FL_PARAMETER
+ && e->ref && e->ref->type == REF_ARRAY
+ && e->ref->u.ar.type != AR_FULL
+ && e->symtree->n.sym->value)
+{
+ char name[2*GFC_MAX_SYMBOL_LEN + 12];
+ gfc_namespace *ns = e->symtree->n.sym->ns;
+ gfc_symtree *st;
+ gfc_expr *expr;
+ gfc_expr *p;
+ gfc_constructor *c;
+ int cnt = 0;
+
+ sprintf (name, "_len_trim_%s_%s", e->symtree->n.sym->name,
+ ns->proc_name->name);
+ st = gfc_find_symtree (ns->sym_root, name);
+ if (st)
+ goto already_built;
+
+ /* Recursively call this fcn to simplify the constructor elements. */
+ expr = gfc_copy_expr (e->symtree->n.sym->value);
+ expr->ts.type = BT_INTEGER;
+ expr->ts.kind = k;
+ expr->ts.u.cl = NULL;
+ c = gfc_constructor_first (expr->value.constructor);
+ for (; c; c = gfc_constructor_next (c))
+ {
+ if (c->iterator)
+ continue;
+
+ if (c->expr && c->expr->ts.type == BT_CHARACTER)
+ {
+ p = gfc_simplify_len_trim (c->expr, kind);
+ if (p == NULL)
+ goto clean_up;
+ gfc_replace_expr (c->expr, p);
+ cnt++;
+ }
+ }
+
+ if (cnt)
+ {
+ /* Build a new parameter to take the result. */
+ st = gfc_new_symtree (&ns->sym_root, name);
+ st->n.sym = gfc_new_symbol (st->name, ns);
+ st->n.sym->value = expr;
+ st->n.sym->ts = expr->ts;
+ st->n.sym->attr.dimension = 1;
+ st->n.sym->attr.save = SAVE_IMPLICIT;
+ st->n.sym->attr.flavor = FL_PARAMETER;
+ st->n.sym->as = gfc_copy_array_spec (e->symtree->n.sym->as);
+ gfc_set_sym_referenced (st->n.sym);
+ st->n.sym->refs++;
+ gfc_commit_symbol (st->n.sym);
+
+already_built:
+ /* Build a return expression. */
+ expr = gfc_copy_expr (e);
+ expr->ts = st->n.sym->ts;
+ expr->symtree = st;
+ gfc_expression_rank (expr);
+ return expr;
+ }
+
+clean_up:
+ gfc_free_expr (expr);
+ return NULL;
+}
+
if (e->expr_type != EXPR_CONSTANT)
return NULL;
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index dfc5b8e9b4a5..3a5a41401858 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -4424,12 +4424,15 @@ gfc_get_interface_mapping_charlen
(gfc_interface_mapping * mapping,
static tree
gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
-gfc_packed packed, tree data)
+gfc_packed packed, tree data, tree len)
{
tree type;
tree var;
- type = gfc_typenode_for_spec (&sym->ts);
+ if (len != NULL_TREE && (TREE_CONSTANT (len) || VAR_P (len)))
+type = gfc_get_character_type_len (sym->ts.kind, len);
+ else
+type = gfc_typenode_for_spec (&sym->ts);
type = gfc_get_nodesc_array_type (type, sym->as, packed,
!sym->attr.tar
[gcc r13-9147] Fortran: Simplify len_trim with array ref and fix mapping bug[PR84868].
https://gcc.gnu.org/g:457a3bb146eb83ffc229d0658cb21317187c38ab
commit r13-9147-g457a3bb146eb83ffc229d0658cb21317187c38ab
Author: Paul Thomas
Date: Tue Jul 16 15:56:44 2024 +0100
Fortran: Simplify len_trim with array ref and fix mapping bug[PR84868].
2024-07-16 Paul Thomas
gcc/fortran
PR fortran/84868
* simplify.cc (gfc_simplify_len_trim): If the argument is an
element of a parameter array, simplify all the elements and
build a new parameter array to hold the result, after checking
that it doesn't already exist.
* trans-expr.cc (gfc_get_interface_mapping_array) if a string
length is available, use it for the typespec.
(gfc_add_interface_mapping): Supply the se string length.
gcc/testsuite/
PR fortran/84868
* gfortran.dg/pr84868.f90: New test.
(cherry picked from commit 9f966b6a8ff0244dd6f8bf36d876799d5f9bbaee)
Diff:
---
gcc/fortran/simplify.cc | 75 +++
gcc/fortran/trans-expr.cc | 18 +---
gcc/testsuite/gfortran.dg/pr84868.f90 | 84 +++
3 files changed, 171 insertions(+), 6 deletions(-)
diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc
index fe700097b7b0..1d0af095de51 100644
--- a/gcc/fortran/simplify.cc
+++ b/gcc/fortran/simplify.cc
@@ -4623,6 +4623,81 @@ gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind)
if (k == -1)
return &gfc_bad_expr;
+ /* If the expression is either an array element or section, an array
+ parameter must be built so that the reference can be applied. Constant
+ references should have already been simplified away. All other cases
+ can proceed to translation, where kind conversion will occur silently. */
+ if (e->expr_type == EXPR_VARIABLE
+ && e->ts.type == BT_CHARACTER
+ && e->symtree->n.sym->attr.flavor == FL_PARAMETER
+ && e->ref && e->ref->type == REF_ARRAY
+ && e->ref->u.ar.type != AR_FULL
+ && e->symtree->n.sym->value)
+{
+ char name[2*GFC_MAX_SYMBOL_LEN + 12];
+ gfc_namespace *ns = e->symtree->n.sym->ns;
+ gfc_symtree *st;
+ gfc_expr *expr;
+ gfc_expr *p;
+ gfc_constructor *c;
+ int cnt = 0;
+
+ sprintf (name, "_len_trim_%s_%s", e->symtree->n.sym->name,
+ ns->proc_name->name);
+ st = gfc_find_symtree (ns->sym_root, name);
+ if (st)
+ goto already_built;
+
+ /* Recursively call this fcn to simplify the constructor elements. */
+ expr = gfc_copy_expr (e->symtree->n.sym->value);
+ expr->ts.type = BT_INTEGER;
+ expr->ts.kind = k;
+ expr->ts.u.cl = NULL;
+ c = gfc_constructor_first (expr->value.constructor);
+ for (; c; c = gfc_constructor_next (c))
+ {
+ if (c->iterator)
+ continue;
+
+ if (c->expr && c->expr->ts.type == BT_CHARACTER)
+ {
+ p = gfc_simplify_len_trim (c->expr, kind);
+ if (p == NULL)
+ goto clean_up;
+ gfc_replace_expr (c->expr, p);
+ cnt++;
+ }
+ }
+
+ if (cnt)
+ {
+ /* Build a new parameter to take the result. */
+ st = gfc_new_symtree (&ns->sym_root, name);
+ st->n.sym = gfc_new_symbol (st->name, ns);
+ st->n.sym->value = expr;
+ st->n.sym->ts = expr->ts;
+ st->n.sym->attr.dimension = 1;
+ st->n.sym->attr.save = SAVE_IMPLICIT;
+ st->n.sym->attr.flavor = FL_PARAMETER;
+ st->n.sym->as = gfc_copy_array_spec (e->symtree->n.sym->as);
+ gfc_set_sym_referenced (st->n.sym);
+ st->n.sym->refs++;
+ gfc_commit_symbol (st->n.sym);
+
+already_built:
+ /* Build a return expression. */
+ expr = gfc_copy_expr (e);
+ expr->ts = st->n.sym->ts;
+ expr->symtree = st;
+ gfc_expression_rank (expr);
+ return expr;
+ }
+
+clean_up:
+ gfc_free_expr (expr);
+ return NULL;
+}
+
if (e->expr_type != EXPR_CONSTANT)
return NULL;
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 657f1cb649b4..7e3c38e5f92d 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -4366,12 +4366,15 @@ gfc_get_interface_mapping_charlen
(gfc_interface_mapping * mapping,
static tree
gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
-gfc_packed packed, tree data)
+gfc_packed packed, tree data, tree len)
{
tree type;
tree var;
- type = gfc_typenode_for_spec (&sym->ts);
+ if (len != NULL_TREE && (TREE_CONSTANT (len) || VAR_P (len)))
+type = gfc_get_character_type_len (sym->ts.kind, len);
+ else
+type = gfc_typenode_for_spec (&sym->ts);
type = gfc_get_nodesc_array_type (type, sym->as, packed,
!sym->attr.targ
[gcc r15-4974] Fortran: F2008 passing of internal procs to a proc pointer [PR117434]
https://gcc.gnu.org/g:4dbf4c0fdb188e1c348688de91e010f696cd59fc
commit r15-4974-g4dbf4c0fdb188e1c348688de91e010f696cd59fc
Author: Paul Thomas
Date: Wed Nov 6 07:17:25 2024 +
Fortran: F2008 passing of internal procs to a proc pointer [PR117434]
2024-11-06 Paul Thomas
gcc/fortran
PR fortran/117434
* interface.cc (gfc_compare_actual_formal): Skip 'Expected a
procedure pointer error' if the formal argument typespec has an
interface and the type of the actual arg is BT_PROCEDURE.
gcc/testsuite/
PR fortran/117434
* gfortran.dg/proc_ptr_54.f90: New test. This is temporarily
compile-only until one one seven four five five is fixed.
* gfortran.dg/proc_ptr_55.f90: New test.
* gfortran.dg/proc_ptr_56.f90: New test.
Diff:
---
gcc/fortran/interface.cc | 9 ++-
gcc/testsuite/gfortran.dg/proc_ptr_54.f90 | 95 +++
gcc/testsuite/gfortran.dg/proc_ptr_55.f90 | 87
gcc/testsuite/gfortran.dg/proc_ptr_56.f90 | 45 +++
4 files changed, 234 insertions(+), 2 deletions(-)
diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc
index 69519fe3168e..61c506bfdb5d 100644
--- a/gcc/fortran/interface.cc
+++ b/gcc/fortran/interface.cc
@@ -3513,12 +3513,17 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap,
gfc_formal_arglist *formal,
skip_size_check:
- /* Satisfy F03:12.4.1.3 by ensuring that a procedure pointer actual
- argument is provided for a procedure pointer formal argument. */
+ /* Satisfy either: F03:12.4.1.3 by ensuring that a procedure pointer
+actual argument is provided for a procedure pointer formal argument;
+or: F08:12.5.2.9 (F18:15.5.2.10) by ensuring that the effective
+argument shall be an external, internal, module, or dummy procedure.
+The interfaces are checked elsewhere. */
if (f->sym->attr.proc_pointer
&& !((a->expr->expr_type == EXPR_VARIABLE
&& (a->expr->symtree->n.sym->attr.proc_pointer
|| gfc_is_proc_ptr_comp (a->expr)))
+ || (a->expr->ts.type == BT_PROCEDURE
+ && f->sym->ts.interface)
|| (a->expr->expr_type == EXPR_FUNCTION
&& is_procptr_result (a->expr
{
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_54.f90
b/gcc/testsuite/gfortran.dg/proc_ptr_54.f90
new file mode 100644
index ..e03ecb507400
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_54.f90
@@ -0,0 +1,95 @@
+! { dg-do compile }
+!
+! Test the fix for pr117434, in which the F2008 addition of being permitted to
+! pass an external, internal or module procedure to a dummy procedure pointer
+! gave the error "Expected a procedure pointer for argument ‘’ at
(1).
+!
+! This testcase checks for correct results.
+!
+! Contributed by Damian Rouson
+!
+module julienne_test_description_m
+ implicit none
+
+ abstract interface
+logical function test_function_i(arg)
+ integer, intent(in) :: arg
+end function
+ end interface
+
+ type test_description_t
+procedure(test_function_i), pointer, nopass :: test_function_
+ end type
+
+
+contains
+
+ type(test_description_t) function new_test_description(test_function)
+procedure(test_function_i), intent(in), pointer :: test_function
+new_test_description%test_function_ => test_function
+ end function
+
+end module
+
+module test_mod
+
+contains
+
+ logical function mod_test(arg)
+integer, intent(in) :: arg
+if (arg == 1) then
+ mod_test = .true.
+else
+ mod_test = .false.
+endif
+ end function
+
+end
+
+logical function ext_test(arg)
+ integer, intent(in) :: arg
+ if (arg == 2) then
+ext_test = .true.
+ else
+ext_test = .false.
+ endif
+end function
+
+ use julienne_test_description_m
+ use test_mod
+ implicit none
+ type(test_description_t) test_description
+
+ interface
+logical function ext_test(arg)
+ integer, intent(in) :: arg
+end function
+ end interface
+
+ test_description = new_test_description(test)
+ if (test_description%test_function_(1) &
+ .or. test_description%test_function_(2) &
+ .or. .not.test_description%test_function_(3)) stop 1
+
+ test_description = new_test_description(mod_test)
+ if (test_description%test_function_(2) &
+ .or. test_description%test_function_(3) &
+ .or. .not.test_description%test_function_(1)) stop 2
+
+ test_description = new_test_description(ext_test)
+ if (test_description%test_function_(1) &
+ .or. test_description%test_function_(3) &
+ .or. .not.test_description%test_function_(2)) stop 3
+
+contains
+
+ logical function test(arg)
+integer, intent(in) :: arg
+if (arg == 3) then
+ test = .true.
+else
+ test = .false.
+endif
+ end function
+
+end
diff --git a/gcc/testsuit
[gcc r13-9212] Fortran: Fix segfault in allocation of unlimited poly array [PR84869]
https://gcc.gnu.org/g:e78a0cb8604cd3e0fdbc606ed5e7094b646ded02
commit r13-9212-ge78a0cb8604cd3e0fdbc606ed5e7094b646ded02
Author: Paul Thomas
Date: Sun Nov 24 14:22:06 2024 +
Fortran: Fix segfault in allocation of unlimited poly array [PR84869]
2024-11-24 Paul Thomas
gcc/fortran/ChangeLog
PR fortran/84869
* trans-expr.cc (trans_class_vptr_len_assignment): To access
the '_len' field, 're' must be unlimited polymorphic.
gcc/testsuite/
PR fortran/84869
* gfortran.dg/pr84869.f90: Comment out test of component refs.
(cherry picked from commit 911a870a6198a2fe50af8bbeb63de1dfaa90de0e)
Diff:
---
gcc/fortran/trans-expr.cc | 2 +-
gcc/testsuite/gfortran.dg/pr84869.f90 | 25 +
2 files changed, 26 insertions(+), 1 deletion(-)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 59a7ff8d8d06..df109bd40547 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -9856,7 +9856,7 @@ trans_class_vptr_len_assignment (stmtblock_t *block,
gfc_expr * le,
vptr_expr = NULL;
se.expr = gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR (
re->symtree->n.sym->backend_decl));
- if (to_len)
+ if (to_len && UNLIMITED_POLY (re))
from_len = gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR (
re->symtree->n.sym->backend_decl));
}
diff --git a/gcc/testsuite/gfortran.dg/pr84869.f90
b/gcc/testsuite/gfortran.dg/pr84869.f90
new file mode 100644
index ..fe40b6208047
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr84869.f90
@@ -0,0 +1,25 @@
+! { dg-do compile }
+!
+! Test the fix for PR84869, where line 19 segfaulted.
+!
+! Contributed by Gerhard Steinmetz
+!
+program p
+ type t
+ integer :: i
+ end type
+ call s
+contains
+ function f()
+ class(t), allocatable :: f(:)
+ f = [(t(i), i = 1, 10)]
+ end
+ subroutine s
+ class(*), allocatable :: z(:)
+ allocate (z, source = f ()) ! Segfault in gfc_class_len_get.
+ select type (z)
+type is (t)
+ if (any (z%i /= [(i, i = 1,10)])) stop 1
+ end select
+ end
+end
[gcc r15-5347] Fortran: Fix segmentation fault in defined assignment [PR109066]
https://gcc.gnu.org/g:27ff8049bbdb0a001ba46835cd6a334c4ac76573
commit r15-5347-g27ff8049bbdb0a001ba46835cd6a334c4ac76573
Author: Paul Thomas
Date: Sat Nov 16 15:56:10 2024 +
Fortran: Fix segmentation fault in defined assignment [PR109066]
2024-11-16 Paul Thomas
gcc/fortran
PR fortran/109066
* resolve.cc (generate_component_assignments): If the temporary
for 'var' is a pointer and 'expr' is neither a constant or
a variable, change its attribute from pointer to allocatable.
This avoids assignment to a temporary point that has neither
been allocated or associated.
gcc/testsuite/
PR fortran/109066
* gfortran.dg/defined_assignment_12.f90: New test.
Diff:
---
gcc/fortran/resolve.cc | 5 ++
.../gfortran.dg/defined_assignment_12.f90 | 61 ++
2 files changed, 66 insertions(+)
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index b8c908b51e92..e8f780d1ef96 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -12404,6 +12404,11 @@ generate_component_assignments (gfc_code **code,
gfc_namespace *ns)
{
/* Assign the rhs to the temporary. */
tmp_expr = get_temp_from_expr ((*code)->expr1, ns);
+ if (tmp_expr->symtree->n.sym->attr.pointer)
+ {
+ tmp_expr->symtree->n.sym->attr.pointer = 0;
+ tmp_expr->symtree->n.sym->attr.allocatable = 1;
+ }
this_code = build_assignment (EXEC_ASSIGN,
tmp_expr, (*code)->expr2,
NULL, NULL, (*code)->loc);
diff --git a/gcc/testsuite/gfortran.dg/defined_assignment_12.f90
b/gcc/testsuite/gfortran.dg/defined_assignment_12.f90
new file mode 100644
index ..57445abe25c4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/defined_assignment_12.f90
@@ -0,0 +1,61 @@
+! { dg-do run }
+!
+! Test fix of PR109066, which caused segfaults as below
+!
+! Contributed by Andrew Benson
+!
+module bugMod
+
+ type :: rm
+ integer :: c=0
+ contains
+ procedure :: rma
+ generic :: assignment(=) => rma
+ end type rm
+
+ type :: lc
+ type(rm) :: lm
+ end type lc
+
+contains
+
+ impure elemental subroutine rma(to,from)
+implicit none
+class(rm), intent(out) :: to
+class(rm), intent(in) :: from
+to%c = -from%c
+return
+ end subroutine rma
+
+end module bugMod
+
+program bug
+ use bugMod
+ implicit none
+ type(lc), pointer :: i, j(:)
+
+ allocate (i)
+ i = lc (rm (1)) ! Segmentation fault
+ if (i%lm%c .ne. -1) stop 1
+ i = i_ptr () ! Segmentation fault
+ if (i%lm%c .ne. 1) stop 2
+
+ allocate (j(2))
+ j = [lc (rm (2)), lc (rm (3))] ! Segmentation fault
+ if (any (j%lm%c .ne. [-2,-3])) stop 3
+ j = j_ptr () ! Worked!
+ if (any (j%lm%c .ne. [2,3])) stop 4
+
+contains
+
+ function i_ptr () result(res)
+type(lc), pointer :: res
+res => i
+ end function
+
+ function j_ptr () result(res)
+type(lc), pointer :: res (:)
+res => j
+ end function
+
+end program bug
[gcc r14-10977] Fortran: Fix segfault in allocation of unlimited poly array [PR84869]
https://gcc.gnu.org/g:911a870a6198a2fe50af8bbeb63de1dfaa90de0e
commit r14-10977-g911a870a6198a2fe50af8bbeb63de1dfaa90de0e
Author: Paul Thomas
Date: Sun Nov 24 14:22:06 2024 +
Fortran: Fix segfault in allocation of unlimited poly array [PR84869]
2024-11-24 Paul Thomas
gcc/fortran/ChangeLog
PR fortran/84869
* trans-expr.cc (trans_class_vptr_len_assignment): To access
the '_len' field, 're' must be unlimited polymorphic.
gcc/testsuite/
PR fortran/84869
* gfortran.dg/pr84869.f90: Comment out test of component refs.
Diff:
---
gcc/fortran/trans-expr.cc | 2 +-
gcc/testsuite/gfortran.dg/pr84869.f90 | 25 +
2 files changed, 26 insertions(+), 1 deletion(-)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 80399fe3c4f7..c9275e7ba82c 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -10232,7 +10232,7 @@ trans_class_vptr_len_assignment (stmtblock_t *block,
gfc_expr * le,
vptr_expr = NULL;
se.expr = gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR (
re->symtree->n.sym->backend_decl));
- if (to_len)
+ if (to_len && UNLIMITED_POLY (re))
from_len = gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR (
re->symtree->n.sym->backend_decl));
}
diff --git a/gcc/testsuite/gfortran.dg/pr84869.f90
b/gcc/testsuite/gfortran.dg/pr84869.f90
new file mode 100644
index ..fe40b6208047
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr84869.f90
@@ -0,0 +1,25 @@
+! { dg-do compile }
+!
+! Test the fix for PR84869, where line 19 segfaulted.
+!
+! Contributed by Gerhard Steinmetz
+!
+program p
+ type t
+ integer :: i
+ end type
+ call s
+contains
+ function f()
+ class(t), allocatable :: f(:)
+ f = [(t(i), i = 1, 10)]
+ end
+ subroutine s
+ class(*), allocatable :: z(:)
+ allocate (z, source = f ()) ! Segfault in gfc_class_len_get.
+ select type (z)
+type is (t)
+ if (any (z%i /= [(i, i = 1,10)])) stop 1
+ end select
+ end
+end
[gcc r13-9211] Fortran: Suppress failing part of testcase [PR109345]
https://gcc.gnu.org/g:0794ca02b47935cd672f74815023d708e5e262e1 commit r13-9211-g0794ca02b47935cd672f74815023d708e5e262e1 Author: Paul Thomas Date: Sun Nov 24 14:25:37 2024 + Fortran: Suppress failing part of testcase [PR109345] 2024-11-24 Paul Thomas gcc/testsuite/ PR fortran/109345 * gfortran.dg/pr109345.f90: Comment out test of component refs. Diff: --- gcc/testsuite/gfortran.dg/pr109345.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/gcc/testsuite/gfortran.dg/pr109345.f90 b/gcc/testsuite/gfortran.dg/pr109345.f90 index cff9aaa987a0..5f59bef00078 100644 --- a/gcc/testsuite/gfortran.dg/pr109345.f90 +++ b/gcc/testsuite/gfortran.dg/pr109345.f90 @@ -31,7 +31,7 @@ program test ! Test component references call foo (str_t%str_array(1), .true.) ! Test component references and that array offset is correct. - call foo (str_t(2:3)%i) +! call foo (str_t(2:3)%i) ! Does not work in 13-branch contains subroutine foo (var, flag) @@ -57,7 +57,7 @@ contains if (any (var /= str_array4(1))) stop 6 end if do i = 1, size(var) -! Elemental array references did not work. +! Elemental array references did not work. (Does not work in 13-branch) if (var(i) /= var(1)) then if (present (flag)) stop 7 if (trim (var(i)) /= trim (str_array4(i))) stop 8
[gcc r15-5629] Fortran: Fix segfault in allocation of unlimited poly array [PR85869]
https://gcc.gnu.org/g:470ebd31843db58fc503ccef38b82d0da93c65e4
commit r15-5629-g470ebd31843db58fc503ccef38b82d0da93c65e4
Author: Paul Thomas
Date: Sun Nov 24 12:01:32 2024 +
Fortran: Fix segfault in allocation of unlimited poly array [PR85869]
2024-11-24 Paul Thomas
gcc/fortran/ChangeLog
PR fortran/85869
* trans-expr.cc (trans_class_vptr_len_assignment): To access
the '_len' field, re must be unlimited polymorphic.
gcc/testsuite/
PR fortran/85869
* gfortran.dg/pr85869.f90: Comment out test of component refs.
Diff:
---
gcc/fortran/trans-expr.cc | 3 ++-
gcc/testsuite/gfortran.dg/pr85869.f90 | 25 +
2 files changed, 27 insertions(+), 1 deletion(-)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 7013dd3a4119..bc1d5a87307d 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -21,6 +21,7 @@ along with GCC; see the file COPYING3. If not see
/* trans-expr.cc-- generate GENERIC trees for gfc_expr. */
+#define INCLUDE_MEMORY
#include "config.h"
#include "system.h"
#include "coretypes.h"
@@ -10421,7 +10422,7 @@ trans_class_vptr_len_assignment (stmtblock_t *block,
gfc_expr * le,
vptr_expr = NULL;
se.expr = gfc_class_vptr_get (GFC_DECL_SAVED_DESCRIPTOR (
re->symtree->n.sym->backend_decl));
- if (to_len)
+ if (to_len && UNLIMITED_POLY (re))
from_len = gfc_class_len_get (GFC_DECL_SAVED_DESCRIPTOR (
re->symtree->n.sym->backend_decl));
}
diff --git a/gcc/testsuite/gfortran.dg/pr85869.f90
b/gcc/testsuite/gfortran.dg/pr85869.f90
new file mode 100644
index ..24caeb486f23
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr85869.f90
@@ -0,0 +1,25 @@
+! { dg-do compile }
+!
+! Test the fix for PR85869, where line 19 segfaulted.
+!
+! Contributed by Gerhard Steinmetz
+!
+program p
+ type t
+ integer :: i
+ end type
+ call s
+contains
+ function f()
+ class(t), allocatable :: f(:)
+ f = [(t(i), i = 1, 10)]
+ end
+ subroutine s
+ class(*), allocatable :: z(:)
+ allocate (z, source = f ()) ! Segfault in gfc_class_len_get.
+ select type (z)
+type is (t)
+ if (any (z%i /= [(i, i = 1,10)])) stop 1
+ end select
+ end
+end
[gcc r15-5630] Fortran: Correct name of testcase [PR84869]
https://gcc.gnu.org/g:aa09e32c4d4ebdd58f677a7ecbdcb93cce84823d
commit r15-5630-gaa09e32c4d4ebdd58f677a7ecbdcb93cce84823d
Author: Paul Thomas
Date: Sun Nov 24 14:01:21 2024 +
Fortran: Correct name of testcase [PR84869]
2024-11-24 Paul Thomas
gcc/testsuite/
PR fortran/84869
* gfortran.dg/pr84869.f90: Copy of test below with number
corrected.
* gfortran.dg/pr85869.f90: deleted.
Diff:
---
gcc/testsuite/gfortran.dg/{pr85869.f90 => pr84869.f90} | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/gcc/testsuite/gfortran.dg/pr85869.f90
b/gcc/testsuite/gfortran.dg/pr84869.f90
similarity index 89%
rename from gcc/testsuite/gfortran.dg/pr85869.f90
rename to gcc/testsuite/gfortran.dg/pr84869.f90
index 24caeb486f23..fe40b6208047 100644
--- a/gcc/testsuite/gfortran.dg/pr85869.f90
+++ b/gcc/testsuite/gfortran.dg/pr84869.f90
@@ -1,6 +1,6 @@
! { dg-do compile }
!
-! Test the fix for PR85869, where line 19 segfaulted.
+! Test the fix for PR84869, where line 19 segfaulted.
!
! Contributed by Gerhard Steinmetz
!
[gcc r15-5628] Fortran: Fix non_overridable typebound proc problems [PR84674/117730].
https://gcc.gnu.org/g:dd6dbbb5111fba960ad0ee7999a225783e0ae80e
commit r15-5628-gdd6dbbb5111fba960ad0ee7999a225783e0ae80e
Author: Paul Thomas
Date: Sun Nov 24 08:50:58 2024 +
Fortran: Fix non_overridable typebound proc problems [PR84674/117730].
2024-11-24 Paul Thomas
gcc/fortran/ChangeLog
PR fortran/117730
* class.cc (add_proc_comp): Only reject a non_overridable if it
has no overridden procedure and the component is already
present in the vtype.
PR fortran/84674
* resolve.cc (resolve_fl_derived): Do not build a vtable for a
derived type extension that is completely empty.
gcc/testsuite/ChangeLog
PR fortran/117730
* gfortran.dg/pr117730_a.f90: New test.
* gfortran.dg/pr117730_b.f90: New test.
PR fortran/84674
* gfortran.dg/pr84674.f90: New test.
Diff:
---
gcc/fortran/class.cc | 5 +--
gcc/fortran/resolve.cc | 4 +++
gcc/testsuite/gfortran.dg/pr117730_a.f90 | 50 +
gcc/testsuite/gfortran.dg/pr117730_b.f90 | 47 +++
gcc/testsuite/gfortran.dg/pr84674.f90| 55
5 files changed, 159 insertions(+), 2 deletions(-)
diff --git a/gcc/fortran/class.cc b/gcc/fortran/class.cc
index da09d210b4b5..59ac0d97e080 100644
--- a/gcc/fortran/class.cc
+++ b/gcc/fortran/class.cc
@@ -885,11 +885,12 @@ add_proc_comp (gfc_symbol *vtype, const char *name,
gfc_typebound_proc *tb)
{
gfc_component *c;
- if (tb->non_overridable && !tb->overridden)
-return;
c = gfc_find_component (vtype, name, true, true, NULL);
+ if (tb->non_overridable && !tb->overridden && c)
+return;
+
if (c == NULL)
{
/* Add procedure component. */
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index b817192cd930..b1740cec3881 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -16287,6 +16287,10 @@ resolve_fl_derived (gfc_symbol *sym)
&& sym->ns->proc_name
&& sym->ns->proc_name->attr.flavor == FL_MODULE
&& sym->attr.access != ACCESS_PRIVATE
+ && !(sym->attr.extension
+ && sym->attr.zero_comp
+ && !sym->f2k_derived->tb_sym_root
+ && !sym->f2k_derived->tb_uop_root)
&& !(sym->attr.vtype || sym->attr.pdt_template))
{
gfc_symbol *vtab = gfc_find_derived_vtab (sym);
diff --git a/gcc/testsuite/gfortran.dg/pr117730_a.f90
b/gcc/testsuite/gfortran.dg/pr117730_a.f90
new file mode 100644
index ..12e28214b02b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr117730_a.f90
@@ -0,0 +1,50 @@
+! { dg-do compile }
+!
+! Test the fix for PR117730 in which the non_overrridable procedures in 'child'
+! were mixied up in the vtable for the extension 'child2' in pr117730_b.f90.
+! This resulted in 'this%calc()' in 'function child_get(this)' returning
garbage
+! when 'this' was of dynamic type 'child2'.
+!
+! Contributed by in comment 4 of PR84674.
+!
+module module1
+implicit none
+private
+public :: child
+
+type, abstract :: parent
+contains
+procedure, pass :: reset => parent_reset
+end type parent
+
+type, extends(parent), abstract :: child
+contains
+procedure, pass, non_overridable :: reset => child_reset
+procedure, pass, non_overridable :: get => child_get
+procedure(calc_i), pass, deferred :: calc
+end type child
+
+abstract interface
+pure function calc_i(this) result(value)
+import :: child
+class(child), intent(in) :: this
+integer :: value
+end function calc_i
+end interface
+
+contains
+pure subroutine parent_reset(this)
+class(parent), intent(inout) :: this
+end subroutine parent_reset
+
+pure subroutine child_reset(this)
+class(child), intent(inout) :: this
+end subroutine child_reset
+
+function child_get(this) result(value)
+class(child), intent(inout) :: this
+integer :: value
+
+value = this%calc()
+end function child_get
+end module module1
diff --git a/gcc/testsuite/gfortran.dg/pr117730_b.f90
b/gcc/testsuite/gfortran.dg/pr117730_b.f90
new file mode 100644
index ..09707882989e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr117730_b.f90
@@ -0,0 +1,47 @@
+! { dg-do run }
+! { dg-compile-aux-modules "pr117730_a.f90" }
+! { dg-additional-sources pr117730_a.f90 }
+!
+! Test the fix for PR117730 in which the non_overrridable procedures in
+! pr117730_a.f90 were mixied up in the vtable for 'child2' below. This resulted
+! in 'this%calc()' in 'function child_get(this)' returning garbage.
+!
+! Contributed by in comment 4 of PR84674.
+!
+module module2
+use module1, only: child
+
+implicit none
+private
+public :: child2
+
+type, extends(chi
[gcc r14-10993] Fortran: Partial reversion of r15-5083 [PR117763]
https://gcc.gnu.org/g:da1305a9fee3b2efbb4702bb2d9b2f740d2e538a
commit r14-10993-gda1305a9fee3b2efbb4702bb2d9b2f740d2e538a
Author: Paul Thomas
Date: Tue Nov 26 08:58:21 2024 +
Fortran: Partial reversion of r15-5083 [PR117763]
2024-11-26 Paul Thomas
gcc/fortran
PR fortran/117763
* trans-array.cc (gfc_get_array_span): Guard against derefences
of 'expr'. Clean up some typos. Use 'gfc_get_vptr_from_expr'
for clarity and apply a functional reversion of last section
that deals with class dummies.
gcc/testsuite/
PR fortran/117763
* gfortran.dg/pr117763.f90: New test.
(cherry picked from commit 8278d9551df610179fca114808a7e6e62bab3d82)
Diff:
---
gcc/fortran/trans-array.cc | 16 +-
gcc/testsuite/gfortran.dg/pr117763.f90 | 279 +
2 files changed, 289 insertions(+), 6 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 3994f4f71f0f..fe69b694e0da 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -961,8 +961,8 @@ tree
gfc_get_array_span (tree desc, gfc_expr *expr)
{
tree tmp;
- gfc_symbol *sym = expr->expr_type == EXPR_VARIABLE
- ? expr->symtree->n.sym : NULL;
+ gfc_symbol *sym = (expr && expr->expr_type == EXPR_VARIABLE) ?
+ expr->symtree->n.sym : NULL;
if (is_pointer_array (desc)
|| (get_CFI_desc (NULL, expr, &desc, NULL)
@@ -989,7 +989,7 @@ gfc_get_array_span (tree desc, gfc_expr *expr)
{
/* Treat unlimited polymorphic expressions separately because
the element size need not be the same as the span. Obtain
-the class container, which is simplified here by their being
+the class container, which is simplified here by there being
no component references. */
if (sym && sym->attr.dummy)
{
@@ -1013,12 +1013,16 @@ gfc_get_array_span (tree desc, gfc_expr *expr)
/* The descriptor is a class _data field. Use the vtable size
since it is guaranteed to have been set and is always OK for
class array descriptors that are not unlimited. */
- tmp = gfc_class_vptr_get (TREE_OPERAND (desc, 0));
+ tmp = gfc_get_vptr_from_expr (desc);
tmp = gfc_vptr_size_get (tmp);
}
- else if (sym && sym->ts.type == BT_CLASS && sym->attr.dummy)
+ else if (sym && sym->ts.type == BT_CLASS
+ && expr->ref->type == REF_COMPONENT
+ && expr->ref->next->type == REF_ARRAY
+ && expr->ref->next->next == NULL
+ && CLASS_DATA (sym)->attr.dimension)
{
- /* Class dummys usually requires extraction from the saved
+ /* Class dummys usually require extraction from the saved
descriptor, which gfc_class_vptr_get does for us. */
tmp = gfc_class_vptr_get (sym->backend_decl);
tmp = gfc_vptr_size_get (tmp);
diff --git a/gcc/testsuite/gfortran.dg/pr117763.f90
b/gcc/testsuite/gfortran.dg/pr117763.f90
new file mode 100644
index ..5f7b36c02694
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr117763.f90
@@ -0,0 +1,279 @@
+! { dg-do compile }
+! { dg-options "-fdump-tree-original" }
+!
+! Test the fix for PR117763, which was a regression caused by the patch for
+! PR109345.
+!
+! Contributed by Juergen Reuter
+!
+module iso_varying_string
+ implicit none
+ integer, parameter, private :: GET_BUFFER_LEN = 1
+
+ type, public :: varying_string
+ private
+ character(LEN=1), dimension(:), allocatable :: chars
+ end type varying_string
+
+ interface assignment(=)
+ module procedure op_assign_CH_VS
+ module procedure op_assign_VS_CH
+ end interface assignment(=)
+
+ interface char
+ module procedure char_auto
+ module procedure char_fixed
+ end interface char
+
+ interface len
+ module procedure len_
+ end interface len
+
+ interface var_str
+ module procedure var_str_
+ end interface var_str
+
+ public :: assignment(=)
+ public :: char
+ public :: len
+ public :: var_str
+
+ private :: op_assign_CH_VS
+ private :: op_assign_VS_CH
+ private :: char_auto
+ private :: char_fixed
+ private :: len_
+ private :: var_str_
+
+contains
+
+ elemental function len_ (string) result (length)
+type(varying_string), intent(in) :: string
+integer :: length
+if(ALLOCATED(string%chars)) then
+ length = SIZE(string%chars)
+else
+ length = 0
+endif
+ end function len_
+
+ elemental subroutine op_assign_CH_VS (var, exp)
+character(LEN=*), intent(out):: var
+type(varying_string), intent(in) :: exp
+var = char(exp)
+ end subroutine op_assign_CH_VS
+
+ elemental subroutine op_assign_VS_CH (var, exp)
+type(varying_string), intent(out) :: var
+character(LEN=*), intent(in) :: exp
+var = var_str(exp)
+ end subroutine op_assign_VS_CH
+
+ pure function char_auto (string) resul
[gcc r13-9219] Fortran: Partial reversion of r15-5083 [PR117763]
https://gcc.gnu.org/g:8d81d6b2f9b72a41f23b07214d88cfcb176a
commit r13-9219-g8d81d6b2f9b72a41f23b07214d88cfcb176a
Author: Paul Thomas
Date: Tue Nov 26 08:58:21 2024 +
Fortran: Partial reversion of r15-5083 [PR117763]
2024-11-26 Paul Thomas
gcc/fortran
PR fortran/117763
* trans-array.cc (gfc_get_array_span): Guard against derefences
of 'expr'. Clean up some typos. Use 'gfc_get_vptr_from_expr'
for clarity and apply a functional reversion of last section
that deals with class dummies.
gcc/testsuite/
PR fortran/117763
* gfortran.dg/pr117763.f90: New test.
(cherry picked from commit 8278d9551df610179fca114808a7e6e62bab3d82)
Diff:
---
gcc/fortran/trans-array.cc | 16 +-
gcc/testsuite/gfortran.dg/pr117763.f90 | 279 +
2 files changed, 289 insertions(+), 6 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 79963befd52f..76e397b2a0ed 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -943,8 +943,8 @@ tree
gfc_get_array_span (tree desc, gfc_expr *expr)
{
tree tmp;
- gfc_symbol *sym = expr->expr_type == EXPR_VARIABLE
- ? expr->symtree->n.sym : NULL;
+ gfc_symbol *sym = (expr && expr->expr_type == EXPR_VARIABLE) ?
+ expr->symtree->n.sym : NULL;
if (is_pointer_array (desc)
|| (get_CFI_desc (NULL, expr, &desc, NULL)
@@ -971,7 +971,7 @@ gfc_get_array_span (tree desc, gfc_expr *expr)
{
/* Treat unlimited polymorphic expressions separately because
the element size need not be the same as the span. Obtain
-the class container, which is simplified here by their being
+the class container, which is simplified here by there being
no component references. */
if (sym && sym->attr.dummy)
{
@@ -995,12 +995,16 @@ gfc_get_array_span (tree desc, gfc_expr *expr)
/* The descriptor is a class _data field. Use the vtable size
since it is guaranteed to have been set and is always OK for
class array descriptors that are not unlimited. */
- tmp = gfc_class_vptr_get (TREE_OPERAND (desc, 0));
+ tmp = gfc_get_vptr_from_expr (desc);
tmp = gfc_vptr_size_get (tmp);
}
- else if (sym && sym->ts.type == BT_CLASS && sym->attr.dummy)
+ else if (sym && sym->ts.type == BT_CLASS
+ && expr->ref->type == REF_COMPONENT
+ && expr->ref->next->type == REF_ARRAY
+ && expr->ref->next->next == NULL
+ && CLASS_DATA (sym)->attr.dimension)
{
- /* Class dummys usually requires extraction from the saved
+ /* Class dummys usually require extraction from the saved
descriptor, which gfc_class_vptr_get does for us. */
tmp = gfc_class_vptr_get (sym->backend_decl);
tmp = gfc_vptr_size_get (tmp);
diff --git a/gcc/testsuite/gfortran.dg/pr117763.f90
b/gcc/testsuite/gfortran.dg/pr117763.f90
new file mode 100644
index ..5f7b36c02694
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr117763.f90
@@ -0,0 +1,279 @@
+! { dg-do compile }
+! { dg-options "-fdump-tree-original" }
+!
+! Test the fix for PR117763, which was a regression caused by the patch for
+! PR109345.
+!
+! Contributed by Juergen Reuter
+!
+module iso_varying_string
+ implicit none
+ integer, parameter, private :: GET_BUFFER_LEN = 1
+
+ type, public :: varying_string
+ private
+ character(LEN=1), dimension(:), allocatable :: chars
+ end type varying_string
+
+ interface assignment(=)
+ module procedure op_assign_CH_VS
+ module procedure op_assign_VS_CH
+ end interface assignment(=)
+
+ interface char
+ module procedure char_auto
+ module procedure char_fixed
+ end interface char
+
+ interface len
+ module procedure len_
+ end interface len
+
+ interface var_str
+ module procedure var_str_
+ end interface var_str
+
+ public :: assignment(=)
+ public :: char
+ public :: len
+ public :: var_str
+
+ private :: op_assign_CH_VS
+ private :: op_assign_VS_CH
+ private :: char_auto
+ private :: char_fixed
+ private :: len_
+ private :: var_str_
+
+contains
+
+ elemental function len_ (string) result (length)
+type(varying_string), intent(in) :: string
+integer :: length
+if(ALLOCATED(string%chars)) then
+ length = SIZE(string%chars)
+else
+ length = 0
+endif
+ end function len_
+
+ elemental subroutine op_assign_CH_VS (var, exp)
+character(LEN=*), intent(out):: var
+type(varying_string), intent(in) :: exp
+var = char(exp)
+ end subroutine op_assign_CH_VS
+
+ elemental subroutine op_assign_VS_CH (var, exp)
+type(varying_string), intent(out) :: var
+character(LEN=*), intent(in) :: exp
+var = var_str(exp)
+ end subroutine op_assign_VS_CH
+
+ pure function char_auto (string) result (
[gcc r12-10835] Fortran: Partial reversion of r15-5083 [PR117763]
https://gcc.gnu.org/g:2ae871b71512f77cc6857bf0ecbf80dd1253e18c
commit r12-10835-g2ae871b71512f77cc6857bf0ecbf80dd1253e18c
Author: Paul Thomas
Date: Tue Nov 26 08:58:21 2024 +
Fortran: Partial reversion of r15-5083 [PR117763]
2024-11-26 Paul Thomas
gcc/fortran
PR fortran/117763
* trans-array.cc (gfc_get_array_span): Guard against derefences
of 'expr'. Clean up some typos. Use 'gfc_get_vptr_from_expr'
for clarity and apply a functional reversion of last section
that deals with class dummies.
gcc/testsuite/
PR fortran/117763
* gfortran.dg/pr117763.f90: New test.
(cherry picked from commit 8278d9551df610179fca114808a7e6e62bab3d82)
Diff:
---
gcc/fortran/trans-array.cc | 16 +-
gcc/testsuite/gfortran.dg/pr117763.f90 | 279 +
2 files changed, 289 insertions(+), 6 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 504b1bb07f06..ddaedf9604e9 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -943,8 +943,8 @@ tree
gfc_get_array_span (tree desc, gfc_expr *expr)
{
tree tmp;
- gfc_symbol *sym = expr->expr_type == EXPR_VARIABLE
- ? expr->symtree->n.sym : NULL;
+ gfc_symbol *sym = (expr && expr->expr_type == EXPR_VARIABLE) ?
+ expr->symtree->n.sym : NULL;
if (is_pointer_array (desc)
|| (get_CFI_desc (NULL, expr, &desc, NULL)
@@ -971,7 +971,7 @@ gfc_get_array_span (tree desc, gfc_expr *expr)
{
/* Treat unlimited polymorphic expressions separately because
the element size need not be the same as the span. Obtain
-the class container, which is simplified here by their being
+the class container, which is simplified here by there being
no component references. */
if (sym && sym->attr.dummy)
{
@@ -995,12 +995,16 @@ gfc_get_array_span (tree desc, gfc_expr *expr)
/* The descriptor is a class _data field. Use the vtable size
since it is guaranteed to have been set and is always OK for
class array descriptors that are not unlimited. */
- tmp = gfc_class_vptr_get (TREE_OPERAND (desc, 0));
+ tmp = gfc_get_vptr_from_expr (desc);
tmp = gfc_vptr_size_get (tmp);
}
- else if (sym && sym->ts.type == BT_CLASS && sym->attr.dummy)
+ else if (sym && sym->ts.type == BT_CLASS
+ && expr->ref->type == REF_COMPONENT
+ && expr->ref->next->type == REF_ARRAY
+ && expr->ref->next->next == NULL
+ && CLASS_DATA (sym)->attr.dimension)
{
- /* Class dummys usually requires extraction from the saved
+ /* Class dummys usually require extraction from the saved
descriptor, which gfc_class_vptr_get does for us. */
tmp = gfc_class_vptr_get (sym->backend_decl);
tmp = gfc_vptr_size_get (tmp);
diff --git a/gcc/testsuite/gfortran.dg/pr117763.f90
b/gcc/testsuite/gfortran.dg/pr117763.f90
new file mode 100644
index ..5f7b36c02694
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr117763.f90
@@ -0,0 +1,279 @@
+! { dg-do compile }
+! { dg-options "-fdump-tree-original" }
+!
+! Test the fix for PR117763, which was a regression caused by the patch for
+! PR109345.
+!
+! Contributed by Juergen Reuter
+!
+module iso_varying_string
+ implicit none
+ integer, parameter, private :: GET_BUFFER_LEN = 1
+
+ type, public :: varying_string
+ private
+ character(LEN=1), dimension(:), allocatable :: chars
+ end type varying_string
+
+ interface assignment(=)
+ module procedure op_assign_CH_VS
+ module procedure op_assign_VS_CH
+ end interface assignment(=)
+
+ interface char
+ module procedure char_auto
+ module procedure char_fixed
+ end interface char
+
+ interface len
+ module procedure len_
+ end interface len
+
+ interface var_str
+ module procedure var_str_
+ end interface var_str
+
+ public :: assignment(=)
+ public :: char
+ public :: len
+ public :: var_str
+
+ private :: op_assign_CH_VS
+ private :: op_assign_VS_CH
+ private :: char_auto
+ private :: char_fixed
+ private :: len_
+ private :: var_str_
+
+contains
+
+ elemental function len_ (string) result (length)
+type(varying_string), intent(in) :: string
+integer :: length
+if(ALLOCATED(string%chars)) then
+ length = SIZE(string%chars)
+else
+ length = 0
+endif
+ end function len_
+
+ elemental subroutine op_assign_CH_VS (var, exp)
+character(LEN=*), intent(out):: var
+type(varying_string), intent(in) :: exp
+var = char(exp)
+ end subroutine op_assign_CH_VS
+
+ elemental subroutine op_assign_VS_CH (var, exp)
+type(varying_string), intent(out) :: var
+character(LEN=*), intent(in) :: exp
+var = var_str(exp)
+ end subroutine op_assign_VS_CH
+
+ pure function char_auto (string) result
[gcc r15-5716] Fortran: Fix non_overridable typebound proc problems [PR84674/117768].
https://gcc.gnu.org/g:fed871f93c235da8ccba29d7beb715abc1482e59
commit r15-5716-gfed871f93c235da8ccba29d7beb715abc1482e59
Author: Paul Thomas
Date: Wed Nov 27 09:20:23 2024 +
Fortran: Fix non_overridable typebound proc problems [PR84674/117768].
2024-11-27 Paul Thomas
gcc/fortran/ChangeLog
PR fortran/84674
* class.cc (add_proc_comp): If the component points to a tbp
that is abstract, do not return since the new version is more
likely to be usable.
PR fortran/117768
* resolve.cc (resolve_fl_derived): Remove the condition that
rejected a completely empty derived type extension.
gcc/testsuite/ChangeLog
PR fortran/117768
* gfortran.dg/pr117768.f90: New test.
Diff:
---
gcc/fortran/class.cc | 14 ++-
gcc/fortran/resolve.cc | 8 +---
gcc/testsuite/gfortran.dg/pr117768.f90 | 76 ++
3 files changed, 90 insertions(+), 8 deletions(-)
diff --git a/gcc/fortran/class.cc b/gcc/fortran/class.cc
index 59ac0d97e080..64a0e726eeb4 100644
--- a/gcc/fortran/class.cc
+++ b/gcc/fortran/class.cc
@@ -884,11 +884,21 @@ static void
add_proc_comp (gfc_symbol *vtype, const char *name, gfc_typebound_proc *tb)
{
gfc_component *c;
-
+ bool is_abstract = false;
c = gfc_find_component (vtype, name, true, true, NULL);
- if (tb->non_overridable && !tb->overridden && c)
+ /* If the present component typebound proc is abstract, the new version
+ should unconditionally be tested if it is a suitable replacement. */
+ if (c && c->tb && c->tb->u.specific
+ && c->tb->u.specific->n.sym->attr.abstract)
+is_abstract = true;
+
+ /* Pass on the new tb being not overridable if a component is found and
+ either there is not an overridden specific or the present component
+ tb is abstract. This ensures that possible, viable replacements are
+ loaded. */
+ if (tb->non_overridable && !tb->overridden && !is_abstract && c)
return;
if (c == NULL)
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 0d3845f9ce35..afed8db7852b 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -3229,8 +3229,8 @@ static bool check_pure_function (gfc_expr *e)
const char *name = NULL;
code_stack *stack;
bool saw_block = false;
-
- /* A BLOCK construct within a DO CONCURRENT construct leads to
+
+ /* A BLOCK construct within a DO CONCURRENT construct leads to
gfc_do_concurrent_flag = 0 when the check for an impure function
occurs. Check the stack to see if the source code has a nested
BLOCK construct. */
@@ -16305,10 +16305,6 @@ resolve_fl_derived (gfc_symbol *sym)
&& sym->ns->proc_name
&& sym->ns->proc_name->attr.flavor == FL_MODULE
&& sym->attr.access != ACCESS_PRIVATE
- && !(sym->attr.extension
- && sym->attr.zero_comp
- && !sym->f2k_derived->tb_sym_root
- && !sym->f2k_derived->tb_uop_root)
&& !(sym->attr.vtype || sym->attr.pdt_template))
{
gfc_symbol *vtab = gfc_find_derived_vtab (sym);
diff --git a/gcc/testsuite/gfortran.dg/pr117768.f90
b/gcc/testsuite/gfortran.dg/pr117768.f90
new file mode 100644
index ..f9cf46421c15
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr117768.f90
@@ -0,0 +1,76 @@
+! { dg-do compile }
+!
+! Fix a regession caused by the first patch for PR84674.
+!
+! Contributed by Juergen Reuter
+!
+module m1
+ implicit none
+ private
+ public :: t1
+ type, abstract :: t1
+ end type t1
+end module m1
+
+module t_base
+ use m1, only: t1
+ implicit none
+ private
+ public :: t_t
+ type, abstract :: t_t
+ contains
+ procedure (t_out), deferred :: output
+ end type t_t
+
+ abstract interface
+ subroutine t_out (t, handle)
+ import
+ class(t_t), intent(inout) :: t
+ class(t1), intent(inout), optional :: handle
+ end subroutine t_out
+ end interface
+
+end module t_base
+
+
+module t_ascii
+ use m1, only: t1
+ use t_base
+ implicit none
+ private
+
+ type, abstract, extends (t_t) :: t1_t
+ contains
+ procedure :: output => t_ascii_output
+ end type t1_t
+ type, extends (t1_t) :: t2_t
+ end type t2_t
+ type, extends (t1_t) :: t3_t
+ logical :: verbose = .true.
+ end type t3_t
+
+ interface
+module subroutine t_ascii_output &
+ (t, handle)
+ class(t1_t), intent(inout) :: t
+ class(t1), intent(inout), optional :: handle
+end subroutine t_ascii_output
+ end interface
+end module t_ascii
+
+submodule (t_ascii) t_ascii_s
+ implicit none
+contains
+ module subroutine t_ascii_output &
+ (t, handle)
+class(t1_t), intent(inout) :: t
+class(t1), intent(inout), optional :: handle
+select type (t)
+type is (t3_t)
+type is (t2_t)
+class default
+ return
+end select
+ end subroutine t_ascii_output
+end submodule t_ascii_s
[gcc r14-11012] Fortran: Fix failing character pointer fcn assignment [PR105054]
https://gcc.gnu.org/g:dd1d74cb548428f5928c10f7d3ba2b3cdd5ddc80
commit r14-11012-gdd1d74cb548428f5928c10f7d3ba2b3cdd5ddc80
Author: Paul Thomas
Date: Wed Nov 13 08:57:55 2024 +
Fortran: Fix failing character pointer fcn assignment [PR105054]
2024-11-14 Paul Thomas
gcc/fortran
PR fortran/105054
* resolve.cc (get_temp_from_expr): If the pointer function has
a deferred character length, generate a new deferred charlen
for the temporary.
gcc/testsuite/
PR fortran/105054
* gfortran.dg/ptr_func_assign_6.f08: New test.
(cherry picked from commit f530a8c61383b174a476b64f46d56adeedf49dc4)
Diff:
---
gcc/fortran/resolve.cc | 11 +++
gcc/testsuite/gfortran.dg/ptr_func_assign_6.f08 | 89 +
2 files changed, 100 insertions(+)
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 1488e9e38238..4c7463168a09 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -12452,6 +12452,17 @@ resolve_ptr_fcn_assign (gfc_code **code, gfc_namespace
*ns)
tmp_ptr_expr->symtree->n.sym->attr.allocatable = 0;
tmp_ptr_expr->where = (*code)->loc;
+ /* A new charlen is required to ensure that the variable string length
+ is different to that of the original lhs for deferred results. */
+ if (s->result->ts.deferred && tmp_ptr_expr->ts.type == BT_CHARACTER)
+{
+ tmp_ptr_expr->ts.u.cl = gfc_get_charlen();
+ tmp_ptr_expr->ts.deferred = 1;
+ tmp_ptr_expr->ts.u.cl->next = gfc_current_ns->cl_list;
+ gfc_current_ns->cl_list = tmp_ptr_expr->ts.u.cl;
+ tmp_ptr_expr->symtree->n.sym->ts.u.cl = tmp_ptr_expr->ts.u.cl;
+}
+
this_code = build_assignment (EXEC_ASSIGN,
tmp_ptr_expr, (*code)->expr2,
NULL, NULL, (*code)->loc);
diff --git a/gcc/testsuite/gfortran.dg/ptr_func_assign_6.f08
b/gcc/testsuite/gfortran.dg/ptr_func_assign_6.f08
new file mode 100644
index ..d62815d7afad
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/ptr_func_assign_6.f08
@@ -0,0 +1,89 @@
+! { dg-do run }
+!
+! Test the fix for PR105054.
+!
+! Contributed by Arjen Markus
+!
+module string_pointers
+implicit none
+character(len=20), dimension(10), target :: array_strings
+character(len=:), dimension(:), target, allocatable :: array_strings2
+
+contains
+
+function pointer_to_string( i , flag)
+ integer, intent(in) :: i, flag
+
+ character(len=:), pointer :: pointer_to_string
+
+ if (flag == 1) then
+ pointer_to_string => array_strings(i)
+ return
+ endif
+
+ if (.not.allocated (array_strings2)) allocate (array_strings2(4), &
+mold = '')
+ pointer_to_string => array_strings2(i)
+end function pointer_to_string
+
+function pointer_to_string2( i , flag) result (res)
+ integer, intent(in) :: i, flag
+
+ character(len=:), pointer :: res
+
+ if (flag == 1) then
+ res => array_strings(i)
+ return
+ endif
+
+ if (.not.allocated (array_strings2)) allocate (array_strings2(4), &
+mold = '')
+ res => array_strings2(i)
+end function pointer_to_string2
+
+end module string_pointers
+
+program chk_string_pointer
+use string_pointers
+implicit none
+integer :: i
+character(*), parameter :: chr(4) = ['1234 ','ABCDefgh ', &
+ '12345678 ',' ']
+
+pointer_to_string(1, 1) = '1234567890'
+pointer_to_string(2, 1) = '12345678901234567890'
+
+if (len(pointer_to_string(3, 1)) /= 20) stop 1
+
+array_strings(1) = array_strings(1)(1:4) // 'ABC'
+if (pointer_to_string(1, 1) /= '1234ABC') stop 2
+
+pointer_to_string(1, 2) = '1234'
+pointer_to_string(2, 2) = 'ABCDefgh'
+pointer_to_string(3, 2) = '12345678'
+
+do i = 1, 3
+ if (trim (array_strings2(i)) /= trim(chr(i))) stop 3
+enddo
+
+! Clear the target arrays
+array_strings = repeat (' ', 20)
+deallocate (array_strings2)
+
+! Repeat with an explicit result.
+pointer_to_string2(1, 1) = '1234567890'
+pointer_to_string2(2, 1) = '12345678901234567890'
+
+if (len(pointer_to_string(3, 1)) /= 20) stop 4
+
+array_strings(1) = array_strings(1)(1:4) // 'ABC'
+if (pointer_to_string(1, 1) /= '1234ABC') stop 5
+
+pointer_to_string2(1, 2) = '1234'
+pointer_to_string2(2, 2) = 'ABCDefgh'
+pointer_to_string2(3, 2) = '12345678'
+
+do i = 1, 3
+ if (trim (array_strings2(i)) /= trim(chr(i))) stop 6
+enddo
+end program chk_string_pointer
[gcc r13-9223] Fortran: Fix failing character pointer fcn assignment [PR105054]
https://gcc.gnu.org/g:351fc7565610574f7677972b0d9c4559eaff32f0
commit r13-9223-g351fc7565610574f7677972b0d9c4559eaff32f0
Author: Paul Thomas
Date: Wed Nov 13 08:57:55 2024 +
Fortran: Fix failing character pointer fcn assignment [PR105054]
2024-11-14 Paul Thomas
gcc/fortran
PR fortran/105054
* resolve.cc (get_temp_from_expr): If the pointer function has
a deferred character length, generate a new deferred charlen
for the temporary.
gcc/testsuite/
PR fortran/105054
* gfortran.dg/ptr_func_assign_6.f08: New test.
(cherry picked from commit f530a8c61383b174a476b64f46d56adeedf49dc4)
Diff:
---
gcc/fortran/resolve.cc | 11 +++
gcc/testsuite/gfortran.dg/ptr_func_assign_6.f08 | 89 +
2 files changed, 100 insertions(+)
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index adfde61bbdb1..6f13725cac57 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -12120,6 +12120,17 @@ resolve_ptr_fcn_assign (gfc_code **code, gfc_namespace
*ns)
tmp_ptr_expr->symtree->n.sym->attr.allocatable = 0;
tmp_ptr_expr->where = (*code)->loc;
+ /* A new charlen is required to ensure that the variable string length
+ is different to that of the original lhs for deferred results. */
+ if (s->result->ts.deferred && tmp_ptr_expr->ts.type == BT_CHARACTER)
+{
+ tmp_ptr_expr->ts.u.cl = gfc_get_charlen();
+ tmp_ptr_expr->ts.deferred = 1;
+ tmp_ptr_expr->ts.u.cl->next = gfc_current_ns->cl_list;
+ gfc_current_ns->cl_list = tmp_ptr_expr->ts.u.cl;
+ tmp_ptr_expr->symtree->n.sym->ts.u.cl = tmp_ptr_expr->ts.u.cl;
+}
+
this_code = build_assignment (EXEC_ASSIGN,
tmp_ptr_expr, (*code)->expr2,
NULL, NULL, (*code)->loc);
diff --git a/gcc/testsuite/gfortran.dg/ptr_func_assign_6.f08
b/gcc/testsuite/gfortran.dg/ptr_func_assign_6.f08
new file mode 100644
index ..d62815d7afad
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/ptr_func_assign_6.f08
@@ -0,0 +1,89 @@
+! { dg-do run }
+!
+! Test the fix for PR105054.
+!
+! Contributed by Arjen Markus
+!
+module string_pointers
+implicit none
+character(len=20), dimension(10), target :: array_strings
+character(len=:), dimension(:), target, allocatable :: array_strings2
+
+contains
+
+function pointer_to_string( i , flag)
+ integer, intent(in) :: i, flag
+
+ character(len=:), pointer :: pointer_to_string
+
+ if (flag == 1) then
+ pointer_to_string => array_strings(i)
+ return
+ endif
+
+ if (.not.allocated (array_strings2)) allocate (array_strings2(4), &
+mold = '')
+ pointer_to_string => array_strings2(i)
+end function pointer_to_string
+
+function pointer_to_string2( i , flag) result (res)
+ integer, intent(in) :: i, flag
+
+ character(len=:), pointer :: res
+
+ if (flag == 1) then
+ res => array_strings(i)
+ return
+ endif
+
+ if (.not.allocated (array_strings2)) allocate (array_strings2(4), &
+mold = '')
+ res => array_strings2(i)
+end function pointer_to_string2
+
+end module string_pointers
+
+program chk_string_pointer
+use string_pointers
+implicit none
+integer :: i
+character(*), parameter :: chr(4) = ['1234 ','ABCDefgh ', &
+ '12345678 ',' ']
+
+pointer_to_string(1, 1) = '1234567890'
+pointer_to_string(2, 1) = '12345678901234567890'
+
+if (len(pointer_to_string(3, 1)) /= 20) stop 1
+
+array_strings(1) = array_strings(1)(1:4) // 'ABC'
+if (pointer_to_string(1, 1) /= '1234ABC') stop 2
+
+pointer_to_string(1, 2) = '1234'
+pointer_to_string(2, 2) = 'ABCDefgh'
+pointer_to_string(3, 2) = '12345678'
+
+do i = 1, 3
+ if (trim (array_strings2(i)) /= trim(chr(i))) stop 3
+enddo
+
+! Clear the target arrays
+array_strings = repeat (' ', 20)
+deallocate (array_strings2)
+
+! Repeat with an explicit result.
+pointer_to_string2(1, 1) = '1234567890'
+pointer_to_string2(2, 1) = '12345678901234567890'
+
+if (len(pointer_to_string(3, 1)) /= 20) stop 4
+
+array_strings(1) = array_strings(1)(1:4) // 'ABC'
+if (pointer_to_string(1, 1) /= '1234ABC') stop 5
+
+pointer_to_string2(1, 2) = '1234'
+pointer_to_string2(2, 2) = 'ABCDefgh'
+pointer_to_string2(3, 2) = '12345678'
+
+do i = 1, 3
+ if (trim (array_strings2(i)) /= trim(chr(i))) stop 6
+enddo
+end program chk_string_pointer
[gcc r12-10840] Fortran: Fix failing character pointer fcn assignment [PR105054]
https://gcc.gnu.org/g:da848c3b9396456c85d8c8055af8158148cbc1a6
commit r12-10840-gda848c3b9396456c85d8c8055af8158148cbc1a6
Author: Paul Thomas
Date: Wed Nov 13 08:57:55 2024 +
Fortran: Fix failing character pointer fcn assignment [PR105054]
2024-11-14 Paul Thomas
gcc/fortran
PR fortran/105054
* resolve.cc (get_temp_from_expr): If the pointer function has
a deferred character length, generate a new deferred charlen
for the temporary.
gcc/testsuite/
PR fortran/105054
* gfortran.dg/ptr_func_assign_6.f08: New test.
(cherry picked from commit f530a8c61383b174a476b64f46d56adeedf49dc4)
Diff:
---
gcc/fortran/resolve.cc | 11 +++
gcc/testsuite/gfortran.dg/ptr_func_assign_6.f08 | 89 +
2 files changed, 100 insertions(+)
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 6a7325e15e72..0ce41941edd9 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -11800,6 +11800,17 @@ resolve_ptr_fcn_assign (gfc_code **code, gfc_namespace
*ns)
tmp_ptr_expr->symtree->n.sym->attr.allocatable = 0;
tmp_ptr_expr->where = (*code)->loc;
+ /* A new charlen is required to ensure that the variable string length
+ is different to that of the original lhs for deferred results. */
+ if (s->result->ts.deferred && tmp_ptr_expr->ts.type == BT_CHARACTER)
+{
+ tmp_ptr_expr->ts.u.cl = gfc_get_charlen();
+ tmp_ptr_expr->ts.deferred = 1;
+ tmp_ptr_expr->ts.u.cl->next = gfc_current_ns->cl_list;
+ gfc_current_ns->cl_list = tmp_ptr_expr->ts.u.cl;
+ tmp_ptr_expr->symtree->n.sym->ts.u.cl = tmp_ptr_expr->ts.u.cl;
+}
+
this_code = build_assignment (EXEC_ASSIGN,
tmp_ptr_expr, (*code)->expr2,
NULL, NULL, (*code)->loc);
diff --git a/gcc/testsuite/gfortran.dg/ptr_func_assign_6.f08
b/gcc/testsuite/gfortran.dg/ptr_func_assign_6.f08
new file mode 100644
index ..d62815d7afad
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/ptr_func_assign_6.f08
@@ -0,0 +1,89 @@
+! { dg-do run }
+!
+! Test the fix for PR105054.
+!
+! Contributed by Arjen Markus
+!
+module string_pointers
+implicit none
+character(len=20), dimension(10), target :: array_strings
+character(len=:), dimension(:), target, allocatable :: array_strings2
+
+contains
+
+function pointer_to_string( i , flag)
+ integer, intent(in) :: i, flag
+
+ character(len=:), pointer :: pointer_to_string
+
+ if (flag == 1) then
+ pointer_to_string => array_strings(i)
+ return
+ endif
+
+ if (.not.allocated (array_strings2)) allocate (array_strings2(4), &
+mold = '')
+ pointer_to_string => array_strings2(i)
+end function pointer_to_string
+
+function pointer_to_string2( i , flag) result (res)
+ integer, intent(in) :: i, flag
+
+ character(len=:), pointer :: res
+
+ if (flag == 1) then
+ res => array_strings(i)
+ return
+ endif
+
+ if (.not.allocated (array_strings2)) allocate (array_strings2(4), &
+mold = '')
+ res => array_strings2(i)
+end function pointer_to_string2
+
+end module string_pointers
+
+program chk_string_pointer
+use string_pointers
+implicit none
+integer :: i
+character(*), parameter :: chr(4) = ['1234 ','ABCDefgh ', &
+ '12345678 ',' ']
+
+pointer_to_string(1, 1) = '1234567890'
+pointer_to_string(2, 1) = '12345678901234567890'
+
+if (len(pointer_to_string(3, 1)) /= 20) stop 1
+
+array_strings(1) = array_strings(1)(1:4) // 'ABC'
+if (pointer_to_string(1, 1) /= '1234ABC') stop 2
+
+pointer_to_string(1, 2) = '1234'
+pointer_to_string(2, 2) = 'ABCDefgh'
+pointer_to_string(3, 2) = '12345678'
+
+do i = 1, 3
+ if (trim (array_strings2(i)) /= trim(chr(i))) stop 3
+enddo
+
+! Clear the target arrays
+array_strings = repeat (' ', 20)
+deallocate (array_strings2)
+
+! Repeat with an explicit result.
+pointer_to_string2(1, 1) = '1234567890'
+pointer_to_string2(2, 1) = '12345678901234567890'
+
+if (len(pointer_to_string(3, 1)) /= 20) stop 4
+
+array_strings(1) = array_strings(1)(1:4) // 'ABC'
+if (pointer_to_string(1, 1) /= '1234ABC') stop 5
+
+pointer_to_string2(1, 2) = '1234'
+pointer_to_string2(2, 2) = 'ABCDefgh'
+pointer_to_string2(3, 2) = '12345678'
+
+do i = 1, 3
+ if (trim (array_strings2(i)) /= trim(chr(i))) stop 6
+enddo
+end program chk_string_pointer
[gcc r13-9187] Fortran: Fix ASSOCIATE with assumed-length character array [PR115700]
https://gcc.gnu.org/g:3b80ff5b4222660a39c861a76df1912d8cc293b3
commit r13-9187-g3b80ff5b4222660a39c861a76df1912d8cc293b3
Author: Paul Thomas
Date: Thu Nov 14 13:27:24 2024 +
Fortran: Fix ASSOCIATE with assumed-length character array [PR115700]
2024-11-14 Paul Thomas
gcc/fortran
PR fortran/115700
* trans-stmt.cc (trans_associate_var): Update from mainline to
handle substring targets correctly.
gcc/testsuite
PR fortran/115700
* gfortran.dg/associate_69.f90: New test.
Diff:
---
gcc/fortran/trans-stmt.cc | 19 -
gcc/testsuite/gfortran.dg/associate_69.f90 | 33 ++
2 files changed, 47 insertions(+), 5 deletions(-)
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index 51d008cacb8d..df4f6f590a41 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -1902,6 +1902,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block
*block)
gfc_add_init_cleanup (block, gfc_finish_block (&se.pre), tmp);
}
+
/* Now all the other kinds of associate variable. */
else if (sym->attr.dimension && !class_target
&& (sym->as->type == AS_DEFERRED || sym->assoc->variable))
@@ -1909,6 +1910,8 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block
*block)
gfc_se se;
tree desc;
bool cst_array_ctor;
+ stmtblock_t init;
+ gfc_init_block (&init);
desc = sym->backend_decl;
cst_array_ctor = e->expr_type == EXPR_ARRAY
@@ -1930,14 +1933,19 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block
*block)
gfc_conv_expr_descriptor (&se, e);
if (sym->ts.type == BT_CHARACTER
- && sym->ts.deferred
&& !sym->attr.select_type_temporary
+ && sym->ts.u.cl->backend_decl
&& VAR_P (sym->ts.u.cl->backend_decl)
+ && se.string_length
&& se.string_length != sym->ts.u.cl->backend_decl)
{
- gfc_add_modify (&se.pre, sym->ts.u.cl->backend_decl,
- fold_convert (TREE_TYPE (sym->ts.u.cl->backend_decl),
- se.string_length));
+ /* When the target is a variable, its length is already known. */
+ tree len = fold_convert (TREE_TYPE (sym->ts.u.cl->backend_decl),
+ se.string_length);
+ if (e->expr_type == EXPR_VARIABLE)
+ gfc_add_modify (&init, sym->ts.u.cl->backend_decl, len);
+ else
+ gfc_add_modify (&se.pre, sym->ts.u.cl->backend_decl, len);
}
/* If we didn't already do the pointer assignment, set associate-name
@@ -1978,7 +1986,8 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block
*block)
}
/* Done, register stuff as init / cleanup code. */
- gfc_add_init_cleanup (block, gfc_finish_block (&se.pre),
+ gfc_add_block_to_block (&init, &se.pre);
+ gfc_add_init_cleanup (block, gfc_finish_block (&init),
gfc_finish_block (&se.post));
}
diff --git a/gcc/testsuite/gfortran.dg/associate_69.f90
b/gcc/testsuite/gfortran.dg/associate_69.f90
new file mode 100644
index ..28f488bb2746
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/associate_69.f90
@@ -0,0 +1,33 @@
+! { dg-do compile }
+! { dg-options "-Og -Wuninitialized -Wmaybe-uninitialized
-fdump-tree-optimized" }
+!
+! PR fortran/115700 - Bogus warning for associate with assumed-length
character array
+!
+subroutine mvce(x)
+ implicit none
+ character(len=*), dimension(:), intent(in) :: x
+
+ associate (tmp1 => x)
+if (len (tmp1) /= len (x)) stop 1
+ end associate
+
+ associate (tmp2 => x(1:))
+if (len (tmp2) /= len (x)) stop 2
+ end associate
+
+ associate (tmp3 => x(1:)(:))
+if (len (tmp3) /= len (x)) stop 3
+ end associate
+
+! The following associate blocks still produce bogus warnings:
+
+! associate (tmp4 => x(:)(1:))
+! if (len (tmp4) /= len (x)) stop 4
+! end associate
+!
+! associate (tmp5 => x(1:)(1:))
+! if (len (tmp5) /= len (x)) stop 5
+! end associate
+end
+
+! { dg-final { scan-tree-dump-not " \\.tmp" "optimized" } }
[gcc r14-10928] Fortran: Fix problems with substring selectors in ASSOCIATE [PR115700]
https://gcc.gnu.org/g:58708cc6a599aa80f6b0422bd6aa33396f26077c
commit r14-10928-g58708cc6a599aa80f6b0422bd6aa33396f26077c
Author: Paul Thomas
Date: Fri Nov 1 07:45:00 2024 +
Fortran: Fix problems with substring selectors in ASSOCIATE [PR115700]
2024-11-01 Paul Thomas
gcc/fortran
PR fortran/115700
* resolve.cc (resolve_assoc_var): Extract a substring reference
with missing as well as non-constant start or end.
gcc/testsuite/
PR fortran/115700
* gfortran.dg/associate_69.f90: Activate commented out tests.
* gfortran.dg/associate_70.f90: Test correct functioning of
references in associate_69.f90 tests.
(cherry picked from commit 7f93910a8b5d606ad742a3594750f0c2b20d8bda)
Diff:
---
gcc/fortran/resolve.cc | 8 ++---
gcc/testsuite/gfortran.dg/associate_69.f90 | 23 +-
gcc/testsuite/gfortran.dg/associate_70.f90 | 50 +-
3 files changed, 54 insertions(+), 27 deletions(-)
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 50427f7450b4..1488e9e38238 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -9688,10 +9688,10 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
gfc_ref *ref;
for (ref = target->ref; ref; ref = ref->next)
if (ref->type == REF_SUBSTRING
- && ((ref->u.ss.start
-&& ref->u.ss.start->expr_type != EXPR_CONSTANT)
- || (ref->u.ss.end
- && ref->u.ss.end->expr_type != EXPR_CONSTANT)))
+ && (ref->u.ss.start == NULL
+ || ref->u.ss.start->expr_type != EXPR_CONSTANT
+ || ref->u.ss.end == NULL
+ || ref->u.ss.end->expr_type != EXPR_CONSTANT))
break;
if (!sym->ts.u.cl)
diff --git a/gcc/testsuite/gfortran.dg/associate_69.f90
b/gcc/testsuite/gfortran.dg/associate_69.f90
index 28f488bb2746..35db417867d4 100644
--- a/gcc/testsuite/gfortran.dg/associate_69.f90
+++ b/gcc/testsuite/gfortran.dg/associate_69.f90
@@ -2,10 +2,14 @@
! { dg-options "-Og -Wuninitialized -Wmaybe-uninitialized
-fdump-tree-optimized" }
!
! PR fortran/115700 - Bogus warning for associate with assumed-length
character array
+! This testcase checks for the suppression of the bogus error and associate_70
for
+! correct results.
!
subroutine mvce(x)
implicit none
character(len=*), dimension(:), intent(in) :: x
+ integer :: i
+ i = len(x)
associate (tmp1 => x)
if (len (tmp1) /= len (x)) stop 1
@@ -19,15 +23,18 @@ subroutine mvce(x)
if (len (tmp3) /= len (x)) stop 3
end associate
-! The following associate blocks still produce bogus warnings:
+ associate (tmp4 => x(:)(1:))
+if (len (tmp4) /= len (x)) stop 4
+ end associate
-! associate (tmp4 => x(:)(1:))
-! if (len (tmp4) /= len (x)) stop 4
-! end associate
-!
-! associate (tmp5 => x(1:)(1:))
-! if (len (tmp5) /= len (x)) stop 5
-! end associate
+ associate (tmp5 => x(1:)(1:))
+if (len (tmp5) /= len (x)) stop 5
+ end associate
+
+ associate (temp6 => x(:)(1:i/2))
+if (len (temp6) /= i/2) stop 6
+ end associate
end
! { dg-final { scan-tree-dump-not " \\.tmp" "optimized" } }
+! { dg-final { scan-tree-dump-times " \\.temp6" 7 "optimized" } }
diff --git a/gcc/testsuite/gfortran.dg/associate_70.f90
b/gcc/testsuite/gfortran.dg/associate_70.f90
index b8916f4c70fd..ddb38b84c4b3 100644
--- a/gcc/testsuite/gfortran.dg/associate_70.f90
+++ b/gcc/testsuite/gfortran.dg/associate_70.f90
@@ -3,37 +3,57 @@
!
! Test fix for PR115700 comment 5, in which ‘.tmp1’ is used uninitialized and
! both normal and scalarized array references did not work correctly.
+! This testcase checks for correct results and associate_69 for suppression
+! of the bogus error.
!
! Contributed by Harald Anlauf
!
character(4), dimension(3) :: chr = ['abcd', 'efgh', 'ijkl']
call mvce (chr)
if (any (chr /= ['ABcd', 'EFgh', 'IJkl'])) stop 1
+
contains
subroutine mvce(x)
implicit none
-character(len=*), dimension(:), intent(inOUT), target :: x
+character(len=*), dimension(:), intent(inOUT) :: x
integer :: i
i = len(x)
-! This was broken
-associate (tmp1 => x(:)(1:i/2))
- if (len (tmp1) /= i/2) stop 2
- if (tmp1(2) /= 'ef') stop 3
- if (any (tmp1 /= ['ab', 'ef', 'ij'])) stop 4
- tmp1 = ['AB','EF','IJ']
+associate (tmp1 => x)
+ if (len (tmp1) /= len (x)) stop 2
+ tmp1(2)(3:4) = '12'
+end associate
+if (any (x /= ['abcd', 'ef12', 'ijkl'])) stop 3
+
+associate (tmp2 => x(1:))
+ if (len (tmp2) /= len (x)) stop 4
+ tmp2(2)(1:2) = '34'
+end associate
+if (any (x /= ['abcd', '3412', 'ijkl'])) stop 5
+
+associate (tmp3 => x(1:)(:))
+ if (len (tmp3) /= len (x)) stop 6
+ tmp3(3)(3:4) = '56'
+end associate
+if (any (x /= ['abcd', '3412', 'ij56'])) stop 7
+
+associate (tmp4 =
[gcc r14-10929] Fortran: Fix associate_69.f90 that fails on some platforms [PR115700]
https://gcc.gnu.org/g:2b93936a122eaf5549c013cfdd27a1a164635ad7
commit r14-10929-g2b93936a122eaf5549c013cfdd27a1a164635ad7
Author: Paul Thomas
Date: Sun Nov 3 18:02:16 2024 +
Fortran: Fix associate_69.f90 that fails on some platforms [PR115700]
2024-11-03 Paul Thomas
gcc/testsuite/
PR fortran/115700
* gfortran.dg/associate_69.f90: Remove the test that produces a
variable string length because the optimized count depends on
the platform. This is tested in associate_70.f90.
(cherry picked from commit 4ed02814c2191d5febe0972c3e43c80c004f4799)
Diff:
---
gcc/testsuite/gfortran.dg/associate_69.f90 | 5 -
1 file changed, 5 deletions(-)
diff --git a/gcc/testsuite/gfortran.dg/associate_69.f90
b/gcc/testsuite/gfortran.dg/associate_69.f90
index 35db417867d4..3839718e7f0e 100644
--- a/gcc/testsuite/gfortran.dg/associate_69.f90
+++ b/gcc/testsuite/gfortran.dg/associate_69.f90
@@ -30,11 +30,6 @@ subroutine mvce(x)
associate (tmp5 => x(1:)(1:))
if (len (tmp5) /= len (x)) stop 5
end associate
-
- associate (temp6 => x(:)(1:i/2))
-if (len (temp6) /= i/2) stop 6
- end associate
end
! { dg-final { scan-tree-dump-not " \\.tmp" "optimized" } }
-! { dg-final { scan-tree-dump-times " \\.temp6" 7 "optimized" } }
[gcc r14-10927] Fortran: Fix problem with substring selectors in ASSOCIATE [PR115700]
https://gcc.gnu.org/g:caa2b2038dadcb545f825d5c736cc50d90245bbc
commit r14-10927-gcaa2b2038dadcb545f825d5c736cc50d90245bbc
Author: Paul Thomas
Date: Thu Oct 31 07:22:36 2024 +
Fortran: Fix problem with substring selectors in ASSOCIATE [PR115700]
2024-10-31 Paul Thomas
gcc/fortran
PR fortran/115700
* resolve.cc (resolve_variable): The typespec of an expression,
which is not a substring, can be shared with a deferred length
associate name.
(resolve_assoc_var): Extract a substring reference with non-
constant start or end. Use it to flag up the need for array
associate name to be a pointer.
(resolve_block_construct): Change comment from past to future
tense.
gcc/testsuite/
PR fortran/115700
* gfortran.dg/associate_70.f90: New test.
(cherry picked from commit 159fb203231c503418e7ab9f45282957e40cb195)
Diff:
---
gcc/fortran/resolve.cc | 33
gcc/testsuite/gfortran.dg/associate_70.f90 | 40 ++
2 files changed, 68 insertions(+), 5 deletions(-)
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index d7a0856fcca1..50427f7450b4 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -6011,6 +6011,15 @@ resolve_variable (gfc_expr *e)
e->ref = newref;
}
}
+ else if (sym->assoc && sym->ts.type == BT_CHARACTER && sym->ts.deferred)
+{
+ gfc_ref *ref;
+ for (ref = e->ref; ref; ref = ref->next)
+ if (ref->type == REF_SUBSTRING)
+ break;
+ if (ref == NULL)
+ e->ts = sym->ts;
+}
if (e->ref && !gfc_resolve_ref (e))
return false;
@@ -9676,6 +9685,15 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
/* Fix up the type-spec for CHARACTER types. */
if (sym->ts.type == BT_CHARACTER && !sym->attr.select_type_temporary)
{
+ gfc_ref *ref;
+ for (ref = target->ref; ref; ref = ref->next)
+ if (ref->type == REF_SUBSTRING
+ && ((ref->u.ss.start
+&& ref->u.ss.start->expr_type != EXPR_CONSTANT)
+ || (ref->u.ss.end
+ && ref->u.ss.end->expr_type != EXPR_CONSTANT)))
+ break;
+
if (!sym->ts.u.cl)
sym->ts.u.cl = target->ts.u.cl;
@@ -9694,9 +9712,10 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
gfc_get_int_expr (gfc_charlen_int_kind, NULL,
target->value.character.length);
}
- else if ((!sym->ts.u.cl->length
- || sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
+ else if (((!sym->ts.u.cl->length
+|| sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
&& target->expr_type != EXPR_VARIABLE)
+ || ref)
{
if (!sym->ts.deferred)
{
@@ -9706,7 +9725,10 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
/* This is reset in trans-stmt.cc after the assignment
of the target expression to the associate name. */
- sym->attr.allocatable = 1;
+ if (ref && sym->as)
+ sym->attr.pointer = 1;
+ else
+ sym->attr.allocatable = 1;
}
}
@@ -11290,8 +11312,9 @@ resolve_block_construct (gfc_code* code)
{
gfc_namespace *ns = code->ext.block.ns;
- /* For an ASSOCIATE block, the associations (and their targets) are already
- resolved during resolve_symbol. Resolve the BLOCK's namespace. */
+ /* For an ASSOCIATE block, the associations (and their targets) will be
+ resolved by gfc_resolve_symbol, during resolution of the BLOCK's
+ namespace. */
gfc_resolve (ns);
}
diff --git a/gcc/testsuite/gfortran.dg/associate_70.f90
b/gcc/testsuite/gfortran.dg/associate_70.f90
new file mode 100644
index ..b8916f4c70fd
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/associate_70.f90
@@ -0,0 +1,40 @@
+! { dg-do run }
+! ( dg-options "-Wuninitialized" )
+!
+! Test fix for PR115700 comment 5, in which ‘.tmp1’ is used uninitialized and
+! both normal and scalarized array references did not work correctly.
+!
+! Contributed by Harald Anlauf
+!
+ character(4), dimension(3) :: chr = ['abcd', 'efgh', 'ijkl']
+ call mvce (chr)
+ if (any (chr /= ['ABcd', 'EFgh', 'IJkl'])) stop 1
+contains
+ subroutine mvce(x)
+implicit none
+character(len=*), dimension(:), intent(inOUT), target :: x
+integer :: i
+i = len(x)
+
+! This was broken
+associate (tmp1 => x(:)(1:i/2))
+ if (len (tmp1) /= i/2) stop 2
+ if (tmp1(2) /= 'ef') stop 3
+ if (any (tmp1 /= ['ab', 'ef', 'ij'])) stop 4
+ tmp1 = ['AB','EF','IJ']
+end associate
+
+! Retest things that worked previously.
+associate (tmp2 => x(:)(1:2))
+ if (len (tmp2) /= i/2) stop 5
+ if (tmp2(2) /= 'EF') stop 6
+ if (any (tmp2 /= ['AB','
[gcc r13-9188] Fortran: Fix problem with substring selectors in ASSOCIATE [PR115700]
https://gcc.gnu.org/g:b706a96cdfe5a8bce6d79cba14be5f563cb69f4b
commit r13-9188-gb706a96cdfe5a8bce6d79cba14be5f563cb69f4b
Author: Paul Thomas
Date: Thu Oct 31 07:22:36 2024 +
Fortran: Fix problem with substring selectors in ASSOCIATE [PR115700]
2024-10-31 Paul Thomas
gcc/fortran
PR fortran/115700
* resolve.cc (resolve_variable): The typespec of an expression,
which is not a substring, can be shared with a deferred length
associate name.
(resolve_assoc_var): Extract a substring reference with non-
constant start or end. Use it to flag up the need for array
associate name to be a pointer.
(resolve_block_construct): Change comment from past to future
tense.
gcc/testsuite/
PR fortran/115700
* gfortran.dg/associate_70.f90: New test.
(cherry picked from commit 159fb203231c503418e7ab9f45282957e40cb195)
Diff:
---
gcc/fortran/resolve.cc | 33
gcc/testsuite/gfortran.dg/associate_70.f90 | 40 ++
2 files changed, 68 insertions(+), 5 deletions(-)
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 453dd90b5fbc..3a1f79c674fa 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -5956,6 +5956,15 @@ resolve_variable (gfc_expr *e)
e->ref = newref;
}
}
+ else if (sym->assoc && sym->ts.type == BT_CHARACTER && sym->ts.deferred)
+{
+ gfc_ref *ref;
+ for (ref = e->ref; ref; ref = ref->next)
+ if (ref->type == REF_SUBSTRING)
+ break;
+ if (ref == NULL)
+ e->ts = sym->ts;
+}
if (e->ref && !gfc_resolve_ref (e))
return false;
@@ -9387,6 +9396,15 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
/* Fix up the type-spec for CHARACTER types. */
if (sym->ts.type == BT_CHARACTER && !sym->attr.select_type_temporary)
{
+ gfc_ref *ref;
+ for (ref = target->ref; ref; ref = ref->next)
+ if (ref->type == REF_SUBSTRING
+ && ((ref->u.ss.start
+&& ref->u.ss.start->expr_type != EXPR_CONSTANT)
+ || (ref->u.ss.end
+ && ref->u.ss.end->expr_type != EXPR_CONSTANT)))
+ break;
+
if (!sym->ts.u.cl)
sym->ts.u.cl = target->ts.u.cl;
@@ -9405,9 +9423,10 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
gfc_get_int_expr (gfc_charlen_int_kind, NULL,
target->value.character.length);
}
- else if ((!sym->ts.u.cl->length
- || sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
+ else if (((!sym->ts.u.cl->length
+|| sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
&& target->expr_type != EXPR_VARIABLE)
+ || ref)
{
if (!sym->ts.deferred)
{
@@ -9417,7 +9436,10 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
/* This is reset in trans-stmt.cc after the assignment
of the target expression to the associate name. */
- sym->attr.allocatable = 1;
+ if (ref && sym->as)
+ sym->attr.pointer = 1;
+ else
+ sym->attr.allocatable = 1;
}
}
@@ -10971,8 +10993,9 @@ resolve_block_construct (gfc_code* code)
{
gfc_namespace *ns = code->ext.block.ns;
- /* For an ASSOCIATE block, the associations (and their targets) are already
- resolved during resolve_symbol. Resolve the BLOCK's namespace. */
+ /* For an ASSOCIATE block, the associations (and their targets) will be
+ resolved by gfc_resolve_symbol, during resolution of the BLOCK's
+ namespace. */
gfc_resolve (ns);
}
diff --git a/gcc/testsuite/gfortran.dg/associate_70.f90
b/gcc/testsuite/gfortran.dg/associate_70.f90
new file mode 100644
index ..b8916f4c70fd
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/associate_70.f90
@@ -0,0 +1,40 @@
+! { dg-do run }
+! ( dg-options "-Wuninitialized" )
+!
+! Test fix for PR115700 comment 5, in which ‘.tmp1’ is used uninitialized and
+! both normal and scalarized array references did not work correctly.
+!
+! Contributed by Harald Anlauf
+!
+ character(4), dimension(3) :: chr = ['abcd', 'efgh', 'ijkl']
+ call mvce (chr)
+ if (any (chr /= ['ABcd', 'EFgh', 'IJkl'])) stop 1
+contains
+ subroutine mvce(x)
+implicit none
+character(len=*), dimension(:), intent(inOUT), target :: x
+integer :: i
+i = len(x)
+
+! This was broken
+associate (tmp1 => x(:)(1:i/2))
+ if (len (tmp1) /= i/2) stop 2
+ if (tmp1(2) /= 'ef') stop 3
+ if (any (tmp1 /= ['ab', 'ef', 'ij'])) stop 4
+ tmp1 = ['AB','EF','IJ']
+end associate
+
+! Retest things that worked previously.
+associate (tmp2 => x(:)(1:2))
+ if (len (tmp2) /= i/2) stop 5
+ if (tmp2(2) /= 'EF') stop 6
+ if (any (tmp2 /= ['AB','E
[gcc r13-9190] Fortran: Fix associate_69.f90 that fails on some platforms [PR115700]
https://gcc.gnu.org/g:af07851b385b6222cddcd701aca315524a5082e8
commit r13-9190-gaf07851b385b6222cddcd701aca315524a5082e8
Author: Paul Thomas
Date: Sun Nov 3 18:02:16 2024 +
Fortran: Fix associate_69.f90 that fails on some platforms [PR115700]
2024-11-03 Paul Thomas
gcc/testsuite/
PR fortran/115700
* gfortran.dg/associate_69.f90: Remove the test that produces a
variable string length because the optimized count depends on
the platform. This is tested in associate_70.f90.
(cherry picked from commit 4ed02814c2191d5febe0972c3e43c80c004f4799)
Diff:
---
gcc/testsuite/gfortran.dg/associate_69.f90 | 5 -
1 file changed, 5 deletions(-)
diff --git a/gcc/testsuite/gfortran.dg/associate_69.f90
b/gcc/testsuite/gfortran.dg/associate_69.f90
index 35db417867d4..3839718e7f0e 100644
--- a/gcc/testsuite/gfortran.dg/associate_69.f90
+++ b/gcc/testsuite/gfortran.dg/associate_69.f90
@@ -30,11 +30,6 @@ subroutine mvce(x)
associate (tmp5 => x(1:)(1:))
if (len (tmp5) /= len (x)) stop 5
end associate
-
- associate (temp6 => x(:)(1:i/2))
-if (len (temp6) /= i/2) stop 6
- end associate
end
! { dg-final { scan-tree-dump-not " \\.tmp" "optimized" } }
-! { dg-final { scan-tree-dump-times " \\.temp6" 7 "optimized" } }
[gcc r13-9189] Fortran: Fix problems with substring selectors in ASSOCIATE [PR115700]
https://gcc.gnu.org/g:50139164b162c968d1e46b4c4a80bd815a00a5da
commit r13-9189-g50139164b162c968d1e46b4c4a80bd815a00a5da
Author: Paul Thomas
Date: Fri Nov 1 07:45:00 2024 +
Fortran: Fix problems with substring selectors in ASSOCIATE [PR115700]
2024-11-01 Paul Thomas
gcc/fortran
PR fortran/115700
* resolve.cc (resolve_assoc_var): Extract a substring reference
with missing as well as non-constant start or end.
gcc/testsuite/
PR fortran/115700
* gfortran.dg/associate_69.f90: Activate commented out tests.
* gfortran.dg/associate_70.f90: Test correct functioning of
references in associate_69.f90 tests.
(cherry picked from commit 7f93910a8b5d606ad742a3594750f0c2b20d8bda)
Diff:
---
gcc/fortran/resolve.cc | 8 ++---
gcc/testsuite/gfortran.dg/associate_69.f90 | 23 +-
gcc/testsuite/gfortran.dg/associate_70.f90 | 50 +-
3 files changed, 54 insertions(+), 27 deletions(-)
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 3a1f79c674fa..adfde61bbdb1 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -9399,10 +9399,10 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
gfc_ref *ref;
for (ref = target->ref; ref; ref = ref->next)
if (ref->type == REF_SUBSTRING
- && ((ref->u.ss.start
-&& ref->u.ss.start->expr_type != EXPR_CONSTANT)
- || (ref->u.ss.end
- && ref->u.ss.end->expr_type != EXPR_CONSTANT)))
+ && (ref->u.ss.start == NULL
+ || ref->u.ss.start->expr_type != EXPR_CONSTANT
+ || ref->u.ss.end == NULL
+ || ref->u.ss.end->expr_type != EXPR_CONSTANT))
break;
if (!sym->ts.u.cl)
diff --git a/gcc/testsuite/gfortran.dg/associate_69.f90
b/gcc/testsuite/gfortran.dg/associate_69.f90
index 28f488bb2746..35db417867d4 100644
--- a/gcc/testsuite/gfortran.dg/associate_69.f90
+++ b/gcc/testsuite/gfortran.dg/associate_69.f90
@@ -2,10 +2,14 @@
! { dg-options "-Og -Wuninitialized -Wmaybe-uninitialized
-fdump-tree-optimized" }
!
! PR fortran/115700 - Bogus warning for associate with assumed-length
character array
+! This testcase checks for the suppression of the bogus error and associate_70
for
+! correct results.
!
subroutine mvce(x)
implicit none
character(len=*), dimension(:), intent(in) :: x
+ integer :: i
+ i = len(x)
associate (tmp1 => x)
if (len (tmp1) /= len (x)) stop 1
@@ -19,15 +23,18 @@ subroutine mvce(x)
if (len (tmp3) /= len (x)) stop 3
end associate
-! The following associate blocks still produce bogus warnings:
+ associate (tmp4 => x(:)(1:))
+if (len (tmp4) /= len (x)) stop 4
+ end associate
-! associate (tmp4 => x(:)(1:))
-! if (len (tmp4) /= len (x)) stop 4
-! end associate
-!
-! associate (tmp5 => x(1:)(1:))
-! if (len (tmp5) /= len (x)) stop 5
-! end associate
+ associate (tmp5 => x(1:)(1:))
+if (len (tmp5) /= len (x)) stop 5
+ end associate
+
+ associate (temp6 => x(:)(1:i/2))
+if (len (temp6) /= i/2) stop 6
+ end associate
end
! { dg-final { scan-tree-dump-not " \\.tmp" "optimized" } }
+! { dg-final { scan-tree-dump-times " \\.temp6" 7 "optimized" } }
diff --git a/gcc/testsuite/gfortran.dg/associate_70.f90
b/gcc/testsuite/gfortran.dg/associate_70.f90
index b8916f4c70fd..ddb38b84c4b3 100644
--- a/gcc/testsuite/gfortran.dg/associate_70.f90
+++ b/gcc/testsuite/gfortran.dg/associate_70.f90
@@ -3,37 +3,57 @@
!
! Test fix for PR115700 comment 5, in which ‘.tmp1’ is used uninitialized and
! both normal and scalarized array references did not work correctly.
+! This testcase checks for correct results and associate_69 for suppression
+! of the bogus error.
!
! Contributed by Harald Anlauf
!
character(4), dimension(3) :: chr = ['abcd', 'efgh', 'ijkl']
call mvce (chr)
if (any (chr /= ['ABcd', 'EFgh', 'IJkl'])) stop 1
+
contains
subroutine mvce(x)
implicit none
-character(len=*), dimension(:), intent(inOUT), target :: x
+character(len=*), dimension(:), intent(inOUT) :: x
integer :: i
i = len(x)
-! This was broken
-associate (tmp1 => x(:)(1:i/2))
- if (len (tmp1) /= i/2) stop 2
- if (tmp1(2) /= 'ef') stop 3
- if (any (tmp1 /= ['ab', 'ef', 'ij'])) stop 4
- tmp1 = ['AB','EF','IJ']
+associate (tmp1 => x)
+ if (len (tmp1) /= len (x)) stop 2
+ tmp1(2)(3:4) = '12'
+end associate
+if (any (x /= ['abcd', 'ef12', 'ijkl'])) stop 3
+
+associate (tmp2 => x(1:))
+ if (len (tmp2) /= len (x)) stop 4
+ tmp2(2)(1:2) = '34'
+end associate
+if (any (x /= ['abcd', '3412', 'ijkl'])) stop 5
+
+associate (tmp3 => x(1:)(:))
+ if (len (tmp3) /= len (x)) stop 6
+ tmp3(3)(3:4) = '56'
+end associate
+if (any (x /= ['abcd', '3412', 'ij56'])) stop 7
+
+associate (tmp4 =>
[gcc r15-5674] Fortran: Partial reversion of r15-5083 [PR117763]
https://gcc.gnu.org/g:8278d9551df610179fca114808a7e6e62bab3d82
commit r15-5674-g8278d9551df610179fca114808a7e6e62bab3d82
Author: Paul Thomas
Date: Tue Nov 26 08:58:21 2024 +
Fortran: Partial reversion of r15-5083 [PR117763]
2024-11-26 Paul Thomas
gcc/fortran
PR fortran/117763
* trans-array.cc (gfc_get_array_span): Guard against derefences
of 'expr'. Clean up some typos. Use 'gfc_get_vptr_from_expr'
for clarity and apply a functional reversion of last section
that deals with class dummies.
gcc/testsuite/
PR fortran/117763
* gfortran.dg/pr117763.f90: New test.
Diff:
---
gcc/fortran/trans-array.cc | 16 +-
gcc/testsuite/gfortran.dg/pr117763.f90 | 279 +
2 files changed, 289 insertions(+), 6 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 32dcd4cb0c7d..a458af322ce8 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -961,8 +961,8 @@ tree
gfc_get_array_span (tree desc, gfc_expr *expr)
{
tree tmp;
- gfc_symbol *sym = expr->expr_type == EXPR_VARIABLE
- ? expr->symtree->n.sym : NULL;
+ gfc_symbol *sym = (expr && expr->expr_type == EXPR_VARIABLE) ?
+ expr->symtree->n.sym : NULL;
if (is_pointer_array (desc)
|| (get_CFI_desc (NULL, expr, &desc, NULL)
@@ -989,7 +989,7 @@ gfc_get_array_span (tree desc, gfc_expr *expr)
{
/* Treat unlimited polymorphic expressions separately because
the element size need not be the same as the span. Obtain
-the class container, which is simplified here by their being
+the class container, which is simplified here by there being
no component references. */
if (sym && sym->attr.dummy)
{
@@ -1013,12 +1013,16 @@ gfc_get_array_span (tree desc, gfc_expr *expr)
/* The descriptor is a class _data field. Use the vtable size
since it is guaranteed to have been set and is always OK for
class array descriptors that are not unlimited. */
- tmp = gfc_class_vptr_get (TREE_OPERAND (desc, 0));
+ tmp = gfc_get_vptr_from_expr (desc);
tmp = gfc_vptr_size_get (tmp);
}
- else if (sym && sym->ts.type == BT_CLASS && sym->attr.dummy)
+ else if (sym && sym->ts.type == BT_CLASS
+ && expr->ref->type == REF_COMPONENT
+ && expr->ref->next->type == REF_ARRAY
+ && expr->ref->next->next == NULL
+ && CLASS_DATA (sym)->attr.dimension)
{
- /* Class dummys usually requires extraction from the saved
+ /* Class dummys usually require extraction from the saved
descriptor, which gfc_class_vptr_get does for us. */
tmp = gfc_class_vptr_get (sym->backend_decl);
tmp = gfc_vptr_size_get (tmp);
diff --git a/gcc/testsuite/gfortran.dg/pr117763.f90
b/gcc/testsuite/gfortran.dg/pr117763.f90
new file mode 100644
index ..5f7b36c02694
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr117763.f90
@@ -0,0 +1,279 @@
+! { dg-do compile }
+! { dg-options "-fdump-tree-original" }
+!
+! Test the fix for PR117763, which was a regression caused by the patch for
+! PR109345.
+!
+! Contributed by Juergen Reuter
+!
+module iso_varying_string
+ implicit none
+ integer, parameter, private :: GET_BUFFER_LEN = 1
+
+ type, public :: varying_string
+ private
+ character(LEN=1), dimension(:), allocatable :: chars
+ end type varying_string
+
+ interface assignment(=)
+ module procedure op_assign_CH_VS
+ module procedure op_assign_VS_CH
+ end interface assignment(=)
+
+ interface char
+ module procedure char_auto
+ module procedure char_fixed
+ end interface char
+
+ interface len
+ module procedure len_
+ end interface len
+
+ interface var_str
+ module procedure var_str_
+ end interface var_str
+
+ public :: assignment(=)
+ public :: char
+ public :: len
+ public :: var_str
+
+ private :: op_assign_CH_VS
+ private :: op_assign_VS_CH
+ private :: char_auto
+ private :: char_fixed
+ private :: len_
+ private :: var_str_
+
+contains
+
+ elemental function len_ (string) result (length)
+type(varying_string), intent(in) :: string
+integer :: length
+if(ALLOCATED(string%chars)) then
+ length = SIZE(string%chars)
+else
+ length = 0
+endif
+ end function len_
+
+ elemental subroutine op_assign_CH_VS (var, exp)
+character(LEN=*), intent(out):: var
+type(varying_string), intent(in) :: exp
+var = char(exp)
+ end subroutine op_assign_CH_VS
+
+ elemental subroutine op_assign_VS_CH (var, exp)
+type(varying_string), intent(out) :: var
+character(LEN=*), intent(in) :: exp
+var = var_str(exp)
+ end subroutine op_assign_VS_CH
+
+ pure function char_auto (string) result (char_string)
+type(varying_string), intent(in) :: string
+character(
[gcc r15-5897] Fortran: Fix class transformational intrinsic calls [PR102689]
https://gcc.gnu.org/g:31250baf81446aa4fc1b729e2fc5165a36005ebc
commit r15-5897-g31250baf81446aa4fc1b729e2fc5165a36005ebc
Author: Paul Thomas
Date: Tue Dec 3 15:56:53 2024 +
Fortran: Fix class transformational intrinsic calls [PR102689]
2024-12-03 Paul Thomas
gcc/fortran
PR fortran/102689
* trans-array.cc (get_array_ref_dim_for_loop_dim): Use the arg1
class container carried in ss->info as the seed for a lhs in
class valued transformational intrinsic calls that are not the
rhs of an assignment. Otherwise, the lhs variable expression is
taken from the loop chain. For this latter case, the _vptr and
_len fields are set.
(gfc_trans_create_temp_array): Use either the lhs expression
seeds to build a class variable that will take the returned
descriptor as its _data field. In the case that the arg1 expr.
is used, 'atmp' must be marked as unused, a typespec built with
the correct rank and the _vptr and _len fields set. The element
size is provided for the temporary allocation and to set the
descriptor span.
(gfc_array_init_size): When an intrinsic type scalar expr3 is
used in allocation of a class array, use its element size in
the descriptor dtype.
* trans-expr.cc (gfc_conv_class_to_class): Class valued
transformational intrinsics return the pointer to the array
descriptor as the _data field of a class temporary. Extract
directly and return the address of the class temporary.
(gfc_conv_procedure_call): store the expression for the first
argument of a class valued transformational intrinsic function
in the ss info class_container field. Later, use its type as
the element type in the call to gfc_trans_create_temp_array.
(fcncall_realloc_result): Add a dtype argument and use it in
the descriptor, when available.
(gfc_trans_arrayfunc_assign): For class lhs, build a dtype with
the lhs rank and the rhs element size and use it in the call to
fcncall_realloc_result.
gcc/testsuite/
PR fortran/102689
* gfortran.dg/class_transformational_1.f90: New test for class-
valued reshape.
* gfortran.dg/class_transformational_2.f90: New test for other
class_valued transformational intrinsics.
Diff:
---
gcc/fortran/trans-array.cc | 157 +---
gcc/fortran/trans-expr.cc | 57 +-
.../gfortran.dg/class_transformational_1.f90 | 204 +
.../gfortran.dg/class_transformational_2.f90 | 107 +++
4 files changed, 490 insertions(+), 35 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index a458af322ce8..6ff2c238038d 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1325,23 +1325,28 @@ get_array_ref_dim_for_loop_dim (gfc_ss *ss, int
loop_dim)
is a class expression. */
static tree
-get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype)
+get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype,
+ gfc_ss **fcnss)
{
+ gfc_ss *loop_ss = ss->loop->ss;
gfc_ss *lhs_ss;
gfc_ss *rhs_ss;
+ gfc_ss *fcn_ss = NULL;
tree tmp;
tree tmp2;
tree vptr;
- tree rhs_class_expr = NULL_TREE;
+ tree class_expr = NULL_TREE;
tree lhs_class_expr = NULL_TREE;
bool unlimited_rhs = false;
bool unlimited_lhs = false;
bool rhs_function = false;
+ bool unlimited_arg1 = false;
gfc_symbol *vtab;
+ tree cntnr = NULL_TREE;
/* The second element in the loop chain contains the source for the
- temporary; ie. the rhs of the assignment. */
- rhs_ss = ss->loop->ss->loop_chain;
+ class temporary created in gfc_trans_create_temp_array. */
+ rhs_ss = loop_ss->loop_chain;
if (rhs_ss != gfc_ss_terminator
&& rhs_ss->info
@@ -1350,28 +1355,58 @@ get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss,
tree *eltype)
&& rhs_ss->info->data.array.descriptor)
{
if (rhs_ss->info->expr->expr_type != EXPR_VARIABLE)
- rhs_class_expr
+ class_expr
= gfc_get_class_from_expr (rhs_ss->info->data.array.descriptor);
else
- rhs_class_expr = gfc_get_class_from_gfc_expr (rhs_ss->info->expr);
+ class_expr = gfc_get_class_from_gfc_expr (rhs_ss->info->expr);
unlimited_rhs = UNLIMITED_POLY (rhs_ss->info->expr);
if (rhs_ss->info->expr->expr_type == EXPR_FUNCTION)
rhs_function = true;
}
+ /* Usually, ss points to the function. When the function call is an actual
+ argument, it is instead rhs_ss because the ss chain is shifted by one. */
+ *fcnss = fcn_ss = rhs_function ? rhs_ss : ss;
+
+ /
[gcc r15-6021] Fortran: Fix testsuite regressions after r15-5897 [PR116261/PR117901]
https://gcc.gnu.org/g:ad94070689b3fadafca14c188c650aad6b8600e7
commit r15-6021-gad94070689b3fadafca14c188c650aad6b8600e7
Author: Paul Thomas
Date: Mon Dec 9 07:32:22 2024 +
Fortran: Fix testsuite regressions after r15-5897 [PR116261/PR117901]
2024-12-09 Paul Thomas
gcc/fortran
PR fortran/116261
* trans-array.cc (gfc_array_init_size): New arg 'explicit_ts',
to suppress the use of the expr3 element size in the descriptor
dtype.
(gfc_array_allocate): New arg 'explicit_ts', used in call to
gfc_array_init_size.
* trans-array.h : Modify prototype for gfc_array_allocate for new
bool argument.
* trans-stmt.cc (gfc_trans_allocate): Set new argument if the
typespec is explicit.
gcc/testsuite/
PR fortran/117901
* gfortran.dg/class_transformational_1.f90: Temporary fix for
ICE with some compile options by setting dummy arg of
'unlimited rebar' to be allocatable.
Diff:
---
gcc/fortran/trans-array.cc | 10 ++
gcc/fortran/trans-array.h | 2 +-
gcc/fortran/trans-stmt.cc | 3 ++-
gcc/testsuite/gfortran.dg/class_transformational_1.f90 | 2 +-
4 files changed, 10 insertions(+), 7 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 6ff2c238038d..9a8477650f4a 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -6104,7 +6104,7 @@ gfc_array_init_size (tree descriptor, int rank, int
corank, tree * poffset,
stmtblock_t * descriptor_block, tree * overflow,
tree expr3_elem_size, tree *nelems, gfc_expr *expr3,
tree expr3_desc, bool e3_has_nodescriptor, gfc_expr *expr,
-tree *element_size)
+tree *element_size, bool explicit_ts)
{
tree type;
tree tmp;
@@ -6164,7 +6164,7 @@ gfc_array_init_size (tree descriptor, int rank, int
corank, tree * poffset,
tmp = gfc_conv_descriptor_dtype (descriptor);
gfc_add_modify (pblock, tmp, gfc_conv_descriptor_dtype (expr3_desc));
}
- else if (expr->ts.type == BT_CLASS
+ else if (expr->ts.type == BT_CLASS && !explicit_ts
&& expr3 && expr3->ts.type != BT_CLASS
&& expr3_elem_size != NULL_TREE && expr3_desc == NULL_TREE)
{
@@ -6469,7 +6469,8 @@ bool
gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
tree errlen, tree label_finish, tree expr3_elem_size,
tree *nelems, gfc_expr *expr3, tree e3_arr_desc,
- bool e3_has_nodescriptor, gfc_omp_namelist *omp_alloc)
+ bool e3_has_nodescriptor, gfc_omp_namelist *omp_alloc,
+ bool explicit_ts)
{
tree tmp;
tree pointer;
@@ -6601,7 +6602,8 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree
status, tree errmsg,
&offset, lower, upper,
&se->pre, &set_descriptor_block, &overflow,
expr3_elem_size, nelems, expr3, e3_arr_desc,
- e3_has_nodescriptor, expr, &element_size);
+ e3_has_nodescriptor, expr, &element_size,
+ explicit_ts);
if (dimension)
{
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index ab27f15cab22..becc8ca4a495 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -22,7 +22,7 @@ along with GCC; see the file COPYING3. If not see
se, which should contain an expression for the array descriptor. */
bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, tree,
tree, tree *, gfc_expr *, tree, bool,
-gfc_omp_namelist *);
+gfc_omp_namelist *, bool);
/* Allow the bounds of a loop to be set from a callee's array spec. */
void gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping *,
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index b8fba1d91fef..80a9502a8a41 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -6992,7 +6992,8 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist
*omp_allocate)
label_finish, tmp, &nelems,
e3rhs ? e3rhs : code->expr3,
e3_is == E3_DESC ? expr3 : NULL_TREE,
- e3_has_nodescriptor, omp_alloc_item))
+ e3_has_nodescriptor, omp_alloc_item,
+ code->ext.alloc.ts.type != BT_UNKNOWN))
{
/* A scalar or derived type. First compute the size to
allocate.
diff --git a/gcc/testsuite/gfortran.dg/class_transformational_1.f90
b/gcc/testsu
[gcc r13-9282] Fortran: Fix an assortment of bugs
https://gcc.gnu.org/g:fc062c12ff59b22061bea98a3539da857968bccb
commit r13-9282-gfc062c12ff59b22061bea98a3539da857968bccb
Author: Paul Thomas
Date: Tue May 16 06:35:40 2023 +0100
Fortran: Fix an assortment of bugs
2023-05-16 Paul Thomas
gcc/fortran
PR fortran/105152
* interface.cc (gfc_compare_actual_formal): Emit an error if an
unlimited polymorphic actual is not matched either to an
unlimited or assumed type formal argument.
PR fortran/100193
* resolve.cc (resolve_ordinary_assign): Emit an error if the
var expression of an ordinary assignment is a proc pointer
component.
PR fortran/87496
* trans-array.cc (gfc_walk_array_ref): Provide assumed shape
arrays coming from interface mapping with a viable arrayspec.
PR fortran/103389
* trans-expr.cc (gfc_conv_intrinsic_to_class): Tidy up flagging
of unlimited polymorphic 'class_ts'.
(gfc_conv_gfc_desc_to_cfi_desc): Assumed type is unlimited
polymorphic and should accept any actual type.
PR fortran/104429
(gfc_conv_procedure_call): Replace dreadful kludge with a call
to gfc_finalize_tree_expr. Avoid dereferencing a void pointer
by giving it the pointer type of the actual argument.
PR fortran/82774
(alloc_scalar_allocatable_subcomponent): Shorten the function
name and replace the symbol argument with the se string length.
If a deferred length character length is either not present or
is not a variable, give the typespec a variable and assign the
string length to that. Use gfc_deferred_strlen to find the
hidden string length component.
(gfc_trans_subcomponent_assign): Convert the expression before
the call to alloc_scalar_allocatable_subcomponent so that a
good string length is provided.
(gfc_trans_structure_assign): Remove the unneeded derived type
symbol from calls to gfc_trans_subcomponent_assign.
gcc/testsuite/
PR fortran/105152
* gfortran.dg/pr105152.f90 : New test
PR fortran/100193
* gfortran.dg/pr100193.f90 : New test
PR fortran/87946
* gfortran.dg/pr87946.f90 : New test
PR fortran/103389
* gfortran.dg/pr103389.f90 : New test
PR fortran/104429
* gfortran.dg/pr104429.f90 : New test
PR fortran/82774
* gfortran.dg/pr82774.f90 : New test
(cherry picked from commit 6c95fe9bc0553743098eeaa739f14b885050fa42)
Diff:
---
gcc/fortran/interface.cc | 10
gcc/fortran/resolve.cc | 11
gcc/fortran/trans-array.cc | 6 +++
gcc/fortran/trans-expr.cc | 96 +++---
gcc/testsuite/gfortran.dg/pr100193.f90 | 20 +++
gcc/testsuite/gfortran.dg/pr103389.f90 | 23
gcc/testsuite/gfortran.dg/pr104429.f90 | 35 +
gcc/testsuite/gfortran.dg/pr105152.f90 | 19 +++
gcc/testsuite/gfortran.dg/pr82774.f90 | 15 ++
gcc/testsuite/gfortran.dg/pr87946.f90 | 42 +++
10 files changed, 223 insertions(+), 54 deletions(-)
diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc
index 05c92ab8f678..48bec125d346 100644
--- a/gcc/fortran/interface.cc
+++ b/gcc/fortran/interface.cc
@@ -3360,6 +3360,16 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap,
gfc_formal_arglist *formal,
}
}
+ if (UNLIMITED_POLY (a->expr)
+ && !(f->sym->ts.type == BT_ASSUMED || UNLIMITED_POLY (f->sym)))
+ {
+ gfc_error ("Unlimited polymorphic actual argument at %L is not "
+"matched with either an unlimited polymorphic or "
+"assumed type dummy argument", &a->expr->where);
+ ok = false;
+ goto match;
+ }
+
/* Special case for character arguments. For allocatable, pointer
and assumed-shape dummies, the string length needs to match
exactly. */
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 6f13725cac57..b9c027ccc0f0 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -11201,6 +11201,17 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace
*ns)
lhs = code->expr1;
rhs = code->expr2;
+ if ((lhs->symtree->n.sym->ts.type == BT_DERIVED
+ || lhs->symtree->n.sym->ts.type == BT_CLASS)
+ && !lhs->symtree->n.sym->attr.proc_pointer
+ && gfc_expr_attr (lhs).proc_pointer)
+{
+ gfc_error ("Variable in the ordinary assignment at %L is a procedure "
+"pointer component",
+&lhs->where);
+ return false;
+}
+
if ((gfc_numeric_ts (&lhs->t
[gcc r15-7389] Fortran: FIx ICE in associate with elemental function [PR118750]
https://gcc.gnu.org/g:a03303b4d5b2ca58e5750a4d5bd735d85a091273
commit r15-7389-ga03303b4d5b2ca58e5750a4d5bd735d85a091273
Author: Paul Thomas
Date: Thu Feb 6 16:40:19 2025 +
Fortran: FIx ICE in associate with elemental function [PR118750]
2025-02-06 Paul Thomas
gcc/fortran
PR fortran/118750
* resolve.cc (resolve_assoc_var): If the target expression has
a rank, do not use gfc_expression_rank, since it will return 0
if the function is elemental. Resolution will have produced the
correct rank.
gcc/testsuite/
PR fortran/118750
* gfortran.dg/associate_72.f90: New test.
Diff:
---
gcc/fortran/resolve.cc | 2 +-
gcc/testsuite/gfortran.dg/associate_72.f90 | 26 ++
2 files changed, 27 insertions(+), 1 deletion(-)
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index c9736db908fe..7adbf958aec1 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -10728,7 +10728,7 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
|| gfc_is_ptr_fcn (target));
/* Finally resolve if this is an array or not. */
- if (target->expr_type == EXPR_FUNCTION
+ if (target->expr_type == EXPR_FUNCTION && target->rank == 0
&& (sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED))
{
gfc_expression_rank (target);
diff --git a/gcc/testsuite/gfortran.dg/associate_72.f90
b/gcc/testsuite/gfortran.dg/associate_72.f90
new file mode 100644
index ..993ebdfd5a7e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/associate_72.f90
@@ -0,0 +1,26 @@
+! { dg-do compile }
+! { dg-options "-fdump-tree-original" }
+!
+! Test the fix for the 14/15 regression PR118750
+!
+! Contributed by Damian Rouson
+!
+ implicit none
+
+ type string_t
+character(:), allocatable :: str
+ end type
+
+ associate(str_a => get_string([string_t ("abcd"),string_t ("ef")]))
+if (str_a(1)%str//str_a(2)%str /= "abcdef") STOP 1 ! Returned "Invalid
array reference at (1)"
+ end associate
+
+contains
+
+ type(string_t) elemental function get_string(mold)
+class(string_t), intent(in) :: mold
+get_string = string_t(mold%str)
+ end function
+
+end
+! { dg-final { scan-tree-dump-times "array01_string_t str_a" 1 "original" } }
[gcc r15-7412] Fortran: Fix default init of finalizable derived argus [PR116829]
https://gcc.gnu.org/g:251aa524a314faa749b7dd1b7da048e6e6476015
commit r15-7412-g251aa524a314faa749b7dd1b7da048e6e6476015
Author: Paul Thomas
Date: Fri Feb 7 12:46:44 2025 +
Fortran: Fix default init of finalizable derived argus [PR116829]
2025-02-07 Tomáš Trnka
gcc/fortran
PR fortran/116829
* trans-decl.cc (init_intent_out_dt): Always call
gfc_init_default_dt() for BT_DERIVED to apply s->value if the
symbol isn't allocatable. Also simplify the logic a bit.
gcc/testsuite/
PR fortran/116829
* gfortran.dg/derived_init_7.f90: New test.
Diff:
---
gcc/fortran/trans-decl.cc| 21 +++---
gcc/testsuite/gfortran.dg/derived_init_7.f90 | 58
2 files changed, 64 insertions(+), 15 deletions(-)
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index 017f184f1794..83f8130afd87 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -4551,7 +4551,6 @@ init_intent_out_dt (gfc_symbol * proc_sym,
gfc_wrapped_block * block)
tree tmp;
tree present;
gfc_symbol *s;
- bool dealloc_with_value = false;
gfc_init_block (&init);
for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next)
@@ -4582,12 +4581,9 @@ init_intent_out_dt (gfc_symbol * proc_sym,
gfc_wrapped_block * block)
by the caller. */
if (tmp == NULL_TREE && !s->attr.allocatable
&& s->ts.u.derived->attr.alloc_comp)
- {
- tmp = gfc_deallocate_alloc_comp (s->ts.u.derived,
-s->backend_decl,
-s->as ? s->as->rank : 0);
- dealloc_with_value = s->value;
- }
+ tmp = gfc_deallocate_alloc_comp (s->ts.u.derived,
+ s->backend_decl,
+ s->as ? s->as->rank : 0);
if (tmp != NULL_TREE && (s->attr.optional
|| s->ns->proc_name->attr.entry_master))
@@ -4597,14 +4593,9 @@ init_intent_out_dt (gfc_symbol * proc_sym,
gfc_wrapped_block * block)
present, tmp, build_empty_stmt (input_location));
}
- if (tmp != NULL_TREE && !dealloc_with_value)
- gfc_add_expr_to_block (&init, tmp);
- else if (s->value && !s->attr.allocatable)
- {
- gfc_add_expr_to_block (&init, tmp);
- gfc_init_default_dt (s, &init, false);
- dealloc_with_value = false;
- }
+ gfc_add_expr_to_block (&init, tmp);
+ if (s->value && !s->attr.allocatable)
+ gfc_init_default_dt (s, &init, false);
}
else if (f->sym && f->sym->attr.intent == INTENT_OUT
&& f->sym->ts.type == BT_CLASS
diff --git a/gcc/testsuite/gfortran.dg/derived_init_7.f90
b/gcc/testsuite/gfortran.dg/derived_init_7.f90
new file mode 100644
index ..f145385b5e21
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/derived_init_7.f90
@@ -0,0 +1,58 @@
+! { dg-do run }
+! Check that finalizable intent(out) dummy arguments are first finalized
+! and then correctly default-initialized (PR116829)
+!
+! Contributed by Tomas Trnka
+!
+module FinalizableIntentOutTestModule
+ implicit none
+
+ type :: AapType
+ integer :: i = 0
+ contains
+ final:: Finalizer
+ end type
+ integer :: ctr = 0
+ logical :: err1 = .false.
+ logical :: err2 = .false.
+contains
+
+ subroutine Finalizer(self)
+ type(AapType), intent(inout) :: self
+
+ ! Fail if Finalizer gets called again on an already finalized object
+ if (self%i == 42) err1 = .true.
+
+ self%i = 42 ! Nobody should ever see this value after finalization
+ ctr = ctr + 1
+ end subroutine
+
+end module
+
+
+program test
+ use FinalizableIntentOutTestModule
+
+ implicit none
+
+ type(AapType) :: aap
+
+ ! Set "i" to nonzero so that initialization in MakeAap has something to do
+ aap%i = 1
+
+ call MakeAap(aap)
+
+ if (err1) stop 1
+ if (err2) stop 2 ! This was failing
+ if (ctr /= 1) stop 3 ! Belt and braces to ensure number of final calls
correct.
+
+contains
+
+ subroutine MakeAap(a)
+ type(AapType), intent(out) :: a
+
+ ! Fail if "a" wasn't initialized properly
+ if (a%i /= 0) err2 = .true.
+ end subroutine
+
+end program
[gcc r14-11279] Fortran: FIx ICE in associate with elemental function [PR118750]
https://gcc.gnu.org/g:1cd744a6828f6ab9179906d16434ea40b6404737
commit r14-11279-g1cd744a6828f6ab9179906d16434ea40b6404737
Author: Paul Thomas
Date: Thu Feb 6 16:40:19 2025 +
Fortran: FIx ICE in associate with elemental function [PR118750]
2025-02-06 Paul Thomas
gcc/fortran
PR fortran/118750
* resolve.cc (resolve_assoc_var): If the target expression has
a rank, do not use gfc_expression_rank, since it will return 0
if the function is elemental. Resolution will have produced the
correct rank.
gcc/testsuite/
PR fortran/118750
* gfortran.dg/associate_72.f90: New test.
(cherry picked from commit a03303b4d5b2ca58e5750a4d5bd735d85a091273)
Diff:
---
gcc/fortran/resolve.cc | 2 +-
gcc/testsuite/gfortran.dg/associate_72.f90 | 26 ++
2 files changed, 27 insertions(+), 1 deletion(-)
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 4d5e8b5537ab..a0ed0e516da3 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -9547,7 +9547,7 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
|| gfc_is_ptr_fcn (target));
/* Finally resolve if this is an array or not. */
- if (target->expr_type == EXPR_FUNCTION
+ if (target->expr_type == EXPR_FUNCTION && target->rank == 0
&& (sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED))
{
gfc_expression_rank (target);
diff --git a/gcc/testsuite/gfortran.dg/associate_72.f90
b/gcc/testsuite/gfortran.dg/associate_72.f90
new file mode 100644
index ..993ebdfd5a7e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/associate_72.f90
@@ -0,0 +1,26 @@
+! { dg-do compile }
+! { dg-options "-fdump-tree-original" }
+!
+! Test the fix for the 14/15 regression PR118750
+!
+! Contributed by Damian Rouson
+!
+ implicit none
+
+ type string_t
+character(:), allocatable :: str
+ end type
+
+ associate(str_a => get_string([string_t ("abcd"),string_t ("ef")]))
+if (str_a(1)%str//str_a(2)%str /= "abcdef") STOP 1 ! Returned "Invalid
array reference at (1)"
+ end associate
+
+contains
+
+ type(string_t) elemental function get_string(mold)
+class(string_t), intent(in) :: mold
+get_string = string_t(mold%str)
+ end function
+
+end
+! { dg-final { scan-tree-dump-times "array01_string_t str_a" 1 "original" } }
[gcc r14-11278] Fortran: Fix error recovery for bad component arrayspecs [PR108434]
https://gcc.gnu.org/g:4d4c5ec93d65752a4aeda6bf2c9efe429e637969
commit r14-11278-g4d4c5ec93d65752a4aeda6bf2c9efe429e637969
Author: Paul Thomas
Date: Sat Jan 11 08:23:48 2025 +
Fortran: Fix error recovery for bad component arrayspecs [PR108434]
2025-01-11 Paul Thomas
gcc/fortran/
PR fortran/108434
* class.cc (generate_finalization_wrapper): To avoid memory
leaks from callocs, return immediately if the derived type
error flag is set.
* decl.cc (build_struct): If the declaration of a derived type
or class component does not have a deferred arrayspec, correct,
set the error flag of the derived type and emit an immediate
error.
gcc/testsuite/
PR fortran/108434
* gfortran.dg/pr108434.f90 : Add tests from comment 1.
(cherry picked from commit d64ca15351029164bac30b49fb3c4f9723e755de)
Diff:
---
gcc/fortran/class.cc | 2 +-
gcc/fortran/decl.cc| 19 ---
gcc/testsuite/gfortran.dg/pr108434.f90 | 10 +-
3 files changed, 26 insertions(+), 5 deletions(-)
diff --git a/gcc/fortran/class.cc b/gcc/fortran/class.cc
index d34bd25cb5e1..513278ffa535 100644
--- a/gcc/fortran/class.cc
+++ b/gcc/fortran/class.cc
@@ -1726,7 +1726,7 @@ generate_finalization_wrapper (gfc_symbol *derived,
gfc_namespace *ns,
gfc_expr *ancestor_wrapper = NULL, *rank;
gfc_iterator *iter;
- if (derived->attr.unlimited_polymorphic)
+ if (derived->attr.unlimited_polymorphic || derived->error)
{
vtab_final->initializer = gfc_get_null_expr (NULL);
return;
diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index 119c9dffa033..2647d5f5ea61 100644
--- a/gcc/fortran/decl.cc
+++ b/gcc/fortran/decl.cc
@@ -2420,11 +2420,24 @@ build_struct (const char *name, gfc_charlen *cl,
gfc_expr **init,
}
else if (c->attr.allocatable)
{
+ const char *err = G_("Allocatable component of structure at %C must have
"
+ "a deferred shape");
if (c->as->type != AS_DEFERRED)
{
- gfc_error ("Allocatable component of structure at %C must have a "
-"deferred shape");
- return false;
+ if (c->ts.type == BT_CLASS || c->ts.type == BT_DERIVED)
+ {
+ /* Issue an immediate error and allow this component to pass for
+the sake of clean error recovery. Set the error flag for the
+containing derived type so that finalizers are not built. */
+ gfc_error_now (err);
+ s->sym->error = 1;
+ c->as->type = AS_DEFERRED;
+ }
+ else
+ {
+ gfc_error (err);
+ return false;
+ }
}
}
else
diff --git a/gcc/testsuite/gfortran.dg/pr108434.f90
b/gcc/testsuite/gfortran.dg/pr108434.f90
index e1768a575744..b7f435338051 100644
--- a/gcc/testsuite/gfortran.dg/pr108434.f90
+++ b/gcc/testsuite/gfortran.dg/pr108434.f90
@@ -1,11 +1,19 @@
! { dg-do compile }
! PR fortran/108434 - ICE in class_allocatable
-! Contributed by G.Steinmetz
+! Contributed by G.Steinmetz
program p
type t
class(c), pointer :: a(2) ! { dg-error "must have a deferred shape" }
end type t
+ type s
+ class(d), allocatable :: a(2) ! { dg-error "must have a deferred
shape|not been declared" }
+ end type
+ type u
+ type(e), allocatable :: b(2) ! { dg-error "must have a deferred
shape|not been declared" }
+ end type
class(t), allocatable :: x
class(t), pointer :: y
+ class(s), allocatable :: x2
+ class(s), pointer :: y2
end
[gcc r15-6121] Fortran: Add DECL_EXPR for variable length assoc name [PR117901]
https://gcc.gnu.org/g:bbb7c53d32ece75ec0c336663ec37df9e63652d3
commit r15-6121-gbbb7c53d32ece75ec0c336663ec37df9e63652d3
Author: Paul Thomas
Date: Wed Dec 11 16:14:05 2024 +
Fortran: Add DECL_EXPR for variable length assoc name [PR117901]
2024-12-11 Paul Thomas
gcc/fortran
PR fortran/117901
* trans-stmt.cc (trans_associate_var): A variable character
length array associate name must generate a DECL expression for
the data pointer type.
gcc/testsuite/
PR fortran/117901
* gfortran.dg/pr117901.f90: New test.
Diff:
---
gcc/fortran/trans-stmt.cc | 14 ++
gcc/testsuite/gfortran.dg/pr117901.f90 | 30 ++
2 files changed, 44 insertions(+)
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index 80a9502a8a41..ae3266fb867f 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -2065,6 +2065,20 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block
*block)
|| GFC_ARRAY_TYPE_P (TREE_TYPE (se.expr)));
gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym->backend_decl)));
+ if (sym->ts.type == BT_CHARACTER)
+ {
+ /* Emit a DECL_EXPR for the variable sized array type in so the
+gimplification of its type sizes works correctly. */
+ tree arraytype;
+ tmp = TREE_TYPE (sym->backend_decl);
+ arraytype = TREE_TYPE (GFC_TYPE_ARRAY_DATAPTR_TYPE (tmp));
+ if (! TYPE_NAME (arraytype))
+ TYPE_NAME (arraytype) = build_decl (UNKNOWN_LOCATION, TYPE_DECL,
+ NULL_TREE, arraytype);
+ gfc_add_expr_to_block (&se.pre, build1 (DECL_EXPR,
+arraytype, TYPE_NAME (arraytype)));
+ }
+
if (GFC_ARRAY_TYPE_P (TREE_TYPE (se.expr)))
{
if (INDIRECT_REF_P (se.expr))
diff --git a/gcc/testsuite/gfortran.dg/pr117901.f90
b/gcc/testsuite/gfortran.dg/pr117901.f90
new file mode 100644
index ..b5c3a4fc2779
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr117901.f90
@@ -0,0 +1,30 @@
+! { dg-do compile }
+! { dg-options "-O3" }
+!
+! Test the fix for pr117901, in which the variable length character in
+! the SELECT TYPE construct caused an ICE in make_ssa_name_fn. This is
+! a much reduced testcase, extracted from class_transformational_1.f90.
+! Note that it does not have references to transformational functions
+! of class objects!
+!
+Module class_tests
+contains
+ subroutine class_rebar (arg)
+class(*), allocatable :: arg(:)
+call class_bar (arg)
+ end
+ subroutine class_bar(x)
+class(*), intent(in) :: x(..)
+integer :: checksum
+select rank (x)
+ rank (1)
+select type (x)
+ type is (character(*))
+checksum = sum(ichar(x(:)(1:1)) + ichar(x(:)(2:2)))
+print *, checksum
+end select
+ rank (2)
+ rank (3)
+ end select
+ end
+end module class_tests
