[PATCH] Fortran: fix CLASS attribute handling [PR106856]

[PATCH] Fortran: fix CLASS attribute handling [PR106856]

[Harald Anlauf]

[-- Attachment #1: Type: text/plain, Size: 680 bytes --]

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


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: pr106856.diff --]
[-- Type: text/x-patch, Size: 10132 bytes --]

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

Re: [PATCH] Fortran: fix CLASS attribute handling [PR106856]

[Steve Kargl]

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.

-- 
Steve

Re: [PATCH] Fortran: fix CLASS attribute handling [PR106856]

[Harald Anlauf]

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

Re: [PATCH] Fortran: fix CLASS attribute handling [PR106856]

[Harald Anlauf]

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

Re: [PATCH] Fortran: fix CLASS attribute handling [PR106856]

[Mikael Morin]

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.

Re: [PATCH] Fortran: fix CLASS attribute handling [PR106856]

[Steve Kargl]

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.

-- 
steve

Re: [PATCH] Fortran: fix CLASS attribute handling [PR106856]

[Mikael Morin]

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;

Re: [PATCH, v2] Fortran: fix CLASS attribute handling [PR106856]

[Harald Anlauf]

[-- Attachment #1: Type: text/plain, Size: 2251 bytes --]

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

[-- Attachment #2: pr107074-v2.diff --]
[-- Type: text/x-patch, Size: 4117 bytes --]

From 70cba7da18023282546b9a5d80e976fc3744d732 Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anlauf@gmx.de>
Date: Wed, 5 Oct 2022 22:25:14 +0200
Subject: [PATCH] Fortran: reject procedures and procedure pointers as IO
 element [PR107074]

gcc/fortran/ChangeLog:

	PR fortran/107074
	* resolve.cc (resolve_transfer): A procedure, type-bound procedure
	or a procedure pointer cannot be an element of an IO list.
	* simplify.cc (gfc_simplify_merge): Do not try to reset array lower
	bound for scalars.

gcc/testsuite/ChangeLog:

	PR fortran/107074
	* gfortran.dg/pr107074.f90: New test.
	* gfortran.dg/pr107074b.f90: New test.
---
 gcc/fortran/resolve.cc                  | 31 +++++++++++++++++++++++++
 gcc/fortran/simplify.cc                 |  3 ++-
 gcc/testsuite/gfortran.dg/pr107074.f90  | 11 +++++++++
 gcc/testsuite/gfortran.dg/pr107074b.f90 | 18 ++++++++++++++
 4 files changed, 62 insertions(+), 1 deletion(-)
 create mode 100644 gcc/testsuite/gfortran.dg/pr107074.f90
 create mode 100644 gcc/testsuite/gfortran.dg/pr107074b.f90

diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index d133bc2d034..d9d101775f6 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -10137,6 +10137,37 @@ resolve_transfer (gfc_code *code)
 		 "an assumed-size array", &code->loc);
       return;
     }
+
+  /* Check for procedures and procedure pointers.  Fortran 2018 has:
+
+     C1233 (R1217) An expression that is an output-item shall not have a
+     value that is a procedure pointer.
+
+     There does not appear any reason to allow procedure pointers for
+     input, so we disallow them generally, and we reject procedures.  */
+
+  if (exp->expr_type == EXPR_VARIABLE)
+    {
+      /* Check for type-bound procedures.  */
+      for (ref = exp->ref; ref; ref = ref->next)
+	if (ref->type == REF_COMPONENT
+	    && ref->u.c.component->attr.flavor == FL_PROCEDURE)
+	  break;
+
+      /* Procedure or procedure pointer?  */
+      if (exp->ts.type == BT_PROCEDURE
+	  || (ref && ref->u.c.component->attr.flavor == FL_PROCEDURE))
+	{
+	  if (exp->symtree->n.sym->attr.proc_pointer
+	      || (ref && ref->u.c.component->attr.proc_pointer))
+	    gfc_error ("Data transfer element at %L cannot be a procedure "
+		       "pointer", &code->loc);
+	  else
+	    gfc_error ("Data transfer element at %L cannot be a procedure",
+		       &code->loc);
+	  return;
+	}
+    }
 }
 
 
diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc
index 6ac92cf9db8..f0482d349af 100644
--- a/gcc/fortran/simplify.cc
+++ b/gcc/fortran/simplify.cc
@@ -4915,7 +4915,8 @@ gfc_simplify_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
     {
       result = gfc_copy_expr (mask->value.logical ? tsource : fsource);
       /* Parenthesis is needed to get lower bounds of 1.  */
-      result = gfc_get_parentheses (result);
+      if (result->rank)
+	result = gfc_get_parentheses (result);
       gfc_simplify_expr (result, 1);
       return result;
     }
diff --git a/gcc/testsuite/gfortran.dg/pr107074.f90 b/gcc/testsuite/gfortran.dg/pr107074.f90
new file mode 100644
index 00000000000..1363c285912
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr107074.f90
@@ -0,0 +1,11 @@
+! { dg-do compile }
+! PR fortran/107074 - ICE: Bad IO basetype (8)
+! Contributed by G.Steinmetz
+
+program p
+  implicit none
+  integer, external        :: a
+  procedure(real), pointer :: b
+  print *, merge (a, a, .true.) ! { dg-error "procedure" }
+  print *, merge (b, b, .true.) ! { dg-error "procedure pointer" }
+end
diff --git a/gcc/testsuite/gfortran.dg/pr107074b.f90 b/gcc/testsuite/gfortran.dg/pr107074b.f90
new file mode 100644
index 00000000000..98c3fc0b90a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr107074b.f90
@@ -0,0 +1,18 @@
+! { dg-do compile }
+! Additional test for PR fortran/107074
+! Contributed by M.Morin
+
+program p
+  implicit none
+  type :: t
+    procedure(f), pointer, nopass :: b
+  end type t
+  type(t) :: a
+
+  interface
+    real function f()
+    end function f
+  end interface
+
+  print *, merge (a%b, a%b, .true.) ! { dg-error "procedure pointer" }
+end
-- 
2.35.3

Re: [PATCH, v2] Fortran: fix CLASS attribute handling [PR106856]

[Harald Anlauf]

[-- Attachment #1: Type: text/plain, Size: 2305 bytes --]

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

[-- Attachment #2: pr107074-v2.diff --]
[-- Type: text/x-patch, Size: 4117 bytes --]

From 70cba7da18023282546b9a5d80e976fc3744d732 Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anlauf@gmx.de>
Date: Wed, 5 Oct 2022 22:25:14 +0200
Subject: [PATCH] Fortran: reject procedures and procedure pointers as IO
 element [PR107074]

gcc/fortran/ChangeLog:

	PR fortran/107074
	* resolve.cc (resolve_transfer): A procedure, type-bound procedure
	or a procedure pointer cannot be an element of an IO list.
	* simplify.cc (gfc_simplify_merge): Do not try to reset array lower
	bound for scalars.

gcc/testsuite/ChangeLog:

	PR fortran/107074
	* gfortran.dg/pr107074.f90: New test.
	* gfortran.dg/pr107074b.f90: New test.
---
 gcc/fortran/resolve.cc                  | 31 +++++++++++++++++++++++++
 gcc/fortran/simplify.cc                 |  3 ++-
 gcc/testsuite/gfortran.dg/pr107074.f90  | 11 +++++++++
 gcc/testsuite/gfortran.dg/pr107074b.f90 | 18 ++++++++++++++
 4 files changed, 62 insertions(+), 1 deletion(-)
 create mode 100644 gcc/testsuite/gfortran.dg/pr107074.f90
 create mode 100644 gcc/testsuite/gfortran.dg/pr107074b.f90

diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index d133bc2d034..d9d101775f6 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -10137,6 +10137,37 @@ resolve_transfer (gfc_code *code)
 		 "an assumed-size array", &code->loc);
       return;
     }
