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>

diff --git a/gcc/fortran/class.cc b/gcc/fortran/class.cc
index ae653e74437cc04de5a240f3b210f2e075d0696f..52235ab83e3a5a4bd4c53d7ae85896e2ce70458d 100644 (file)
--- 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, &copy);
                  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 eec0314cf4c3f2d5487b9f48362a396fb89e0ab2..c8f0bb83c2c6103a9bdf81a021493389c1ac58b1 100644 (file)
--- 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, &current_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, &current_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, &current_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 1bea17d44fe603086382d3ce75a8843bb346b99e..00d35a717708582aa6fc4589ef4662ba53345f2a 100644 (file)
--- 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 2ce0f3e4df7e6b2f2b4292f3539068949158c928..221165d6daccd977c032c4575f4a76e7741702e4 100644 (file)
--- 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 (file)
index 0000000..2394ed9
--- /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 (file)
index 0000000..eb29ad5
--- /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 b5ea8af189d3ec178ad00dea0ee9ea6a6660b5d5..2fec01e3cf9a3e8899310036af8ad99b1985e516 100644 (file)
--- 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