From 6aa1f40a3263741d964ef4716e85a0df5cec83b6 Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anlauf@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 <tobias@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
@@ -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
@@ -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;
@@ -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
{
@@ -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)
new file mode 100644
@@ -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
new file mode 100644
@@ -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
@@ -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