mirror of git://gcc.gnu.org/git/gcc.git
Fortran: avoid several NULL pointer dereferences during error recovery
gcc/fortran/ChangeLog: PR fortran/102332 * expr.c (gfc_get_variable_expr): Avoid NULL pointer dereferences during handling of errors with invalid uses of CLASS variables. * match.c (select_type_set_tmp): Likewise. * primary.c (gfc_match_varspec): Likewise. * resolve.c (resolve_variable): Likewise. (resolve_select_type): Likewise. gcc/testsuite/ChangeLog: PR fortran/102332 * gfortran.dg/pr102332.f90: New test.
This commit is contained in:
parent
ad964f7eae
commit
d8f6c48ccb
|
@ -5166,7 +5166,8 @@ gfc_get_variable_expr (gfc_symtree *var)
|
|||
|
||||
if (var->n.sym->attr.flavor != FL_PROCEDURE
|
||||
&& ((var->n.sym->as != NULL && var->n.sym->ts.type != BT_CLASS)
|
||||
|| (var->n.sym->ts.type == BT_CLASS && CLASS_DATA (var->n.sym)
|
||||
|| (var->n.sym->ts.type == BT_CLASS && var->n.sym->ts.u.derived
|
||||
&& CLASS_DATA (var->n.sym)
|
||||
&& CLASS_DATA (var->n.sym)->as)))
|
||||
{
|
||||
e->rank = var->n.sym->ts.type == BT_CLASS
|
||||
|
|
|
@ -6363,7 +6363,8 @@ select_type_set_tmp (gfc_typespec *ts)
|
|||
sym = tmp->n.sym;
|
||||
gfc_add_type (sym, ts, NULL);
|
||||
|
||||
if (selector->ts.type == BT_CLASS && selector->attr.class_ok)
|
||||
if (selector->ts.type == BT_CLASS && selector->attr.class_ok
|
||||
&& selector->ts.u.derived && CLASS_DATA (selector))
|
||||
{
|
||||
sym->attr.pointer
|
||||
= CLASS_DATA (selector)->attr.class_pointer;
|
||||
|
|
|
@ -2151,6 +2151,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
|
|||
&& !(gfc_matching_procptr_assignment
|
||||
&& sym->attr.flavor == FL_PROCEDURE))
|
||||
|| (sym->ts.type == BT_CLASS && sym->attr.class_ok
|
||||
&& sym->ts.u.derived && CLASS_DATA (sym)
|
||||
&& (CLASS_DATA (sym)->attr.dimension
|
||||
|| CLASS_DATA (sym)->attr.codimension)))
|
||||
{
|
||||
|
|
|
@ -5736,6 +5736,8 @@ resolve_variable (gfc_expr *e)
|
|||
can't be translated that way. */
|
||||
if (sym->assoc && e->rank == 0 && e->ref && sym->ts.type == BT_CLASS
|
||||
&& sym->assoc->target && sym->assoc->target->ts.type == BT_CLASS
|
||||
&& sym->assoc->target->ts.u.derived
|
||||
&& CLASS_DATA (sym->assoc->target)
|
||||
&& CLASS_DATA (sym->assoc->target)->as)
|
||||
{
|
||||
gfc_ref *ref = e->ref;
|
||||
|
@ -5799,7 +5801,8 @@ resolve_variable (gfc_expr *e)
|
|||
/* Like above, but for class types, where the checking whether an array
|
||||
ref is present is more complicated. Furthermore make sure not to add
|
||||
the full array ref to _vptr or _len refs. */
|
||||
if (sym->assoc && sym->ts.type == BT_CLASS
|
||||
if (sym->assoc && sym->ts.type == BT_CLASS && sym->ts.u.derived
|
||||
&& CLASS_DATA (sym)
|
||||
&& CLASS_DATA (sym)->attr.dimension
|
||||
&& (e->ts.type != BT_DERIVED || !e->ts.u.derived->attr.vtype))
|
||||
{
|
||||
|
@ -9432,6 +9435,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
|
|||
|
||||
/* Check F03:C815. */
|
||||
if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
|
||||
&& selector_type
|
||||
&& !selector_type->attr.unlimited_polymorphic
|
||||
&& !gfc_type_is_extensible (c->ts.u.derived))
|
||||
{
|
||||
|
@ -9442,7 +9446,8 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
|
|||
}
|
||||
|
||||
/* Check F03:C816. */
|
||||
if (c->ts.type != BT_UNKNOWN && !selector_type->attr.unlimited_polymorphic
|
||||
if (c->ts.type != BT_UNKNOWN
|
||||
&& selector_type && !selector_type->attr.unlimited_polymorphic
|
||||
&& ((c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS)
|
||||
|| !gfc_type_is_extension_of (selector_type, c->ts.u.derived)))
|
||||
{
|
||||
|
|
|
@ -0,0 +1,69 @@
|
|||
! { dg-do compile }
|
||||
! PR fortran/102332 - ICE in select_type_set_tmp
|
||||
! Contributed by G.Steinmetz
|
||||
|
||||
program p
|
||||
type t
|
||||
real :: a, b
|
||||
end type
|
||||
class(t), allocatable :: x ! Valid
|
||||
select type (y => x)
|
||||
type is (t)
|
||||
y%a = 0
|
||||
end select
|
||||
end
|
||||
|
||||
subroutine s0 (x)
|
||||
type t
|
||||
real :: a, b
|
||||
end type
|
||||
class(t) :: x ! Valid
|
||||
select type (y => x)
|
||||
type is (t)
|
||||
y%a = 0
|
||||
end select
|
||||
end
|
||||
|
||||
subroutine s1
|
||||
type t
|
||||
real :: a, b
|
||||
end type
|
||||
class(t) :: x ! { dg-error "must be dummy, allocatable or pointer" }
|
||||
select type (y => x)
|
||||
type is (t)
|
||||
y%a = 0
|
||||
end select
|
||||
end
|
||||
|
||||
subroutine s3
|
||||
type t
|
||||
real :: a, b
|
||||
end type
|
||||
class(t) :: x ! { dg-error "must be dummy, allocatable or pointer" }
|
||||
select type (y => x)
|
||||
class is (t)
|
||||
y%a = 0
|
||||
end select
|
||||
end
|
||||
|
||||
subroutine s2
|
||||
type t
|
||||
real :: a, b
|
||||
end type
|
||||
class(t) :: x ! { dg-error "must be dummy, allocatable or pointer" }
|
||||
select type (y => x)
|
||||
type default ! { dg-error "Expected" }
|
||||
y%a = 0
|
||||
end select
|
||||
end
|
||||
|
||||
subroutine s4
|
||||
type t
|
||||
real :: a, b
|
||||
end type
|
||||
class(t) :: x ! { dg-error "must be dummy, allocatable or pointer" }
|
||||
select type (y => x)
|
||||
class default
|
||||
y%a = 0
|
||||
end select
|
||||
end
|
Loading…
Reference in New Issue