Fortran: Fix CLASS conversion check [PR102745]
Commit Message
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
Comments
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
>
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(-)
@@ -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
@@ -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(*)");
new file mode 100644
@@ -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