+
+  /* Check for procedures and procedure pointers.  Fortran 2018 has:
+
+     C1233 (R1217) An expression that is an output-item shall not have a
+     value that is a procedure pointer.
+
+     There does not appear any reason to allow procedure pointers for
+     input, so we disallow them generally, and we reject procedures.  */
+
+  if (exp->expr_type == EXPR_VARIABLE)
+    {
+      /* Check for type-bound procedures.  */
+      for (ref = exp->ref; ref; ref = ref->next)
+	if (ref->type == REF_COMPONENT
+	    && ref->u.c.component->attr.flavor == FL_PROCEDURE)
+	  break;
+
+      /* Procedure or procedure pointer?  */
+      if (exp->ts.type == BT_PROCEDURE
+	  || (ref && ref->u.c.component->attr.flavor == FL_PROCEDURE))
+	{
+	  if (exp->symtree->n.sym->attr.proc_pointer
+	      || (ref && ref->u.c.component->attr.proc_pointer))
+	    gfc_error ("Data transfer element at %L cannot be a procedure "
+		       "pointer", &code->loc);
+	  else
+	    gfc_error ("Data transfer element at %L cannot be a procedure",
+		       &code->loc);
+	  return;
+	}
+    }
 }
 
 
diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc
index 6ac92cf9db8..f0482d349af 100644
--- a/gcc/fortran/simplify.cc
+++ b/gcc/fortran/simplify.cc
@@ -4915,7 +4915,8 @@ gfc_simplify_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
     {
       result = gfc_copy_expr (mask->value.logical ? tsource : fsource);
       /* Parenthesis is needed to get lower bounds of 1.  */
-      result = gfc_get_parentheses (result);
+      if (result->rank)
+	result = gfc_get_parentheses (result);
       gfc_simplify_expr (result, 1);
       return result;
     }
diff --git a/gcc/testsuite/gfortran.dg/pr107074.f90 b/gcc/testsuite/gfortran.dg/pr107074.f90
new file mode 100644
index 00000000000..1363c285912
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr107074.f90
@@ -0,0 +1,11 @@
+! { dg-do compile }
+! PR fortran/107074 - ICE: Bad IO basetype (8)
+! Contributed by G.Steinmetz
+
+program p
+  implicit none
+  integer, external        :: a
+  procedure(real), pointer :: b
+  print *, merge (a, a, .true.) ! { dg-error "procedure" }
+  print *, merge (b, b, .true.) ! { dg-error "procedure pointer" }
+end
diff --git a/gcc/testsuite/gfortran.dg/pr107074b.f90 b/gcc/testsuite/gfortran.dg/pr107074b.f90
new file mode 100644
index 00000000000..98c3fc0b90a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr107074b.f90
@@ -0,0 +1,18 @@
+! { dg-do compile }
+! Additional test for PR fortran/107074
+! Contributed by M.Morin
+
+program p
+  implicit none
+  type :: t
+    procedure(f), pointer, nopass :: b
+  end type t
+  type(t) :: a
+
+  interface
+    real function f()
+    end function f
+  end interface
+
+  print *, merge (a%b, a%b, .true.) ! { dg-error "procedure pointer" }
+end
-- 
2.35.3

Re: [PATCH, v2] Fortran: fix CLASS attribute handling [PR106856]

[Harald Anlauf]

