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.
This commit is contained in:
parent
f5b3743596
commit
017665f630
|
@ -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
|
/* In building an array constructor, gfortran can end up here when no
|
||||||
conversion is required for an intrinsic type. We need to let derived
|
conversion is required for an intrinsic type. We need to let derived
|
||||||
types drop through. */
|
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))
|
&& (from_ts.type == ts->type && from_ts.kind == ts->kind))
|
||||||
return true;
|
return true;
|
||||||
|
|
||||||
if (expr->ts.type == BT_DERIVED && ts->type == BT_DERIVED
|
if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
|
||||||
&& gfc_compare_types (&expr->ts, ts))
|
&& (ts->type == BT_DERIVED || ts->type == BT_CLASS)
|
||||||
|
&& gfc_compare_types (ts, &expr->ts))
|
||||||
return true;
|
return true;
|
||||||
|
|
||||||
/* If array is true then conversion is in an array constructor where
|
/* 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 char buffer2[GFC_MAX_SYMBOL_LEN + 8];
|
||||||
static int flag = 0;
|
static int flag = 0;
|
||||||
char *buffer;
|
char *buffer;
|
||||||
gfc_typespec *ts1;
|
|
||||||
gfc_charlen_t length = 0;
|
gfc_charlen_t length = 0;
|
||||||
|
|
||||||
buffer = flag ? buffer1 : buffer2;
|
buffer = flag ? buffer1 : buffer2;
|
||||||
|
@ -180,16 +179,17 @@ gfc_typename (gfc_typespec *ts, bool for_hash)
|
||||||
sprintf (buffer, "TYPE(%s)", ts->u.derived->name);
|
sprintf (buffer, "TYPE(%s)", ts->u.derived->name);
|
||||||
break;
|
break;
|
||||||
case BT_CLASS:
|
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");
|
sprintf (buffer, "invalid class");
|
||||||
break;
|
break;
|
||||||
}
|
}
|
||||||
ts1 = ts->u.derived->components ? &ts->u.derived->components->ts : NULL;
|
if (ts->u.derived->components->ts.u.derived->attr.unlimited_polymorphic)
|
||||||
if (ts1 && ts1->u.derived && ts1->u.derived->attr.unlimited_polymorphic)
|
|
||||||
sprintf (buffer, "CLASS(*)");
|
sprintf (buffer, "CLASS(*)");
|
||||||
else
|
else
|
||||||
sprintf (buffer, "CLASS(%s)", ts->u.derived->name);
|
sprintf (buffer, "CLASS(%s)",
|
||||||
|
ts->u.derived->components->ts.u.derived->name);
|
||||||
break;
|
break;
|
||||||
case BT_ASSUMED:
|
case BT_ASSUMED:
|
||||||
sprintf (buffer, "TYPE(*)");
|
sprintf (buffer, "TYPE(*)");
|
||||||
|
|
|
@ -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
|
Loading…
Reference in New Issue