@@ -2242,6 +2242,10 @@ typedef struct gfc_namespace
/* Set when resolve_types has been called for this namespace. */
unsigned types_resolved:1;
+ /* Set if the associate_name in a select type statement is an
+ inferred type. */
+ unsigned assoc_name_inferred:1;
+
/* Set to 1 if code has been generated for this namespace. */
unsigned translated:1;
@@ -6721,6 +6721,20 @@ gfc_match_select_type (void)
goto cleanup;
}
+ if (expr2 && expr2->expr_type == EXPR_VARIABLE
+ && expr2->symtree->n.sym->assoc)
+ {
+ if (expr2->symtree->n.sym->assoc->inferred_type)
+ gfc_current_ns->assoc_name_inferred = 1;
+ else if (expr2->symtree->n.sym->assoc->target
+ && expr2->symtree->n.sym->assoc->target->ts.type == BT_UNKNOWN)
+ gfc_current_ns->assoc_name_inferred = 1;
+ }
+ else if (!expr2
+ && expr1->symtree->n.sym->assoc
+ && expr1->symtree->n.sym->assoc->inferred_type)
+ gfc_current_ns->assoc_name_inferred = 1;
+
new_st.op = EXEC_SELECT_TYPE;
new_st.expr1 = expr1;
new_st.expr2 = expr2;
@@ -2113,13 +2113,13 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
inferred_type = IS_INFERRED_TYPE (primary);
- /* SELECT TYPE and SELECT RANK temporaries within an ASSOCIATE block, whose
- selector has not been parsed, can generate errors with array and component
- refs.. Use 'inferred_type' as a flag to suppress these errors. */
+ /* SELECT TYPE temporaries within an ASSOCIATE block, whose selector has not
+ been parsed, can generate errors with array refs.. The SELECT TYPE
+ namespace is marked with 'assoc_name_inferred'. During resolution, this is
+ detected and gfc_fixup_inferred_type_refs is called. */
if (!inferred_type
- && (gfc_peek_ascii_char () == '(' && !sym->attr.dimension)
- && !sym->attr.codimension
&& sym->attr.select_type_temporary
+ && sym->ns->assoc_name_inferred
&& !sym->attr.select_rank_temporary)
inferred_type = true;
@@ -5888,6 +5888,9 @@ resolve_variable (gfc_expr *e)
if (e->expr_type == EXPR_CONSTANT)
return true;
}
+ else if (sym->attr.select_type_temporary
+ && sym->ns->assoc_name_inferred)
+ gfc_fixup_inferred_type_refs (e);
/* For variables that are used in an associate (target => object) where
the object's basetype is array valued while the target is scalar,
@@ -6231,10 +6234,12 @@ gfc_fixup_inferred_type_refs (gfc_expr *e)
free (new_ref);
}
else
- {
- e->ref = ref->next;
- free (ref);
- }
+ {
+ if (e->ref->u.ar.type == AR_UNKNOWN)
+ gfc_error ("Invalid array reference at %L", &e->where);
+ e->ref = ref->next;
+ free (ref);
+ }
}
/* It is possible for an inquiry reference to be mistaken for a
@@ -6315,6 +6320,8 @@ gfc_fixup_inferred_type_refs (gfc_expr *e)
&& e->ref->u.ar.type != AR_ELEMENT)
{
ref = e->ref;
+ if (ref->u.ar.type == AR_UNKNOWN)
+ gfc_error ("Invalid array reference at %L", &e->where);
e->ref = ref->next;
free (ref);
@@ -6337,6 +6344,8 @@ gfc_fixup_inferred_type_refs (gfc_expr *e)
&& e->ref->next->u.ar.type != AR_ELEMENT)
{
ref = e->ref->next;
+ if (ref->u.ar.type == AR_UNKNOWN)
+ gfc_error ("Invalid array reference at %L", &e->where);
e->ref->next = e->ref->next->next;
free (ref);
}
new file mode 100644
@@ -0,0 +1,32 @@
+! { dg-do compile }
+! Test fix for regression caused by r14-9489 - valid code only.
+! Contributed by Harald Anlauf <anlauf@gcc.gnu.org>
+!
+module p
+ implicit none
+contains
+ subroutine foo
+ class(*), allocatable :: c
+ c = 'abc'
+ select type (c)
+ type is (character(*))
+ if (c .ne. 'abc') stop 1
+! Regression caused ICE here - valid substring reference
+ if (c(2:2) .ne. 'b') stop 2
+ end select
+ end
+ subroutine bar ! This worked correctly
+ class(*), allocatable :: c(:)
+ c = ['abc','def']
+ select type (c)
+ type is (character(*))
+ if (any (c .ne. ['abc','def'])) stop 3
+ if (any (c(:)(2:2) .ne. ['b','e'])) stop 4
+ end select
+ end
+end module p
+
+ use p
+ call foo
+ call bar
+end
new file mode 100644
@@ -0,0 +1,53 @@
+! { dg-do compile }
+! Test fix for regression caused by r14-9489 - invalid code.
+! Contributed by Harald Anlauf <anlauf@gcc.gnu.org>
+
+module q
+ type :: s
+ integer :: j
+ end type
+ type :: t
+ integer :: i
+ class(s), allocatable :: ca
+ end type
+contains
+ subroutine foobar
+ class(*), allocatable :: c
+ c = t (1)
+ select type (c)
+ type is (t)
+! Regression caused ICE here in translation or error was missed - invalid array reference
+ if (c(1)%i .ne. 1) stop 5 ! { dg-error "Syntax error in IF-expression" }
+ if (allocated (c%ca)) then
+! Make sure that response is correct if problem is "nested".
+ select type (ca => c%ca)
+ type is (s)
+! Regression caused ICE here in translation or error was missed - invalid array reference
+ if (ca(1)%j .ne. 1) stop 6 ! { dg-error "Syntax error in IF-expression" }
+ end select
+ select type (ca(1) => c%ca) ! { dg-error "parse error in SELECT TYPE" }
+ type is (s) ! { dg-error "Unexpected TYPE IS statement" }
+ if (ca(1)%j .ne. 1) stop 6 ! { dg-error "nonderived-type variable" }
+ end select ! { dg-error " Expecting END IF statement" }
+ endif
+ end select
+
+! This problem was found in the course of the fix: Chunk taken from associate_64.f90,
+! the derived type and component names adapted and the invalid array reference added.
+ associate (var4 => bar4())
+ if (var4%i .ne. 84) stop 33
+ if (var4%ca%j .ne. 168) stop 34
+ select type (x => var4)
+ type is (t)
+ if (x(1)%i .ne. var4%i) stop 35 ! { dg-error "Invalid array reference" }
+ if (x%ca%j .ne. var4%ca%j) stop 36
+ class default
+ stop 37
+ end select
+ end associate
+ end
+ function bar4() result(res)
+ class(t), allocatable :: res
+ res = t(84, s(168))
+ end
+end module q