/* 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
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;
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(*)");
--- /dev/null
+! 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