Hi Mikael,
Am 04.03.23 um 23:29 schrieb Mikael Morin:
Le 04/03/2023 à 22:20, Harald Anlauf a écrit :
Hi Mikael,
Am 04.03.23 um 18:09 schrieb Mikael Morin:
There was a comment about the old_symbol thing at the end of my previous
message:
https://gcc.gnu.org/pipermail/gcc-patches/2023-March/613354.html
I think Tobias might be the better person to answer this.
But when playing with variations of that else-branch,
I always hit an issue with class_74.f90, where the class
variables are not dummy arguments but local variables.
E.g. take the following reduced testcase:
subroutine foo
class(*) :: y
dimension :: y(:,:)
pointer :: y
end subroutine foo
So when we see the dimension but haven't seen the
pointer (or allocatable) declaration, we appear to
generate an error with bad consequences (ICE).
If this is a resolution issue, maybe it can be fixed
differently, but likely needs digging deeper. With
the patch as-is at least I do not see a memory leak
in that context.
One of my suggestions was to fix it as attached.
It is probably more clear with an actual patch to look at.
It seems to work on your example and class_74 as well.
This fix is great. I've included it in the revised patch.
It seems to also fix some valgrind errors on this example:
subroutine foo
pointer :: y
dimension :: y(:,:)
class(*) :: y
end subroutine foo
I'm fine with that fix if it works for you.
I've added this variant to class_74.f90, so it won't break
without noticing.
I suggest waiting for next stage 1, but it's your call, you have the
green light from Steve anyway.
I've chosen to push patch v3 (attached) after a further round of
regtesting as r13-6497-g6aa1f40a326374 .
Thanks for your work.
Many thanks for your very helpful review!
Harald
From 6aa1f40a3263741d964ef4716e85a0df5cec83b6 Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anl...@gmx.de>
Date: Thu, 2 Mar 2023 22:37:14 +0100
Subject: [PATCH] Fortran: fix CLASS attribute handling [PR106856]
gcc/fortran/ChangeLog:
PR fortran/106856
* class.cc (gfc_build_class_symbol): Handle update of attributes of
existing class container.
(gfc_find_derived_vtab): Fix several memory leaks.
(find_intrinsic_vtab): Ditto.
* decl.cc (attr_decl1): Manage update of symbol attributes from
CLASS attributes.
* primary.cc (gfc_variable_attr): OPTIONAL shall not be taken or
updated from the class container.
* symbol.cc (free_old_symbol): Adjust management of symbol versions
to not prematurely free array specs while working on the declation
of CLASS variables.
gcc/testsuite/ChangeLog:
PR fortran/106856
* gfortran.dg/interface_41.f90: Remove dg-pattern from valid testcase.
* gfortran.dg/class_74.f90: New test.
* gfortran.dg/class_75.f90: New test.
Co-authored-by: Tobias Burnus <tob...@codesourcery.com>
---
gcc/fortran/class.cc | 25 +++-
gcc/fortran/decl.cc | 56 ++++----
gcc/fortran/primary.cc | 1 -
gcc/fortran/symbol.cc | 6 +-
gcc/testsuite/gfortran.dg/class_74.f90 | 151 +++++++++++++++++++++
gcc/testsuite/gfortran.dg/class_75.f90 | 24 ++++
gcc/testsuite/gfortran.dg/interface_41.f90 | 2 +-
7 files changed, 229 insertions(+), 36 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/class_74.f90
create mode 100644 gcc/testsuite/gfortran.dg/class_75.f90
diff --git a/gcc/fortran/class.cc b/gcc/fortran/class.cc
index ae653e74437..52235ab83e3 100644
--- a/gcc/fortran/class.cc
+++ b/gcc/fortran/class.cc
@@ -638,6 +638,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
{
char tname[GFC_MAX_SYMBOL_LEN+1];
char *name;
+ gfc_typespec *orig_ts = ts;
gfc_symbol *fclass;
gfc_symbol *vtab;
gfc_component *c;
@@ -646,9 +647,21 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
gcc_assert (as);
- if (attr->class_ok)
- /* Class container has already been built. */
+ /* Class container has already been built with same name. */
+ if (attr->class_ok
+ && ts->u.derived->components->attr.dimension >= attr->dimension
+ && ts->u.derived->components->attr.codimension >= attr->codimension
+ && ts->u.derived->components->attr.class_pointer >= attr->pointer
+ && ts->u.derived->components->attr.allocatable >= attr->allocatable)
return true;
+ if (attr->class_ok)
+ {
+ attr->dimension |= ts->u.derived->components->attr.dimension;
+ attr->codimension |= ts->u.derived->components->attr.codimension;
+ attr->pointer |= ts->u.derived->components->attr.class_pointer;
+ attr->allocatable |= ts->u.derived->components->attr.allocatable;
+ ts = &ts->u.derived->components->ts;
+ }
attr->class_ok = attr->dummy || attr->pointer || attr->allocatable
|| attr->select_type_temporary || attr->associate_var;
@@ -790,7 +803,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
}
fclass->attr.is_class = 1;
- ts->u.derived = fclass;
+ orig_ts->u.derived = fclass;
attr->allocatable = attr->pointer = attr->dimension = attr->codimension = 0;
(*as) = NULL;
free (name);
@@ -2344,6 +2357,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
vtab->attr.vtab = 1;
vtab->attr.access = ACCESS_PUBLIC;
gfc_set_sym_referenced (vtab);
+ free (name);
name = xasprintf ("__vtype_%s", tname);
gfc_find_symbol (name, ns, 0, &vtype);
@@ -2447,6 +2461,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
else
{
/* Construct default initialization variable. */
+ free (name);
name = xasprintf ("__def_init_%s", tname);
gfc_get_symbol (name, ns, &def_init);
def_init->attr.target = 1;
@@ -2480,6 +2495,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
ns->contained = sub_ns;
sub_ns->resolved = 1;
/* Set up procedure symbol. */
+ free (name);
name = xasprintf ("__copy_%s", tname);
gfc_get_symbol (name, sub_ns, ©);
sub_ns->proc_name = copy;
@@ -2558,6 +2574,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
ns->contained = sub_ns;
sub_ns->resolved = 1;
/* Set up procedure symbol. */
+ free (name);
name = xasprintf ("__deallocate_%s", tname);
gfc_get_symbol (name, sub_ns, &dealloc);
sub_ns->proc_name = dealloc;
@@ -2723,6 +2740,7 @@ find_intrinsic_vtab (gfc_typespec *ts)
vtab->attr.vtab = 1;
vtab->attr.access = ACCESS_PUBLIC;
gfc_set_sym_referenced (vtab);
+ free (name);
name = xasprintf ("__vtype_%s", tname);
gfc_find_symbol (name, ns, 0, &vtype);
@@ -2801,6 +2819,7 @@ find_intrinsic_vtab (gfc_typespec *ts)
c->tb = XCNEW (gfc_typebound_proc);
c->tb->ppc = 1;
+ free (name);
if (ts->type != BT_CHARACTER)
name = xasprintf ("__copy_%s", tname);
else
diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index eec0314cf4c..c8f0bb83c2c 100644
--- a/gcc/fortran/decl.cc
+++ b/gcc/fortran/decl.cc
@@ -8740,45 +8740,23 @@ attr_decl1 (void)
}
}
- /* Update symbol table. DIMENSION attribute is set in
- gfc_set_array_spec(). For CLASS variables, this must be applied
- to the first component, or '_data' field. */
if (sym->ts.type == BT_CLASS
&& sym->ts.u.derived
&& sym->ts.u.derived->attr.is_class)
{
- /* gfc_set_array_spec sets sym->attr not CLASS_DATA(sym)->attr. Check
- for duplicate attribute here. */
- if (CLASS_DATA(sym)->attr.dimension == 1 && as)
- {
- gfc_error ("Duplicate DIMENSION attribute at %C");
- m = MATCH_ERROR;
- goto cleanup;
- }
-
- if (!gfc_copy_attr (&CLASS_DATA(sym)->attr, ¤t_attr, &var_locus))
- {
- m = MATCH_ERROR;
- goto cleanup;
- }
+ sym->attr.pointer = CLASS_DATA(sym)->attr.class_pointer;
+ sym->attr.allocatable = CLASS_DATA(sym)->attr.allocatable;
+ sym->attr.dimension = CLASS_DATA(sym)->attr.dimension;
+ sym->attr.codimension = CLASS_DATA(sym)->attr.codimension;
+ if (CLASS_DATA (sym)->as)
+ sym->as = gfc_copy_array_spec (CLASS_DATA (sym)->as);
}
- else
- {
- if (current_attr.dimension == 0 && current_attr.codimension == 0
- && !gfc_copy_attr (&sym->attr, ¤t_attr, &var_locus))
- {
- m = MATCH_ERROR;
- goto cleanup;
- }
- }
-
- if (sym->ts.type == BT_CLASS
- && !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as))
+ if (current_attr.dimension == 0 && current_attr.codimension == 0
+ && !gfc_copy_attr (&sym->attr, ¤t_attr, &var_locus))
{
m = MATCH_ERROR;
goto cleanup;
}
-
if (!gfc_set_array_spec (sym, as, &var_locus))
{
m = MATCH_ERROR;
@@ -8807,6 +8785,24 @@ attr_decl1 (void)
goto cleanup;
}
+ if (sym->ts.type == BT_CLASS && sym->ts.u.derived->attr.is_class
+ && !as && !current_attr.pointer && !current_attr.allocatable
+ && !current_attr.external)
+ {
+ sym->attr.pointer = 0;
+ sym->attr.allocatable = 0;
+ sym->attr.dimension = 0;
+ sym->attr.codimension = 0;
+ gfc_free_array_spec (sym->as);
+ sym->as = NULL;
+ }
+ else if (sym->ts.type == BT_CLASS
+ && !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as))
+ {
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+
add_hidden_procptr_result (sym);
return MATCH_YES;
diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index 1bea17d44fe..00d35a71770 100644
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
@@ -2640,7 +2640,6 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
codimension = CLASS_DATA (sym)->attr.codimension;
pointer = CLASS_DATA (sym)->attr.class_pointer;
allocatable = CLASS_DATA (sym)->attr.allocatable;
- optional |= CLASS_DATA (sym)->attr.optional;
}
else
{
diff --git a/gcc/fortran/symbol.cc b/gcc/fortran/symbol.cc
index 2ce0f3e4df7..221165d6dac 100644
--- a/gcc/fortran/symbol.cc
+++ b/gcc/fortran/symbol.cc
@@ -3761,7 +3761,11 @@ free_old_symbol (gfc_symbol *sym)
if (sym->old_symbol == NULL)
return;
- if (sym->old_symbol->as != sym->as)
+ if (sym->old_symbol->as != NULL
+ && sym->old_symbol->as != sym->as
+ && !(sym->ts.type == BT_CLASS
+ && sym->ts.u.derived->attr.is_class
+ && sym->old_symbol->as == CLASS_DATA (sym)->as))
gfc_free_array_spec (sym->old_symbol->as);
if (sym->old_symbol->value != sym->value)
diff --git a/gcc/testsuite/gfortran.dg/class_74.f90 b/gcc/testsuite/gfortran.dg/class_74.f90
new file mode 100644
index 00000000000..2394ed918fc
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_74.f90
@@ -0,0 +1,151 @@
+! { dg-do compile }
+! { dg-additional-options "-fcoarray=single" }
+!
+! PR fortran/106856
+!
+! Contributed by G. Steinmetz
+!
+subroutine foo
+ interface
+ subroutine bar(x)
+ type(*) :: x
+ end subroutine bar
+ end interface
+ class(*) :: x, y
+ allocatable :: x
+ dimension :: x(:), y(:,:)
+ codimension :: x[:]
+ pointer :: y
+ y => null()
+ if (allocated(x)) then
+ call bar(x(2)[1])
+ end if
+ if (associated(y)) then
+ call bar(y(2,2))
+ end if
+end subroutine foo
+
+
+program p
+ class(*), allocatable :: x, y
+ y = 'abc'
+ call s1(x, y)
+contains
+ subroutine s1(x, y)
+ class(*) :: x, y
+ end
+ subroutine s2(x, y)
+ class(*), allocatable :: x, y
+ optional :: x
+ end
+end
+
+
+subroutine s1 (x)
+ class(*) :: x
+ allocatable :: x
+ dimension :: x(:)
+ if (allocated (x)) print *, size (x)
+end
+
+subroutine s2 (x)
+ class(*) :: x
+ allocatable :: x(:)
+ if (allocated (x)) print *, size (x)
+end
+
+subroutine s3 (x)
+ class(*) :: x(:)
+ allocatable :: x
+ if (allocated (x)) print *, size (x)
+end
+
+subroutine s4 (x)
+ class(*) :: x
+ dimension :: x(:)
+ allocatable :: x
+ if (allocated (x)) print *, size (x)
+end
+
+
+subroutine c0 (x)
+ class(*) :: x
+ allocatable :: x
+ codimension :: x[:]
+ dimension :: x(:)
+ if (allocated (x)) print *, size (x)
+end
+
+subroutine c1 (x)
+ class(*) :: x(:)
+ allocatable :: x[:]
+ if (allocated (x)) print *, size (x)
+end
+
+subroutine c2 (x)
+ class(*) :: x[:]
+ allocatable :: x(:)
+ if (allocated (x)) print *, size (x)
+end
+
+subroutine c3 (x)
+ class(*) :: x(:)[:]
+ allocatable :: x
+ if (allocated (x)) print *, size (x)
+end
+
+subroutine c4 (x)
+ class(*) :: x
+ dimension :: x(:)
+ codimension :: x[:]
+ allocatable :: x
+ if (allocated (x)) print *, size (x)
+end
+
+
+subroutine p1 (x)
+ class(*) :: x
+ pointer :: x
+ dimension :: x(:)
+ if (associated (x)) print *, size (x)
+end
+
+subroutine p2 (x)
+ class(*) :: x
+ pointer :: x(:)
+ if (associated (x)) print *, size (x)
+end
+
+subroutine p3 (x)
+ class(*) :: x(:)
+ pointer :: x
+ if (associated (x)) print *, size (x)
+end
+
+subroutine p4 (x)
+ class(*) :: x
+ dimension :: x(:)
+ pointer :: x
+ if (associated (x)) print *, size (x)
+end
+
+
+! Testcase by Mikael Morin
+subroutine mm ()
+ pointer :: y
+ dimension :: y(:,:)
+ class(*) :: y
+ if (associated (y)) print *, size (y)
+end
+
+! Testcase from pr53951
+subroutine pr53951 ()
+ type t
+ end type t
+ class(t), pointer :: C
+ TARGET :: A
+ class(t), allocatable :: A, B
+ TARGET :: B
+ C => A ! Valid
+ C => B ! Valid, but was rejected
+end
diff --git a/gcc/testsuite/gfortran.dg/class_75.f90 b/gcc/testsuite/gfortran.dg/class_75.f90
new file mode 100644
index 00000000000..eb29ad51c85
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_75.f90
@@ -0,0 +1,24 @@
+! { dg-do compile }
+! { dg-additional-options "-fcoarray=single" }
+!
+! PR fortran/106856
+!
+!
+!
+subroutine foo(x,y)
+ class(*), optional :: x, y
+ optional :: x ! { dg-error "Duplicate OPTIONAL attribute" }
+ target :: x
+ allocatable :: x
+ target :: x ! { dg-error "Duplicate TARGET attribute" }
+ allocatable :: x ! { dg-error "Duplicate ALLOCATABLE attribute" }
+ pointer :: y
+ contiguous :: y
+ pointer :: y ! { dg-error "Duplicate POINTER attribute" }
+ contiguous :: y ! { dg-error "Duplicate CONTIGUOUS attribute" }
+ codimension :: x[:]
+ dimension :: x(:,:)
+ dimension :: y(:,:,:)
+ codimension :: x[:] ! { dg-error "Duplicate CODIMENSION attribute" }
+ dimension :: y(:) ! { dg-error "Duplicate DIMENSION attribute" }
+end
diff --git a/gcc/testsuite/gfortran.dg/interface_41.f90 b/gcc/testsuite/gfortran.dg/interface_41.f90
index b5ea8af189d..2fec01e3cf9 100644
--- a/gcc/testsuite/gfortran.dg/interface_41.f90
+++ b/gcc/testsuite/gfortran.dg/interface_41.f90
@@ -14,6 +14,6 @@ contains
subroutine s
type(t) :: x(2)
real :: z
- z = f(x) ! { dg-error "Rank mismatch in argument" }
+ z = f(x)
end
end
--
2.35.3
