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

re PR fortran/50981 ([OOP] Wrong-code for scalarizing ELEMENTAL call with absent OPTIONAL argument)

Browse Source 
PR fortran/50981
	* trans-array.h (gfc_walk_elemental_function_args): New argument.
	* trans-intrinsic.c (gfc_walk_intrinsic_function): Update call.
	* trans-stmt.c (gfc_trans_call): Ditto.
	* trans-array.c (gfc_walk_function_expr): Ditto.
	(gfc_walk_elemental_function_args): Get the dummy argument list
	if possible.  Check that the dummy and the actual argument are both
	optional, and set can_be_null_ref accordingly.

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

From-SVN: r182875
This commit is contained in:
Mikael Morin 2012-01-04 14:20:17 +00:00
parent 0192ef204c
commit 17d038cd90
7 changed files with 138 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
gcc/fortran/ChangeLog
View File

@ -1,3 +1,14 @@
2012-01-04 Mikael Morin <mikael@gcc.gnu.org>
PR fortran/50981
* trans-array.h (gfc_walk_elemental_function_args): New argument.
* trans-intrinsic.c (gfc_walk_intrinsic_function): Update call.
* trans-stmt.c (gfc_trans_call): Ditto.
* trans-array.c (gfc_walk_function_expr): Ditto.
(gfc_walk_elemental_function_args): Get the dummy argument list
if possible. Check that the dummy and the actual argument are both
optional, and set can_be_null_ref accordingly.
2012-01-04 Mikael Morin <mikael@gcc.gnu.org>
PR fortran/50981

42
gcc/fortran/trans-array.c
View File

@ -8307,12 +8307,16 @@ gfc_reverse_ss (gfc_ss * ss)
}
/* Walk the arguments of an elemental function. */
/* Walk the arguments of an elemental function.
PROC_EXPR is used to check whether an argument is permitted to be absent. If
it is NULL, we don't do the check and the argument is assumed to be present.
*/
gfc_ss *
gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
gfc_ss_type type)
gfc_expr *proc_expr, gfc_ss_type type)
{
gfc_formal_arglist *dummy_arg;
int scalar;
gfc_ss *head;
gfc_ss *tail;
@ -8320,6 +8324,28 @@ gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
head = gfc_ss_terminator;
tail = NULL;
if (proc_expr)
{
gfc_ref *ref;
/* Normal procedure case. */
dummy_arg = proc_expr->symtree->n.sym->formal;
/* Typebound procedure case. */
for (ref = proc_expr->ref; ref; ref = ref->next)
{
if (ref->type == REF_COMPONENT
&& ref->u.c.component->attr.proc_pointer
&& ref->u.c.component->ts.interface)
dummy_arg = ref->u.c.component->ts.interface->formal;
else
dummy_arg = NULL;
}
}
else
dummy_arg = NULL;
scalar = 1;
for (; arg; arg = arg->next)
{
@ -8333,6 +8359,13 @@ gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
gcc_assert (type == GFC_SS_SCALAR || type == GFC_SS_REFERENCE);
newss = gfc_get_scalar_ss (head, arg->expr);
newss->info->type = type;
if (dummy_arg != NULL
&& dummy_arg->sym->attr.optional
&& arg->expr->symtree
&& arg->expr->symtree->n.sym->attr.optional
&& arg->expr->ref == NULL)
newss->info->data.scalar.can_be_null_ref = true;
}
else
scalar = 0;
@ -8344,6 +8377,9 @@ gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
while (tail->next != gfc_ss_terminator)
tail = tail->next;
}
if (dummy_arg != NULL)
dummy_arg = dummy_arg->next;
}
if (scalar)
@ -8393,7 +8429,7 @@ gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
by reference. */
if (sym->attr.elemental || (comp && comp->attr.elemental))
return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
GFC_SS_REFERENCE);
expr, GFC_SS_REFERENCE);
/* Scalar functions are OK as these are evaluated outside the scalarization
loop. Pass back and let the caller deal with it. */

2
gcc/fortran/trans-array.h
View File

