OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/60289 (allocating class(*) pointer as character gives type-spec requires the same character-length parameter)

Browse Source 
PR fortran/60289
	Initial patch by Janus Weil
	* resolve.c (resolve_allocate_expr): Add check for comp. only when 
	target is not unlimited polymorphic.
	* trans-stmt.c (gfc_trans_allocate): Assign correct value to _len
	component of unlimited polymorphic entities.

	* gfortran.dg/unlimited_polymorphic_22.f90: New test.

From-SVN: r220474
This commit is contained in:
Andre Vehreschild 2015-02-06 12:22:54 +01:00 committed by Andre Vehreschild
parent 9fb87eb0bb
commit e3a7c6cf72
4 changed files with 83 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
gcc/fortran/ChangeLog
View File

@ -1,3 +1,17 @@
2015-01-29 Andre Vehreschild <vehre@gmx.de>, Janus Weil <janus@gcc.gnu.org>
PR fortran/60289
Initial patch by Janus Weil
* resolve.c (resolve_allocate_expr): Add check for comp. only when
target is not unlimited polymorphic.
* trans-stmt.c (gfc_trans_allocate): Assign correct value to _len
component of unlimited polymorphic entities.
2015-01-29 Andre Vehreschild <vehre@gmx.de>
* gfortran.dg/unlimited_polymorphic_22.f90: New test.
2015-02-05 Tobias Burnus <burnus@net-b.de>
PR fortran/64943

4
gcc/fortran/resolve.c
View File

@ -6933,7 +6933,9 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
goto failure;
}
if (code->ext.alloc.ts.type == BT_CHARACTER && !e->ts.deferred)
/* Check F08:C632. */
if (code->ext.alloc.ts.type == BT_CHARACTER && !e->ts.deferred
&& !UNLIMITED_POLY (e))
{
int cmp = gfc_dep_compare_expr (e->ts.u.cl->length,
code->ext.alloc.ts.u.cl->length);

11
gcc/fortran/trans-stmt.c
View File

@ -5167,7 +5167,16 @@ gfc_trans_allocate (gfc_code * code)
se_sz.expr = gfc_evaluate_now (se_sz.expr, &se.pre);
gfc_add_block_to_block (&se.pre, &se_sz.post);
/* Store the string length. */
tmp = al->expr->ts.u.cl->backend_decl;
if ((expr->symtree->n.sym->ts.type == BT_CLASS
|| expr->symtree->n.sym->ts.type == BT_DERIVED)
&& expr->ts.u.derived->attr.unlimited_polymorphic)
/* For unlimited polymorphic entities get the backend_decl of
the _len component for that. */
tmp = gfc_class_len_get (gfc_get_symbol_decl (
expr->symtree->n.sym));
else
/* Else use what is stored in the charlen->backend_decl. */
tmp = al->expr->ts.u.cl->backend_decl;
gfc_add_modify (&se.pre, tmp, fold_convert (TREE_TYPE (tmp),
se_sz.expr));
tmp = TREE_TYPE (gfc_typenode_for_spec (&code->ext.alloc.ts));

56
gcc/testsuite/gfortran.dg/unlimited_polymorphic_22.f90 Normal file
View File

@ -0,0 +1,56 @@
! { dg-do run }
! Testing fix for PR fortran/60289
! Contributed by: Andre Vehreschild <vehre@gmx.de>
!
program test
implicit none
class(*), pointer :: P
integer :: string_len = 10 *2
allocate(character(string_len)::P)
select type(P)
type is (character(*))
P ="some test string"
if (P .ne. "some test string") then
call abort ()
end if
if (len(P) .ne. 20) then
call abort ()
end if
if (len(P) .eq. len("some test string")) then
call abort ()
end if
class default
call abort ()
end select
deallocate(P)
! Now for kind=4 chars.
allocate(character(len=20,kind=4)::P)
select type(P)
type is (character(len=*,kind=4))
P ="some test string"
if (P .ne. 4_"some test string") then
call abort ()
end if
if (len(P) .ne. 20) then
call abort ()
end if
if (len(P) .eq. len("some test string")) then
call abort ()
end if
type is (character(len=*,kind=1))
call abort ()
class default
call abort ()
end select
deallocate(P)
end program test