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

re PR fortran/26038 (ICE on allocation of assumed length CHARACTER dummy.)

Browse source 
2006-02-09  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/26038
	* trans-stmt.c (gfc_trans_allocate): Provide assumed character length
	scalar with missing backend_decl for the hidden dummy charlen.

	PR fortran/25059
	* interface.c (gfc_extend_assign): Remove detection of non-PURE
	subroutine in assignment interface, with gfc_error, and put it in
	* resolve.c (resolve_code).

	PR fortran/25070
	* interface.c (gfc_procedure_use): Flag rank checking for non-
	elemental, contained or interface procedures in call to
	(compare_actual_formal), where ranks are checked for assumed
	shape arrays..

2006-02-09  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/26038
	* gfortran.dg/allocate_char_star_scalar_1.f90: New test.

	PR fortran/25059
	* gfortran.dg/impure_assignment_1.f90: New test.

	PR fortran/25070
	* gfortran.dg/assumed_shape_ranks_1.f90: New test.

From-SVN: r110816
This commit is contained in:
Paul Thomas 2006-02-09 23:23:28 +00:00
parent 95c029c30c
commit c4bbc10564
8 changed files with 134 additions and 11 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

17
gcc/fortran/ChangeLog
View file

@ -1,3 +1,20 @@
2006-02-09 Paul Thomas <pault@gcc.gnu.org>
PR fortran/26038
* trans-stmt.c (gfc_trans_allocate): Provide assumed character length
scalar with missing backend_decl for the hidden dummy charlen.
PR fortran/25059
* interface.c (gfc_extend_assign): Remove detection of non-PURE
subroutine in assignment interface, with gfc_error, and put it in
* resolve.c (resolve_code).
PR fortran/25070
* interface.c (gfc_procedure_use): Flag rank checking for non-
elemental, contained or interface procedures in call to
(compare_actual_formal), where ranks are checked for assumed
shape arrays..
2006-02-08 Francois-Xavier Coudert <coudert@clipper.ens.fr>
PR libfortran/25425

20
gcc/fortran/interface.c
View file

@ -1241,7 +1241,10 @@ compare_actual_formal (gfc_actual_arglist ** ap,
}
if (!compare_parameter
(f->sym, a->expr, ranks_must_agree, is_elemental))
(f->sym, a->expr,
ranks_must_agree && f->sym->as
&& f->sym->as->type == AS_ASSUMED_SHAPE,
is_elemental))
{
if (where)
gfc_error ("Type/rank mismatch in argument '%s' at %L",
@ -1563,6 +1566,10 @@ check_intents (gfc_formal_arglist * f, gfc_actual_arglist * a)
void
gfc_procedure_use (gfc_symbol * sym, gfc_actual_arglist ** ap, locus * where)
{
int ranks_must_agree;
ranks_must_agree = !sym->attr.elemental && (sym->attr.contained
|| sym->attr.if_source == IFSRC_IFBODY);
/* Warn about calls with an implicit interface. */
if (gfc_option.warn_implicit_interface
&& sym->attr.if_source == IFSRC_UNKNOWN)
@ -1570,8 +1577,8 @@ gfc_procedure_use (gfc_symbol * sym, gfc_actual_arglist ** ap, locus * where)
sym->name, where);
if (sym->attr.if_source == IFSRC_UNKNOWN
|| !compare_actual_formal (ap, sym->formal, 0,
sym->attr.elemental, where))
|| !compare_actual_formal (ap, sym->formal, ranks_must_agree,
sym->attr.elemental, where))
return;
check_intents (sym->formal, *ap);
@ -1796,13 +1803,6 @@ gfc_extend_assign (gfc_code * c, gfc_namespace * ns)
c->expr2 = NULL;
c->ext.actual = actual;
if (gfc_pure (NULL) && !gfc_pure (sym))
{
gfc_error ("Subroutine '%s' called in lieu of assignment at %L must be "
"PURE", sym->name, &c->loc);
return FAILURE;
}
return SUCCESS;
}

