[Patch] Fortran: Fix CLASS conversion check [PR102745]

[Patch] Fortran: Fix CLASS conversion check [PR102745]

[Tobias Burnus]

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

This patch fixes two issues:

First, to print 'CLASS(t2)' instead of:
Error: Type mismatch in argument ‘x’ at (1); passed CLASS(__class_MAIN___T2_a) to TYPE(t)

Additionally,

   class(t2) = class(t)  ! 't2' extends 't'
   class(t2) = class(any)

was wrongly accepted.

OK?

Tobias
-----------------
Siemens Electronic Design Automation GmbH; Anschrift: Arnulfstraße 201, 80634 München; Gesellschaft mit beschränkter Haftung; Geschäftsführer: Thomas Heurung, Frank Thürauf; Sitz der Gesellschaft: München; Registergericht München, HRB 106955

[-- Attachment #2: class-check.diff --]
[-- Type: text/x-patch, Size: 5201 bytes --]

Fortran: Fix CLASS conversion check [PR102745]

	PR fortran/102745
gcc/fortran/ChangeLog
	* intrinsic.c (gfc_convert_type_warn): Fix checks by checking CLASS
	and do typcheck in correct order for type extension.
	* misc.c (gfc_typename): Print proper not internal CLASS type name.

gcc/testsuite/ChangeLog
	* gfortran.dg/class_72.f90: New.

 gcc/fortran/intrinsic.c                |  7 +--
 gcc/fortran/misc.c                     | 10 ++--
 gcc/testsuite/gfortran.dg/class_72.f90 | 83 ++++++++++++++++++++++++++++++++++
 3 files changed, 92 insertions(+), 8 deletions(-)

diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index 219f04f2317..f5c88d98cc9 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -5237,12 +5237,13 @@ gfc_convert_type_warn (gfc_expr *expr, gfc_typespec *ts, int eflag, int wflag,
   /* In building an array constructor, gfortran can end up here when no
      conversion is required for an intrinsic type.  We need to let derived
      types drop through.  */
-  if (from_ts.type != BT_DERIVED
+  if (from_ts.type != BT_DERIVED && from_ts.type != BT_CLASS
       && (from_ts.type == ts->type && from_ts.kind == ts->kind))
     return true;
 
-  if (expr->ts.type == BT_DERIVED && ts->type == BT_DERIVED
-      && gfc_compare_types (&expr->ts, ts))
+  if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
+      && (ts->type == BT_DERIVED || ts->type == BT_CLASS)
+      && gfc_compare_types (ts, &expr->ts))
     return true;
 
   /* If array is true then conversion is in an array constructor where
diff --git a/gcc/fortran/misc.c b/gcc/fortran/misc.c
index 3d449ae17fe..e6402e881e3 100644
--- a/gcc/fortran/misc.c
+++ b/gcc/fortran/misc.c
@@ -130,7 +130,6 @@ gfc_typename (gfc_typespec *ts, bool for_hash)
   static char buffer2[GFC_MAX_SYMBOL_LEN + 8];
   static int flag = 0;
   char *buffer;
-  gfc_typespec *ts1;
   gfc_charlen_t length = 0;
 
   buffer = flag ? buffer1 : buffer2;
@@ -180,16 +179,17 @@ gfc_typename (gfc_typespec *ts, bool for_hash)
       sprintf (buffer, "TYPE(%s)", ts->u.derived->name);
       break;
     case BT_CLASS:
-      if (ts->u.derived == NULL)
+      if (!ts->u.derived || !ts->u.derived->components
+	  || !ts->u.derived->components->ts.u.derived)
 	{
 	  sprintf (buffer, "invalid class");
 	  break;
 	}
-      ts1 = ts->u.derived->components ? &ts->u.derived->components->ts : NULL;
-      if (ts1 && ts1->u.derived && ts1->u.derived->attr.unlimited_polymorphic)
+      if (ts->u.derived->components->ts.u.derived->attr.unlimited_polymorphic)
 	sprintf (buffer, "CLASS(*)");
       else
-	sprintf (buffer, "CLASS(%s)", ts->u.derived->name);
+	sprintf (buffer, "CLASS(%s)",
+		 ts->u.derived->components->ts.u.derived->name);
       break;
     case BT_ASSUMED:
       sprintf (buffer, "TYPE(*)");
diff --git a/gcc/testsuite/gfortran.dg/class_72.f90 b/gcc/testsuite/gfortran.dg/class_72.f90
new file mode 100644
index 00000000000..0fd6ec010f5
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_72.f90
@@ -0,0 +1,83 @@
+! PR fortran/102745
+
+implicit none
+
+type t
+end type t
+
+type, extends(t) :: t2
+end type t2
+
+type t3
+end type t3
+
+type(t), allocatable :: var
+type(t2), allocatable :: v2ar
+type(t3), allocatable :: v3ar
+class(t), allocatable :: cvar
+class(t2), allocatable :: c2var
+class(t3), allocatable :: c3var
+
+call f(var)
+call f(v2ar)   ! { dg-error "passed TYPE.t2. to TYPE.t." }
+call f(v2ar%t)
+call f(cvar)
+call f(c2var)  ! { dg-error "passed CLASS.t2. to TYPE.t." }
+call f(c2var%t)
+
+call f2(var)   ! { dg-error "passed TYPE.t. to TYPE.t2." }
+call f2(v2ar)
+call f2(cvar)  ! { dg-error "passed CLASS.t. to TYPE.t2." }
+call f2(c2var)
+
+
+var = var
+var = v2ar  ! { dg-error "TYPE.t2. to TYPE.t." }
+var = cvar
+var = c2var ! { dg-error "TYPE.t2. to TYPE.t." }
+
+v2ar = var  ! { dg-error "Cannot convert TYPE.t. to TYPE.t2." }
+v2ar = v2ar
+v2ar = cvar ! { dg-error "Cannot convert TYPE.t. to TYPE.t2." }
+v2ar = c2var
+
+cvar = var
+cvar = v2ar
+cvar = cvar
+cvar = c2var
+
+c2var = var   ! { dg-error "Cannot convert TYPE.t. to CLASS.t2." }
+c2var = v3ar  ! { dg-error "Cannot convert TYPE.t3. to CLASS.t2." }
+c2var = v2ar
+c2var = cvar  ! { dg-error "Cannot convert CLASS.t. to CLASS.t2." }
+c2var = c3var ! { dg-error "Cannot convert CLASS.t3. to CLASS.t2." }
+c2var = c2var
+
+allocate (var, source=var)
+allocate (var, source=v2ar)   ! { dg-error "incompatible with source-expr" }
+allocate (var, source=cvar)
+allocate (var, source=c2var)  ! { dg-error "incompatible with source-expr" }
+
+allocate (v2ar, source=var)   ! { dg-error "incompatible with source-expr" }
+allocate (v2ar, source=v2ar)
+allocate (v2ar, source=cvar)  ! { dg-error "incompatible with source-expr" }
+allocate (v2ar, source=c2var)
+
+allocate (cvar, source=var)
+allocate (cvar, source=v2ar)
+allocate (cvar, source=cvar)
+allocate (cvar, source=c2var)
+
+allocate (c2var, source=var)  ! { dg-error "incompatible with source-expr" }
+allocate (c2var, source=v2ar)
+allocate (c2var, source=cvar) ! { dg-error "incompatible with source-expr" }
+allocate (c2var, source=c2var)
+
+contains
+ subroutine f(x)
+   type(t) :: x
+ end
+ subroutine f2(x)
+   type(t2) :: x
+ end
+end

Re: [Patch] Fortran: Fix CLASS conversion check [PR102745]

[Paul Richard Thomas]

Hi Tobias,

This is OK for mainline and as far back in the branches as you feel
inclined to go.

Thanks for the patch.

Paul


On Fri, 15 Oct 2021 at 22:19, Tobias Burnus <tobias@codesourcery.com> wrote:

> This patch fixes two issues:
>
> First, to print 'CLASS(t2)' instead of:
> Error: Type mismatch in argument ‘x’ at (1); passed
> CLASS(__class_MAIN___T2_a) to TYPE(t)
>
> Additionally,
>
>    class(t2) = class(t)  ! 't2' extends 't'
>    class(t2) = class(any)
>
> was wrongly accepted.
>
> OK?
>
> Tobias
> -----------------
> Siemens Electronic Design Automation GmbH; Anschrift: Arnulfstraße 201,
> 80634 München; Gesellschaft mit beschränkter Haftung; Geschäftsführer:
> Thomas Heurung, Frank Thürauf; Sitz der Gesellschaft: München;
> Registergericht München, HRB 106955
>


-- 
"If you can't explain it simply, you don't understand it well enough" -
Albert Einstein