Fortran: fix CLASS attribute handling [PR106856]

Message ID trinity-b92172eb-3e6e-401c-82e2-f5e1b3cee6b2-1677794628453@3c-app-gmx-bs40
State New
Headers
Series Fortran: fix CLASS attribute handling [PR106856] |

Commit Message

Harald Anlauf March 2, 2023, 10:03 p.m. UTC
  Dear all,

the attached patch fixes a long-standing issue with CLASS attributes
when a declaration is scattered over multiple statements.

The major part ("draft") of the patch is by Tobias, which I took up
before it started to bit-rot too much, see PR.  It is mainly about
a proper updating and book-keeping of symbol attributes.

While debugging the draft patch, I fixed a few disturbing memleaks
in class.cc that showed up when looking at intermediate fallout.

This patch also addresses issues reported in a few other PRs:
pr53951, pr101101, pr104229, pr107380.  These are mostly
duplicates at some level.

Regtested on x86_64-pc-linux-gnu.  OK for mainline?

Thanks,
Harald
  

Comments

Li, Pan2 via Gcc-patches March 3, 2023, 7:57 p.m. UTC | #1
On Thu, Mar 02, 2023 at 11:03:48PM +0100, Harald Anlauf via Fortran wrote:
> -  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)

I suppose I'm a bit confused here.  dimension, codimension, 
pointer and allocatable are 1-bit bitfields in the attr
struct.  These can have the values 0 and 1, so the above
conditionals are always true.

The rest of the patch looks reasonable.  If Tobias has no 
objections or comments, it's ok to commit once the above
is explained.
  
Harald Anlauf March 3, 2023, 9:17 p.m. UTC | #2
Hi Steve,

Am 03.03.23 um 20:57 schrieb Steve Kargl via Gcc-patches:
> On Thu, Mar 02, 2023 at 11:03:48PM +0100, Harald Anlauf via Fortran wrote:
>> -  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)
> 
> I suppose I'm a bit confused here.  dimension, codimension,
> pointer and allocatable are 1-bit bitfields in the attr
> struct.  These can have the values 0 and 1, so the above
> conditionals are always true.

thanks for looking into it.

The above part is from the original draft.  I thought I could
generate testcases that allow to exercise this part, and found
a new case that is not covered by the patch and still ICEs:

subroutine bar (x)
   class(*)    :: x
   dimension   :: x(:)
   allocatable :: x
end

:-(

We'll need to revisit the logic...

> The rest of the patch looks reasonable.  If Tobias has no
> objections or comments, it's ok to commit once the above
> is explained.
> 

Thanks,
Harald
  
Mikael Morin March 3, 2023, 9:24 p.m. UTC | #3
Hello,

Le 03/03/2023 à 20:57, Steve Kargl via Fortran a écrit :
> On Thu, Mar 02, 2023 at 11:03:48PM +0100, Harald Anlauf via Fortran wrote:
>> -  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)
> 
> I suppose I'm a bit confused here.  dimension, codimension,
> pointer and allocatable are 1-bit bitfields in the attr
> struct.  These can have the values 0 and 1, so the above
> conditionals are always true.
> 
as I understand it, they aren't if attr has attributes that aren't 
already set in the class container's first component.
a >= b == !(a < b) and if a and b are boolean-valued, a < b == !a && b.
Admittedly, I haven't tested the logic like Harald has.

> The rest of the patch looks reasonable.  If Tobias has no
> objections or comments, it's ok to commit once the above
> is explained.
> 

I have two comments, one about the handling of as and sym->as, which I 
quite don't understand, but I haven't had time to write something about it.
The other is about this:
> +  else if (sym->ts.type == BT_CLASS
> +	   && sym->ts.u.derived->attr.is_class
> +	   && sym->old_symbol && sym->old_symbol->as == CLASS_DATA (sym)->as)
> +    sym->old_symbol->as = NULL;
Can this be avoided?  The management of symbol versions should not need 
any manual change.  In principle, either the modified symbols are 
committed, or (in case of error) the previous symbols are restored, but 
there shouldn't be any need for restoring a modified previous symbol.

I guess it's a matter of memory management, because 
gfc_build_class_symbol copies the AS pointer to the class descriptor, 
but I think using gfc_copy_array_spec there or adding the condition 
above to free_old_symbol would be preferable.
  
