{
gfc_symbol* sym;
gfc_expr *target;
+ int rank;
if (gfc_get_sym_tree (a->name, NULL, &a->st, false))
gcc_unreachable ();
}
}
- if (target->rank)
+ rank = target->rank;
+ /* Fixup cases where the ranks are mismatched. */
+ if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
{
- int rank = 0;
- rank = target->rank;
- /* When the rank is greater than zero then sym will be an array. */
- if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
+ if ((!CLASS_DATA (sym)->as && rank != 0)
+ || (CLASS_DATA (sym)->as
+ && CLASS_DATA (sym)->as->rank != rank))
{
- if ((!CLASS_DATA (sym)->as && rank != 0)
- || (CLASS_DATA (sym)->as
- && CLASS_DATA (sym)->as->rank != rank))
+ /* Don't just (re-)set the attr and as in the sym.ts,
+ because this modifies the target's attr and as. Copy the
+ data and do a build_class_symbol. */
+ symbol_attribute attr = CLASS_DATA (target)->attr;
+ int corank = gfc_get_corank (target);
+ gfc_typespec type;
+
+ if (rank || corank)
{
- /* Don't just (re-)set the attr and as in the sym.ts,
- because this modifies the target's attr and as. Copy the
- data and do a build_class_symbol. */
- symbol_attribute attr = CLASS_DATA (target)->attr;
- int corank = gfc_get_corank (target);
- gfc_typespec type;
-
- if (rank || corank)
- {
- as = gfc_get_array_spec ();
- as->type = AS_DEFERRED;
- as->rank = rank;
- as->corank = corank;
- attr.dimension = rank ? 1 : 0;
- attr.codimension = corank ? 1 : 0;
- }
- else
- {
- as = NULL;
- attr.dimension = attr.codimension = 0;
- }
- attr.class_ok = 0;
- type = CLASS_DATA (sym)->ts;
- if (!gfc_build_class_symbol (&type,
- &attr, &as))
- gcc_unreachable ();
- sym->ts = type;
- sym->ts.type = BT_CLASS;
- sym->attr.class_ok = 1;
+ as = gfc_get_array_spec ();
+ as->type = AS_DEFERRED;
+ as->rank = rank;
+ as->corank = corank;
+ attr.dimension = rank ? 1 : 0;
+ attr.codimension = corank ? 1 : 0;
}
else
- sym->attr.class_ok = 1;
- }
- else if ((!sym->as && rank != 0)
- || (sym->as && sym->as->rank != rank))
- {
- as = gfc_get_array_spec ();
- as->type = AS_DEFERRED;
- as->rank = rank;
- as->corank = gfc_get_corank (target);
- sym->as = as;
- sym->attr.dimension = 1;
- if (as->corank)
- sym->attr.codimension = 1;
+ {
+ as = NULL;
+ attr.dimension = attr.codimension = 0;
+ }
+ attr.class_ok = 0;
+ type = CLASS_DATA (sym)->ts;
+ if (!gfc_build_class_symbol (&type, &attr, &as))
+ gcc_unreachable ();
+ sym->ts = type;
+ sym->ts.type = BT_CLASS;
+ sym->attr.class_ok = 1;
}
+ else
+ sym->attr.class_ok = 1;
+ }
+ else if ((!sym->as && rank != 0)
+ || (sym->as && sym->as->rank != rank))
+ {
+ as = gfc_get_array_spec ();
+ as->type = AS_DEFERRED;
+ as->rank = rank;
+ as->corank = gfc_get_corank (target);
+ sym->as = as;
+ sym->attr.dimension = 1;
+ if (as->corank)
+ sym->attr.codimension = 1;
}
}
--- /dev/null
+! { dg-do compile }
+!
+! This contains both testcases in the PR
+!
+! Contributed by Tomas Trnka <trnka@scm.com>
+!
+! First testcase
+module BogusPointerArgError
+ implicit none
+
+ type :: AType
+ end type
+
+contains
+
+ subroutine A ()
+
+ class(AType), allocatable :: x
+
+ allocate(x)
+ call B (x) ! Was an error here
+ end subroutine
+
+ subroutine B (y)
+ class(AType), intent(in) :: y
+ end subroutine
+
+ subroutine C (z)
+ class(AType), intent(in) :: z(:)
+
+ associate (xxx => z(1))
+ end associate
+
+ end subroutine
+
+end module
+
+! Second testcase
+module AModule
+ implicit none
+ private
+
+ public AType
+
+ type, abstract :: AType
+ contains
+ generic, public :: assignment(=) => Assign
+
+ procedure, private :: Assign
+ end type AType
+
+contains
+
+ subroutine Assign(lhs, rhs)
+ class(AType), intent(inout) :: lhs
+ class(AType), intent(in) :: rhs
+ end subroutine
+
+end module AModule
+
+
+
+module ICEGetDescriptorField
+ use AModule
+ implicit none
+
+contains
+
+ subroutine Foo (x)
+ class(AType), intent(in) :: x(:)
+
+ class(AType), allocatable :: y
+
+ associate (xxx => x(1))
+ y = xxx ! Was an ICE here
+ end associate
+ end subroutine
+
+end module ICEGetDescriptorField