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

[Harald Anlauf <anlauf@gmx.de>]

[-- 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