FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

re PR fortran/87566 (ICE with class(*) and select)

Browse source 
2018-10-15  Paul Thomas  <pault@gcc.gnu.org>
	    Tobias Burnus  <burnus@gcc.gnu.org>

	PR fortran/87566
	* resolve.c (resolve_assoc_var): Add missing array spec for
	class associate names.
	(resolve_select_type): Handle case where last typed component
	of the selector has a different type to the expression.
	* trans-expr.c (gfc_find_and_cut_at_last_class_ref): Replace
	call to gfc_expr_to_initialize with call to gfc_copy_expr.
	(gfc_conv_class_to_class): Guard assignment to 'len' field
	against case where zero constant is supplied.

2018-10-15  Paul Thomas  <pault@gcc.gnu.org>
	    Tobias Burnus  <burnus@gcc.gnu.org>

	PR fortran/87566
	* gfortran.dg/select_type_44.f90: New test.
	* gfortran.dg/associate_42.f90: New test.


Co-Authored-By: Tobias Burnus <burnus@gcc.gnu.org>

From-SVN: r265171
This commit is contained in:
Paul Thomas 2018-10-15 16:31:15 +00:00
parent 72551c683c
commit e60f68ec46
6 changed files with 136 additions and 5 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

13
gcc/fortran/ChangeLog
View file

@ -1,3 +1,16 @@
2018-10-15 Paul Thomas <pault@gcc.gnu.org>
Tobias Burnus <burnus@gcc.gnu.org>
PR fortran/87566
* resolve.c (resolve_assoc_var): Add missing array spec for
class associate names.
(resolve_select_type): Handle case where last typed component
of the selector has a different type to the expression.
* trans-expr.c (gfc_find_and_cut_at_last_class_ref): Replace
call to gfc_expr_to_initialize with call to gfc_copy_expr.
(gfc_conv_class_to_class): Guard assignment to 'len' field
against case where zero constant is supplied.
2018-10-12 Tobias Burnus <burnus@net-b.de>
PR fortran/87597

33
gcc/fortran/resolve.c
View file

@ -8675,6 +8675,18 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
if (as->corank != 0)
sym->attr.codimension = 1;
}
else if (sym->ts.type == BT_CLASS && (!CLASS_DATA (sym)->as || sym->assoc->rankguessed))
{
if (!CLASS_DATA (sym)->as)
CLASS_DATA (sym)->as = gfc_get_array_spec ();
as = CLASS_DATA (sym)->as;
as->rank = target->rank;
as->type = AS_DEFERRED;
as->corank = gfc_get_corank (target);
CLASS_DATA (sym)->attr.dimension = 1;
if (as->corank != 0)
CLASS_DATA (sym)->attr.codimension = 1;
}
}
else
{
@ -8875,9 +8887,24 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
if (code->expr2)
{
if (code->expr1->symtree->n.sym->attr.untyped)
code->expr1->symtree->n.sym->ts = code->expr2->ts;
selector_type = CLASS_DATA (code->expr2)->ts.u.derived;
gfc_ref *ref2 = NULL;
for (ref = code->expr2->ref; ref != NULL; ref = ref->next)
if (ref->type == REF_COMPONENT
&& ref->u.c.component->ts.type == BT_CLASS)
ref2 = ref;
if (ref2)
{
if (code->expr1->symtree->n.sym->attr.untyped)
code->expr1->symtree->n.sym->ts = ref->u.c.component->ts;
selector_type = CLASS_DATA (ref2->u.c.component)->ts.u.derived;
}
else
{
if (code->expr1->symtree->n.sym->attr.untyped)
code->expr1->symtree->n.sym->ts = code->expr2->ts;
selector_type = CLASS_DATA (code->expr2)->ts.u.derived;
}
if (code->expr2->rank && CLASS_DATA (code->expr1)->as)
CLASS_DATA (code->expr1)->as->rank = code->expr2->rank;

5
gcc/fortran/trans-expr.c
View file

@ -394,7 +394,7 @@ gfc_find_and_cut_at_last_class_ref (gfc_expr *e)
e->ref = NULL;
}
base_expr = gfc_expr_to_initialize (e);
base_expr = gfc_copy_expr (e);
/* Restore the original tail expression. */
if (class_ref)
@ -1131,7 +1131,8 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
/* Return the len component, except in the case of scalarized array
references, where the dynamic type cannot change. */
if (!elemental && full_array && copyback)
if (!elemental && full_array && copyback
&& (UNLIMITED_POLY (e) || VAR_P (tmp)))
gfc_add_modify (&parmse->post, tmp,
fold_convert (TREE_TYPE (tmp), ctree));
}

7
gcc/testsuite/ChangeLog
View file

@ -1,3 +1,10 @@
2018-10-15 Paul Thomas <pault@gcc.gnu.org>
Tobias Burnus <burnus@gcc.gnu.org>
PR fortran/87566
* gfortran.dg/select_type_44.f90: New test.
* gfortran.dg/associate_42.f90: New test.
2018-10-15 Bin Cheng <bin.cheng@linux.alibaba.com>
PR tree-optimization/87022

41
gcc/testsuite/gfortran.dg/associate_42.f90 Normal file
View file

@ -0,0 +1,41 @@
! { dg-do run }
!
! Tests the fix for a bug that was found in the course of fixing PR87566.
!
! Contributed by Paul Thomas <pault@gcc.gnu.org>
!
call AddArray
contains
subroutine AddArray()
type Object_array_pointer
class(*), pointer :: p(:) => null()
end type Object_array_pointer
type (Object_array_pointer) :: obj
character(3), target :: tgt1(2) = ['one','two']
character(5), target :: tgt2(2) = ['three','four ']
real, target :: tgt3(3) = [1.0,2.0,3.0]
obj%p => tgt1
associate (point => obj%p)
select type (point) ! Used to ICE here.
type is (character(*))
if (any (point .ne. tgt1)) stop 1
end select
point => tgt2
end associate
select type (z => obj%p)
type is (character(*))
if (any (z .ne. tgt2)) stop 2
end select
obj%p => tgt3
associate (point => obj%p)
select type (point)
type is (real)
if (any (point .ne. tgt3)) stop 3
end select
end associate
end subroutine AddArray
end

42
gcc/testsuite/gfortran.dg/select_type_44.f90 Normal file
View file

@ -0,0 +1,42 @@
! { dg-do run }
!
! Test the fix for PR87566
!
! Contributed by Antony Lewis <antony@cosmologist.info>
!
call AddArray
contains
subroutine AddArray()
type Object_array_pointer
class(*), pointer :: p(:) => null()
end type Object_array_pointer
class(*), pointer :: Pt => null()
type (Object_array_pointer) :: obj
character(3), target :: tgt1(2) = ['one','two']
character(5), target :: tgt2(2) = ['three','four ']
allocate (Pt, source = Object_array_pointer ())
select type (Pt)
type is (object_array_pointer)
Pt%p => tgt1
end select
select type (Pt)
class is (object_array_pointer)
select type (Point=> Pt%P)
type is (character(*))
if (any (Point .ne. tgt1)) stop 1
Point = ['abc','efg']
end select
end select
select type (Pt)
class is (object_array_pointer)
select type (Point=> Pt%P)
type is (character(*))
if (any (Point .ne. ['abc','efg'])) stop 2
end select
end select
end subroutine AddArray
end