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

re PR fortran/29507 ([4.2 only] INDEX in an array initialization causes ICE) 

2007-04-14 Paul Thomas <pault@gcc.gnu.org>

	PR fortran/29507
	PR fortran/31404
	* expr.c (scalarize_intrinsic_call): New function to
	scalarize elemental intrinsic functions in initialization
	expressions.
	(check_init_expr): Detect elemental intrinsic functions
	in initalization expressions and call previous.


2007-04-14 Paul Thomas <pault@gcc.gnu.org>

	PR fortran/29507
	PR fortran/31404
	* gfortran.dg/initialization_6.f90: New test.

From-SVN: r123815
This commit is contained in:
Paul Thomas 2007-04-14 14:09:57 +00:00
parent 4d4f2837c5
commit 396b2c195a
4 changed files with 172 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
gcc/fortran/ChangeLog
View File

@ -1,4 +1,14 @@
2007-04-13 Tobias Burnus <burnus@net-b.de>
2007-04-14 Paul Thomas <pault@gcc.gnu.org>
PR fortran/29507
PR fortran/31404
* expr.c (scalarize_intrinsic_call): New function to
scalarize elemental intrinsic functions in initialization
expressions.
(check_init_expr): Detect elemental intrinsic functions
in initalization expressions and call previous.
2007-04-13 Tobias Burnus <burnus@net-b.de>
PR fortran/31559
* primary.c (match_variable): External functions

133
gcc/fortran/expr.c
View File

@ -1574,6 +1574,128 @@ et0 (gfc_expr *e)
static try check_init_expr (gfc_expr *);
/* Scalarize an expression for an elemental intrinsic call. */
static try
scalarize_intrinsic_call (gfc_expr *e)
{
gfc_actual_arglist *a, *b;
gfc_constructor *args[5], *ctor, *new_ctor;
gfc_expr *expr, *old;
int n, i, rank[5];
old = gfc_copy_expr (e);
/* Assume that the old expression carries the type information and
that the first arg carries all the shape information. */
expr = gfc_copy_expr (old->value.function.actual->expr);
gfc_free_constructor (expr->value.constructor);
expr->value.constructor = NULL;
expr->ts = old->ts;
expr->expr_type = EXPR_ARRAY;
/* Copy the array argument constructors into an array, with nulls
for the scalars. */
n = 0;
a = old->value.function.actual;
for (; a; a = a->next)
{
/* Check that this is OK for an initialization expression. */
if (a->expr && check_init_expr (a->expr) == FAILURE)
goto cleanup;
rank[n] = 0;
if (a->expr && a->expr->rank && a->expr->expr_type == EXPR_VARIABLE)
{
rank[n] = a->expr->rank;
ctor = a->expr->symtree->n.sym->value->value.constructor;
args[n] = gfc_copy_constructor (ctor);
}
else if (a->expr && a->expr->expr_type == EXPR_ARRAY)
{
if (a->expr->rank)
rank[n] = a->expr->rank;
else
rank[n] = 1;
args[n] = gfc_copy_constructor (a->expr->value.constructor);
}
else
args[n] = NULL;
n++;
}
for (i = 1; i < n; i++)
if (rank[i] && rank[i] != rank[0])
goto compliance;
/* Using the first argument as the master, step through the array
calling the function for each element and advancing the array
constructors together. */
ctor = args[0];
new_ctor = NULL;
for (; ctor; ctor = ctor->next)
{
if (expr->value.constructor == NULL)
expr->value.constructor
= new_ctor = gfc_get_constructor ();
else
{
new_ctor->next = gfc_get_constructor ();
new_ctor = new_ctor->next;
}
new_ctor->expr = gfc_copy_expr (old);
gfc_free_actual_arglist (new_ctor->expr->value.function.actual);
a = NULL;
b = old->value.function.actual;
for (i = 0; i < n; i++)
{
if (a == NULL)
new_ctor->expr->value.function.actual
= a = gfc_get_actual_arglist ();
else
{
a->next = gfc_get_actual_arglist ();
a = a->next;
}
if (args[i])
a->expr = gfc_copy_expr (args[i]->expr);
else
a->expr = gfc_copy_expr (b->expr);
b = b->next;
}
/* Simplify the function calls. */
if (gfc_simplify_expr (new_ctor->expr, 0) == FAILURE)
goto cleanup;
for (i = 0; i < n; i++)
if (args[i])
args[i] = args[i]->next;
for (i = 1; i < n; i++)
if (rank[i] && ((args[i] != NULL && args[0] == NULL)
|| (args[i] == NULL && args[0] != NULL)))
goto compliance;
}
free_expr0 (e);
*e = *expr;
gfc_free_expr (old);
return SUCCESS;
compliance:
gfc_error_now ("elemental function arguments at %C are not compliant");
cleanup:
gfc_free_expr (expr);
gfc_free_expr (old);
return FAILURE;
}
static try
check_intrinsic_op (gfc_expr *e, try (*check_function) (gfc_expr *))
{
@ -1775,6 +1897,7 @@ check_init_expr (gfc_expr *e)
gfc_actual_arglist *ap;
match m;
try t;
gfc_intrinsic_sym *isym;
if (e == NULL)
return SUCCESS;
@ -1802,6 +1925,16 @@ check_init_expr (gfc_expr *e)
}
}
/* Try to scalarize an elemental intrinsic function that has an
array argument. */
isym = gfc_find_function (e->symtree->n.sym->name);
if (isym && isym->elemental
&& e->value.function.actual->expr->expr_type == EXPR_ARRAY)
{
if (scalarize_intrinsic_call (e) == SUCCESS)
break;
}
if (t == SUCCESS)
{
m = gfc_intrinsic_func_interface (e, 0);

6
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,9 @@
2007-04-14 Paul Thomas <pault@gcc.gnu.org>
PR fortran/29507
PR fortran/31404
* gfortran.dg/initialization_6.f90: New test.
2007-04-14 Kazu Hirata <kazu@codesourcery.com>
* gcc.c-torture/compile/pr27528.c: Require nonpic.

22
gcc/testsuite/gfortran.dg/initialization_6.f90 Normal file
View File

@ -0,0 +1,22 @@
! { dg-do run }
! { dg-options -O2 }
! Tests the fix for PRs29507 and 31404, where elemental functions in
! initialization expressions could not be simplified with array arguments.
!
! Contributed by Steve Kargl <kargl@gcc.gnu.org >
! and Vivek Rao <vivekrao4@yahoo.com>
!
real, parameter :: a(2,2) = reshape ((/1.0, 2.0, 3.0, 4.0/), (/2,2/))
real, parameter :: b(2,2) = sin (a)
character(8), parameter :: oa(1:3)=(/'nint() ', 'log10() ', 'sqrt() '/)
integer, parameter :: ob(1:3) = index(oa, '(')
character(6), parameter :: ch(3) = (/"animal", "person", "mantee"/)
character(1), parameter :: ch2(3) = (/"n", "r", "t"/)
integer, parameter :: i(3) = index (ch, ch2)
integer :: ic(1) = len_trim((/"a"/))
if (any (reshape (b, (/4/)) .ne. (/(sin(real(k)), k = 1,4)/))) call abort ()
if (any (ob .ne. (/5,6,5/))) call abort () ! Original PR29507
if (any (i .ne. (/2,3,4/))) call abort ()
if (ic(1) .ne. 1) call abort () ! Original PR31404
end