Li, Pan2 via Gcc-patches March 3, 2023, 10:18 p.m. UTC | #4
On Fri, Mar 03, 2023 at 10:24:07PM +0100, Mikael Morin wrote:
> Hello,
> 
> Le 03/03/2023 à 20:57, Steve Kargl via Fortran a écrit :
> > On Thu, Mar 02, 2023 at 11:03:48PM +0100, Harald Anlauf via Fortran wrote:
> > > -  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)
> > 
> > I suppose I'm a bit confused here.  dimension, codimension,
> > pointer and allocatable are 1-bit bitfields in the attr
> > struct.  These can have the values 0 and 1, so the above
> > conditionals are always true.
> > 
> as I understand it, they aren't if attr has attributes that aren't already
> set in the class container's first component.
> a >= b == !(a < b) and if a and b are boolean-valued, a < b == !a && b.
> Admittedly, I haven't tested the logic like Harald has.
> 

Mikael, thanks for smacking me with the clue stick.  I had to do a quick
test to see the trees.

% cc -o z a.c && ./z
a.i = 0,  b.i = 0, a.i >= b.i = 1
a.i = 1,  b.i = 0, a.i >= b.i = 1
a.i = 1,  b.i = 1, a.i >= b.i = 1
a.i = 0,  b.i = 1, a.i >= b.i = 0

I was overlooking the last case.  So, the above is an all
or nothing test.
  
Mikael Morin March 4, 2023, 1:56 p.m. UTC | #5
Le 03/03/2023 à 22:24, Mikael Morin a écrit :
> 
> I have two comments, one about the handling of as and sym->as, which I 
> quite don't understand, but I haven't had time to write something about it.
I have found the time finally.  It's not as bad as it seemed.  See below.

> diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
> index eec0314cf4c..72d8c6f1c14 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, &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 (as && CLASS_DATA (sym)->as)
> +	sym->as = gfc_copy_array_spec (CLASS_DATA (sym)->as);

Here the condition on 'CLASS_DATA(sym)->as' makes obviously sense, but I 
don't see why there is also a condition on 'as'.

For example, if the array spec has been previously set on the class 
container's first component, and there is no array spec information in 
the current statement (i.e. as == NULL), sym->as will remain NULL, and a 
non-array class container will be built in gfc_build_class_symbol below.

>      }
> -  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,27 @@ 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 should probably be reset to NULL here.
Maybe both calls to gfc_free_array_spec here and to gfc_copy_array_spec 
above can be avoided by doing a simple pointer copy?

> +    }
> +  else if (sym->ts.type == BT_CLASS
> +      && !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as))
> +    {
> +      m = MATCH_ERROR;
> +      goto cleanup;
> +    }
> +  else if (sym->ts.type == BT_CLASS
> +	   && sym->ts.u.derived->attr.is_class
> +	   && sym->old_symbol && sym->old_symbol->as == CLASS_DATA (sym)->as)
> +    sym->old_symbol->as = NULL;
> +
>    add_hidden_procptr_result (sym);
> 
>    return MATCH_YES;
  
Harald Anlauf March 4, 2023, 4:02 p.m. UTC | #6
Hi Mikael!

Am 04.03.23 um 14:56 schrieb Mikael Morin:
> I have found the time finally.  It's not as bad as it seemed.  See below.
> 
>> diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
>> index eec0314cf4c..72d8c6f1c14 100644
>> --- a/gcc/fortran/decl.cc
>> +++ b/gcc/fortran/decl.cc

>> +      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 (as && CLASS_DATA (sym)->as)
>> +    sym->as = gfc_copy_array_spec (CLASS_DATA (sym)->as);
> 
> Here the condition on 'CLASS_DATA(sym)->as' makes obviously sense, but I 
> don't see why there is also a condition on 'as'.
> 
> For example, if the array spec has been previously set on the class 
> container's first component, and there is no array spec information in 
> the current statement (i.e. as == NULL), sym->as will remain NULL, and a 
> non-array class container will be built in gfc_build_class_symbol below.

Very good catch!  Indeed, this fixes the testcase variations.


>> @@ -8807,6 +8785,27 @@ 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 should probably be reset to NULL here.

Done.

> Maybe both calls to gfc_free_array_spec here and to gfc_copy_array_spec 
> above can be avoided by doing a simple pointer copy?

I tried that, but this produced a crash with a double-free.

The attached revised version uses the above proven changes,
and extends the new testcase class_74.f90 by variations of
the failures remaining with version 1 so that different
codepaths are tested.

Regtested again on x86_64-pc-linux-gnu.

Any further comments?

Thanks for your very helpful review!

Harald
  