11
gcc/fortran/resolve.c
View file

@ -4241,7 +4241,16 @@ resolve_code (gfc_code * code, gfc_namespace * ns)
break;
if (gfc_extend_assign (code, ns) == SUCCESS)
goto call;
{
if (gfc_pure (NULL) && !gfc_pure (code->symtree->n.sym))
{
gfc_error ("Subroutine '%s' called instead of assignment at "
"%L must be PURE", code->symtree->n.sym->name,
&code->loc);
break;
}
goto call;
}
if (gfc_pure (NULL))
{

4
gcc/fortran/trans-stmt.c
View file

@ -3455,6 +3455,10 @@ gfc_trans_allocate (gfc_code * code)
gfc_add_modify_expr (&se.pre, val, tmp);
tmp = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));
if (expr->ts.type == BT_CHARACTER && tmp == NULL_TREE)
tmp = se.string_length;
parm = gfc_chainon_list (NULL_TREE, val);
parm = gfc_chainon_list (parm, tmp);
parm = gfc_chainon_list (parm, pstat);

11
gcc/testsuite/ChangeLog
View file

@ -1,3 +1,14 @@
2006-02-09 Paul Thomas <pault@gcc.gnu.org>
PR fortran/26038
* gfortran.dg/allocate_char_star_scalar_1.f90: New test.
PR fortran/25059
* gfortran.dg/impure_assignment_1.f90: New test.
PR fortran/25070
* gfortran.dg/assumed_shape_ranks_1.f90: New test.
2006-02-09 J"orn Rennecke <joern.rennecke@st.com>
PR target/26141

31
gcc/testsuite/gfortran.dg/allocate_char_star_scalar_1.f90 Normal file
View file

@ -0,0 +1,31 @@
! { dg-do compile }
! Tests the patch for PR26038 that used to ICE in gfc_trans_allocate
! for the want of a string_length to pass to the library.
! Contributed by hjl@lucon.org && Erik Edelmann <eedelmanncc.gnu.org>
module moo
contains
subroutine foo(self)
character(*) :: self
pointer :: self
nullify(self)
allocate(self) ! Used to ICE here
print *, len(self)
end subroutine
end module moo
program hum
use moo
character(5), pointer :: p
character(10), pointer :: q
call foo(p)
call foo(q)
end program hum

25
gcc/testsuite/gfortran.dg/assumed_shape_ranks_1.f90 Normal file
View file

@ -0,0 +1,25 @@
! { dg-do compile }
! Tests fix for PR25070; was no error for actual and assumed shape
! dummy ranks not matching.
! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
module addon
interface extra
function foo (y)
integer :: foo (2), y (:)
end function foo
end interface extra
end module addon
use addon
INTEGER :: I(2,2)
I=RESHAPE((/1,2,3,4/),(/2,2/))
CALL TST(I) ! { dg-error "Type/rank mismatch in argument" }
i = foo (i) ! { dg-error "Type/rank mismatch|Incompatible ranks" }
CONTAINS
SUBROUTINE TST(I)
INTEGER :: I(:)
write(6,*) I
END SUBROUTINE TST
END

26
gcc/testsuite/gfortran.dg/impure_assignment_1.f90 Normal file
View file

@ -0,0 +1,26 @@
! { dg-do compile }
! Tests fix for PR25059, which gave and ICE after error message
! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
MODULE M1
TYPE T1
INTEGER :: I
END TYPE T1
INTERFACE ASSIGNMENT(=)
MODULE PROCEDURE S1
END INTERFACE
CONTAINS
SUBROUTINE S1(I,J)
TYPE(T1), INTENT(OUT):: I
TYPE(T1), INTENT(IN) :: J
I%I=J%I**2
END SUBROUTINE S1
END MODULE M1
USE M1
CONTAINS
PURE SUBROUTINE S2(I,J)
TYPE(T1), INTENT(OUT):: I
TYPE(T1), INTENT(IN) :: J
I=J ! { dg-error "must be PURE" }
END SUBROUTINE S2
END