@ -73,7 +73,7 @@ gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *);
gfc_ss *gfc_walk_array_ref (gfc_ss *, gfc_expr *, gfc_ref * ref);
/* Walk the arguments of an elemental function. */
gfc_ss *gfc_walk_elemental_function_args (gfc_ss *, gfc_actual_arglist *,
gfc_ss_type);
gfc_expr *, gfc_ss_type);
/* Walk an intrinsic function. */
gfc_ss *gfc_walk_intrinsic_function (gfc_ss *, gfc_expr *,
gfc_intrinsic_sym *);

2
gcc/fortran/trans-intrinsic.c
View File

@ -7149,7 +7149,7 @@ gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
if (isym->elemental)
return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
GFC_SS_SCALAR);
NULL, GFC_SS_SCALAR);
if (expr->rank == 0)
return ss;

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

@ -348,7 +348,8 @@ gfc_trans_call (gfc_code * code, bool dependency_check,
ss = gfc_ss_terminator;
if (code->resolved_sym->attr.elemental)
ss = gfc_walk_elemental_function_args (ss, code->ext.actual, GFC_SS_REFERENCE);
ss = gfc_walk_elemental_function_args (ss, code->ext.actual,
code->expr1, GFC_SS_REFERENCE);
/* Is not an elemental subroutine call with array valued arguments. */
if (ss == gfc_ss_terminator)

4
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,7 @@
2012-01-04 Mikael Morin <mikael@gcc.gnu.org>
* gfortran.dg/elemental_optional_args_2.f90: New test.
2012-01-04 Thomas Koenig <tkoenig@gcc.gnu.org>
PR fortran/49693

80
gcc/testsuite/gfortran.dg/elemental_optional_args_2.f90 Normal file
View File

@ -0,0 +1,80 @@
! { dg-do run }
!
! PR fortran/50981
! The program used to dereference a NULL pointer when trying to access
! an optional dummy argument to be passed to an elemental subprocedure.
!
! Original testcase from Andriy Kostyuk <kostyuk@fias.uni-frankfurt.de>
PROGRAM test
IMPLICIT NONE
REAL(KIND=8), DIMENSION(2) :: aa, rr
aa(1)=10.
aa(2)=11.
! WRITE(*,*) 'Both f1 and ff work if the optional parameter is present:'
rr=f1(aa,1)
! WRITE(*,*) ' rr(1)=', rr(1), ' rr(2)=', rr(2)
IF (ANY(rr /= (/ 110, 132 /))) CALL ABORT
rr=0
rr=ff(aa,1)
! WRITE(*,*) ' rr(1)=', rr(1), ' rr(2)=', rr(2)
IF (ANY(rr /= (/ 110, 132 /))) CALL ABORT
! WRITE(*,*) 'But only f1 works if the optional parameter is absent:'
rr=0
rr=f1(aa)
! WRITE(*,*) ' rr(1)=', rr(1), ' rr(2)=', rr(2)
IF (ANY(rr /= (/ 110, 132 /))) CALL ABORT
rr = 0
rr=ff(aa)
! WRITE(*,*) ' rr(1)=', rr(1), ' rr(2)=', rr(2)
IF (ANY(rr /= (/ 110, 132 /))) CALL ABORT
CONTAINS
ELEMENTAL REAL(KIND=8) FUNCTION ff(a,b)
IMPLICIT NONE
REAL(KIND=8), INTENT(IN) :: a
INTEGER, INTENT(IN), OPTIONAL :: b
REAL(KIND=8), DIMENSION(2) :: ac
ac(1)=a
ac(2)=a**2
ff=SUM(gg(ac,b))
END FUNCTION ff
ELEMENTAL REAL(KIND=8) FUNCTION f1(a,b)
IMPLICIT NONE
REAL(KIND=8), INTENT(IN) :: a
INTEGER, INTENT(IN), OPTIONAL :: b
REAL(KIND=8), DIMENSION(2) :: ac
ac(1)=a
ac(2)=a**2
f1=gg(ac(1),b)+gg(ac(2),b) ! This is the same as in ff, but without using the elemental feature of gg
END FUNCTION f1
ELEMENTAL REAL(KIND=8) FUNCTION gg(a,b)
IMPLICIT NONE
REAL(KIND=8), INTENT(IN) :: a
INTEGER, INTENT(IN), OPTIONAL :: b
INTEGER ::b1
IF(PRESENT(b)) THEN
b1=b
ELSE
b1=1
ENDIF
gg=a**b1
END FUNCTION gg
END PROGRAM test