[-- Attachment #1: Type: text/plain, Size: 2251 bytes --]

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

[-- Attachment #2: pr107074-v2.diff --]
[-- Type: text/x-patch, Size: 4117 bytes --]

From 70cba7da18023282546b9a5d80e976fc3744d732 Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anlauf@gmx.de>
Date: Wed, 5 Oct 2022 22:25:14 +0200
Subject: [PATCH] Fortran: reject procedures and procedure pointers as IO
 element [PR107074]

gcc/fortran/ChangeLog:

	PR fortran/107074
	* resolve.cc (resolve_transfer): A procedure, type-bound procedure
	or a procedure pointer cannot be an element of an IO list.
	* simplify.cc (gfc_simplify_merge): Do not try to reset array lower
	bound for scalars.

gcc/testsuite/ChangeLog:

	PR fortran/107074
	* gfortran.dg/pr107074.f90: New test.
	* gfortran.dg/pr107074b.f90: New test.
---
 gcc/fortran/resolve.cc                  | 31 +++++++++++++++++++++++++
 gcc/fortran/simplify.cc                 |  3 ++-
 gcc/testsuite/gfortran.dg/pr107074.f90  | 11 +++++++++
 gcc/testsuite/gfortran.dg/pr107074b.f90 | 18 ++++++++++++++
 4 files changed, 62 insertions(+), 1 deletion(-)
 create mode 100644 gcc/testsuite/gfortran.dg/pr107074.f90
 create mode 100644 gcc/testsuite/gfortran.dg/pr107074b.f90

diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index d133bc2d034..d9d101775f6 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -10137,6 +10137,37 @@ resolve_transfer (gfc_code *code)
 		 "an assumed-size array", &code->loc);
       return;
     }
+
+  /* Check for procedures and procedure pointers.  Fortran 2018 has:
+
+     C1233 (R1217) An expression that is an output-item shall not have a
+     value that is a procedure pointer.
+
+     There does not appear any reason to allow procedure pointers for
+     input, so we disallow them generally, and we reject procedures.  */
+
+  if (exp->expr_type == EXPR_VARIABLE)
+    {
+      /* Check for type-bound procedures.  */
+      for (ref = exp->ref; ref; ref = ref->next)
+	if (ref->type == REF_COMPONENT
+	    && ref->u.c.component->attr.flavor == FL_PROCEDURE)
+	  break;
+
+      /* Procedure or procedure pointer?  */
+      if (exp->ts.type == BT_PROCEDURE
+	  || (ref && ref->u.c.component->attr.flavor == FL_PROCEDURE))
+	{
+	  if (exp->symtree->n.sym->attr.proc_pointer
+	      || (ref && ref->u.c.component->attr.proc_pointer))
+	    gfc_error ("Data transfer element at %L cannot be a procedure "
+		       "pointer", &code->loc);
+	  else
+	    gfc_error ("Data transfer element at %L cannot be a procedure",
+		       &code->loc);
+	  return;
+	}
+    }
 }
 
 
diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc
index 6ac92cf9db8..f0482d349af 100644
--- a/gcc/fortran/simplify.cc
+++ b/gcc/fortran/simplify.cc
@@ -4915,7 +4915,8 @@ gfc_simplify_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
     {
       result = gfc_copy_expr (mask->value.logical ? tsource : fsource);
       /* Parenthesis is needed to get lower bounds of 1.  */
-      result = gfc_get_parentheses (result);
+      if (result->rank)
+	result = gfc_get_parentheses (result);
       gfc_simplify_expr (result, 1);
       return result;
     }
diff --git a/gcc/testsuite/gfortran.dg/pr107074.f90 b/gcc/testsuite/gfortran.dg/pr107074.f90
new file mode 100644
index 00000000000..1363c285912
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr107074.f90
@@ -0,0 +1,11 @@
+! { dg-do compile }
+! PR fortran/107074 - ICE: Bad IO basetype (8)
+! Contributed by G.Steinmetz
+
+program p
+  implicit none
+  integer, external        :: a
+  procedure(real), pointer :: b
+  print *, merge (a, a, .true.) ! { dg-error "procedure" }
+  print *, merge (b, b, .true.) ! { dg-error "procedure pointer" }
+end
diff --git a/gcc/testsuite/gfortran.dg/pr107074b.f90 b/gcc/testsuite/gfortran.dg/pr107074b.f90
new file mode 100644
index 00000000000..98c3fc0b90a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr107074b.f90
@@ -0,0 +1,18 @@
+! { dg-do compile }
+! Additional test for PR fortran/107074
+! Contributed by M.Morin
+
+program p
+  implicit none
+  type :: t
+    procedure(f), pointer, nopass :: b
+  end type t
+  type(t) :: a
+
+  interface
+    real function f()
+    end function f
+  end interface
+
+  print *, merge (a%b, a%b, .true.) ! { dg-error "procedure pointer" }
+end
-- 
2.35.3

