From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: by sourceware.org (Postfix, from userid 2071) id 9E2AF3858D1E; Sun, 5 Mar 2023 20:13:36 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 9E2AF3858D1E DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1678047216; bh=QC+5OhL/he1vJTc/zU3G+vnKXrZC4dIajWhdzl+njXs=; h=From:To:Subject:Date:From; b=ZfWE3IkYVBMAocC/DLKPek+8cvojqBsq8ATEfD9Pn50oNlU1I0UuQPEp8V827p1HA BG6I0eCy3iOwN8kIWukvWZN3mv2/k/EIyRDbAFol0V8kjJb6d9IKxdgPPQ7VXbdo3N AKzKb1Dwn3MRGryzVcLthNhB2coH7lBNGc3xMRfU= MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Content-Type: text/plain; charset="utf-8" From: Harald Anlauf To: gcc-cvs@gcc.gnu.org Subject: [gcc r13-6497] Fortran: fix CLASS attribute handling [PR106856] X-Act-Checkin: gcc X-Git-Author: Harald Anlauf X-Git-Refname: refs/heads/master X-Git-Oldrev: ca27d765f1d88a0f9d625b3519b6a8b1f8b19cc7 X-Git-Newrev: 6aa1f40a3263741d964ef4716e85a0df5cec83b6 Message-Id: <20230305201336.9E2AF3858D1E@sourceware.org> Date: Sun, 5 Mar 2023 20:13:36 +0000 (GMT) List-Id: https://gcc.gnu.org/g:6aa1f40a3263741d964ef4716e85a0df5cec83b6 commit r13-6497-g6aa1f40a3263741d964ef4716e85a0df5cec83b6 Author: Harald Anlauf Date: Thu Mar 2 22:37:14 2023 +0100 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 Diff: --- 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(-) 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