Harald Anlauf March 4, 2023, 4:02 p.m. UTC | #7
Hi Mikael!

Am 04.03.23 um 14:56 schrieb Mikael Morin:
> I have found the time finally.  It's not as bad as it seemed.  See below.
>
>> diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
>> index eec0314cf4c..72d8c6f1c14 100644
>> --- a/gcc/fortran/decl.cc
>> +++ b/gcc/fortran/decl.cc

>> +      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 (as && CLASS_DATA (sym)->as)
>> +    sym->as = gfc_copy_array_spec (CLASS_DATA (sym)->as);
>
> Here the condition on 'CLASS_DATA(sym)->as' makes obviously sense, but I
> don't see why there is also a condition on 'as'.
>
> For example, if the array spec has been previously set on the class
> container's first component, and there is no array spec information in
> the current statement (i.e. as == NULL), sym->as will remain NULL, and a
> non-array class container will be built in gfc_build_class_symbol below.

Very good catch!  Indeed, this fixes the testcase variations.


>> @@ -8807,6 +8785,27 @@ 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 should probably be reset to NULL here.

Done.

> Maybe both calls to gfc_free_array_spec here and to gfc_copy_array_spec
> above can be avoided by doing a simple pointer copy?

I tried that, but this produced a crash with a double-free.

The attached revised version uses the above proven changes,
and extends the new testcase class_74.f90 by variations of
the failures remaining with version 1 so that different
codepaths are tested.

Regtested again on x86_64-pc-linux-gnu.

Any further comments?

Thanks for your very helpful review!

Harald
  
Harald Anlauf March 4, 2023, 4:06 p.m. UTC | #8
Sorry, attached the wrong patch.

Here's the correct one.

Harald

Am 04.03.23 um 17:02 schrieb Harald Anlauf via Gcc-patches:

> The attached revised version uses the above proven changes,
> and extends the new testcase class_74.f90 by variations of
> the failures remaining with version 1 so that different
> codepaths are tested.
>
> Regtested again on x86_64-pc-linux-gnu.
>
> Any further comments?
>
> Thanks for your very helpful review!
>
> Harald
  
Mikael Morin March 4, 2023, 5:09 p.m. UTC | #9
Le 04/03/2023 à 17:06, Harald Anlauf a écrit :
> Sorry, attached the wrong patch.
> 
> Here's the correct one.
> 
> Harald
> 
> Am 04.03.23 um 17:02 schrieb Harald Anlauf via Gcc-patches:
> 
>> The attached revised version uses the above proven changes,
>> and extends the new testcase class_74.f90 by variations of
>> the failures remaining with version 1 so that different
>> codepaths are tested.
>>
>> Regtested again on x86_64-pc-linux-gnu.
>>
>> Any further comments?
>>
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
  
Harald Anlauf March 4, 2023, 9:20 p.m. UTC | #10
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.

Cheers,
Harald
  
Mikael Morin March 4, 2023, 10:29 p.m. UTC | #11
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.
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 suggest waiting for next stage 1, but it's your call, you have the 
green light from Steve anyway.

Thanks for your work.
  

Patch

From 4600577e3ecceb2525618685f47c8a979cf9d244 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.
	* 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.

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                       | 23 +++++++--
 gcc/fortran/decl.cc                        | 59 +++++++++++-----------
 gcc/fortran/primary.cc                     |  1 -
 gcc/testsuite/gfortran.dg/class_74.f90     | 41 +++++++++++++++
 gcc/testsuite/gfortran.dg/class_75.f90     | 24 +++++++++
 gcc/testsuite/gfortran.dg/interface_41.f90 |  2 +-
 6 files changed, 115 insertions(+), 35 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..2eebdd4a3bb 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, &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;
diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index eec0314cf4c..72d8c6f1c14 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, &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 (as && 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,27 @@  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);
+    }
+  else if (sym->ts.type == BT_CLASS
+      && !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as))
+    {
+      m = MATCH_ERROR;
+      goto cleanup;
+    }
+  else if (sym->ts.type == BT_CLASS
+	   && sym->ts.u.derived->attr.is_class
+	   && sym->old_symbol && sym->old_symbol->as == CLASS_DATA (sym)->as)
+    sym->old_symbol->as = NULL;
+
   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/testsuite/gfortran.dg/class_74.f90 b/gcc/testsuite/gfortran.dg/class_74.f90
new file mode 100644
index 00000000000..cd169375356
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_74.f90
@@ -0,0 +1,41 @@ 
+! { 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
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