Re: [PATCH, v2] Fortran: fix CLASS attribute handling [PR106856]

[Harald Anlauf]

[-- Attachment #1: Type: text/plain, Size: 475 bytes --]

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

[-- Attachment #2: pr106856-v2.diff --]
[-- Type: text/x-patch, Size: 11992 bytes --]

From 0b7e9ea9c83ca6d6c0aae638be09fbcb8e42c682 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.

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                        |  60 +++++-----
 gcc/fortran/primary.cc                     |   1 -
 gcc/testsuite/gfortran.dg/class_74.f90     | 130 +++++++++++++++++++++
 gcc/testsuite/gfortran.dg/class_75.f90     |  24 ++++
 gcc/testsuite/gfortran.dg/interface_41.f90 |   2 +-
 6 files changed, 207 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..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, &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 eec0314cf4c..a65c6dcb994 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 (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,28 @@ 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;
+    }
+  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..a22a3d9f739
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_74.f90
@@ -0,0 +1,130 @@
+! { 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
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

Re: [PATCH, v2] Fortran: fix CLASS attribute handling [PR106856]

[Harald Anlauf]

[-- Attachment #1: Type: text/plain, Size: 459 bytes --]

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

[-- Attachment #2: pr106856-v2.diff --]
[-- Type: text/x-patch, Size: 11992 bytes --]

From 0b7e9ea9c83ca6d6c0aae638be09fbcb8e42c682 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.

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                        |  60 +++++-----
 gcc/fortran/primary.cc                     |   1 -
 gcc/testsuite/gfortran.dg/class_74.f90     | 130 +++++++++++++++++++++
 gcc/testsuite/gfortran.dg/class_75.f90     |  24 ++++
 gcc/testsuite/gfortran.dg/interface_41.f90 |   2 +-
 6 files changed, 207 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..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, &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 eec0314cf4c..a65c6dcb994 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 (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,28 @@ 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;
+    }
+  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..a22a3d9f739
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_74.f90
@@ -0,0 +1,130 @@
+! { 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
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

Re: [PATCH, v2] Fortran: fix CLASS attribute handling [PR106856]

[Mikael Morin]

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

Re: [PATCH, v2] Fortran: fix CLASS attribute handling [PR106856]

[Harald Anlauf]

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

Re: [PATCH, v2] Fortran: fix CLASS attribute handling [PR106856]

[Harald Anlauf]

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

Re: [PATCH, v2] Fortran: fix CLASS attribute handling [PR106856]

[Mikael Morin]

[-- Attachment #1: Type: text/plain, Size: 1507 bytes --]

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.

[-- Attachment #2: old_symbol_as.diff --]
[-- Type: text/x-patch, Size: 1060 bytes --]

diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index a65c6dcb994..c8f0bb83c2c 100644
--- a/gcc/fortran/decl.cc
+++ b/gcc/fortran/decl.cc
@@ -8802,10 +8802,6 @@ attr_decl1 (void)
       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);
 
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)

[PATCH, v3] Fortran: fix CLASS attribute handling [PR106856]

[Harald Anlauf]

[-- Attachment #1: Type: text/plain, Size: 1933 bytes --]

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

[-- Attachment #2: pr106856-v3.diff --]
[-- Type: text/x-patch, Size: 12994 bytes --]

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

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, &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 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, &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 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

[PATCH, v3] Fortran: fix CLASS attribute handling [PR106856]

[Harald Anlauf]

[-- Attachment #1: Type: text/plain, Size: 1992 bytes --]

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

[-- Attachment #2: pr106856-v3.diff --]
[-- Type: text/x-patch, Size: 12994 bytes --]

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

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, &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 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, &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 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