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

re PR fortran/25098 (Variable as actual argument for procedure dummy argument allowed) 

2006-06-01  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/25098
	PR fortran/25147
	* interface.c (compare_parameter): Return 1 if the actual arg
	is external and the formal is a procedure.
	(compare_actual_formal): If the actual argument is a variable
	and the formal a procedure, this an error.  If a gsymbol exists
	for a procedure of the same name, this is not yet resolved and
	the error is cleared.

	* trans-intrinsic.c (gfc_conv_associated): Make provision for
	zero array length or zero string length contingent on presence
	of target, for consistency with standard.

2006-06-01  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/25098
	* gfortran.dg/dummy_procedure_1.f90: New test.

	PR fortran/25147
	* gfortran.dg/dummy_procedure_2.f90: New test.

	* gfortran.dg/associated_2.f90: Correct to make consistent with
	standard.

From-SVN: r114296
This commit is contained in:
Paul Thomas 2006-06-01 04:35:38 +00:00
parent 86ce18257f
commit 699fa7aa1a
7 changed files with 169 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
gcc/fortran/ChangeLog
View File

@ -1,3 +1,18 @@
2006-06-01 Paul Thomas <pault@gcc.gnu.org>
PR fortran/25098
PR fortran/25147
* interface.c (compare_parameter): Return 1 if the actual arg
is external and the formal is a procedure.
(compare_actual_formal): If the actual argument is a variable
and the formal a procedure, this an error. If a gsymbol exists
for a procedure of the same name, this is not yet resolved and
the error is cleared.
* trans-intrinsic.c (gfc_conv_associated): Make provision for
zero array length or zero string length contingent on presence
of target, for consistency with standard.
2006-05-30 Asher Langton <langton2@llnl.gov>
* symbol.c (check_conflict): Allow external, function, and

22
gcc/fortran/interface.c
View File

@ -1123,7 +1123,8 @@ compare_parameter (gfc_symbol * formal, gfc_expr * actual,
&& !compare_type_rank (formal, actual->symtree->n.sym))
return 0;
if (formal->attr.if_source == IFSRC_UNKNOWN)
if (formal->attr.if_source == IFSRC_UNKNOWN
|| actual->symtree->n.sym->attr.external)
return 1; /* Assume match */
return compare_interfaces (formal, actual->symtree->n.sym, 0);
@ -1177,6 +1178,7 @@ compare_actual_formal (gfc_actual_arglist ** ap,
{
gfc_actual_arglist **new, *a, *actual, temp;
gfc_formal_arglist *f;
gfc_gsymbol *gsym;
int i, n, na;
bool rank_check;
@ -1276,6 +1278,24 @@ compare_actual_formal (gfc_actual_arglist ** ap,
return 0;
}
/* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
provided for a procedure formal argument. */
if (a->expr->ts.type != BT_PROCEDURE
&& a->expr->expr_type == EXPR_VARIABLE
&& f->sym->attr.flavor == FL_PROCEDURE)
{
gsym = gfc_find_gsymbol (gfc_gsym_root,
a->expr->symtree->n.sym->name);
if (gsym == NULL || (gsym->type != GSYM_FUNCTION
&& gsym->type != GSYM_SUBROUTINE))
{
if (where)
gfc_error ("Expected a procedure for argument '%s' at %L",
f->sym->name, &a->expr->where);
return 0;
}
}
if (f->sym->as
&& f->sym->as->type == AS_ASSUMED_SHAPE
&& a->expr->expr_type == EXPR_VARIABLE

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

@ -2823,23 +2823,6 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
arg2 = arg1->next;
ss1 = gfc_walk_expr (arg1->expr);
nonzero_charlen = NULL_TREE;
if (arg1->expr->ts.type == BT_CHARACTER)
nonzero_charlen = build2 (NE_EXPR, boolean_type_node,
arg1->expr->ts.cl->backend_decl,
integer_zero_node);
nonzero_arraylen = NULL_TREE;
if (ss1 != gfc_ss_terminator)
{
arg1se.descriptor_only = 1;
gfc_conv_expr_lhs (&arg1se, arg1->expr);
tmp = gfc_conv_descriptor_stride (arg1se.expr,
gfc_rank_cst[arg1->expr->rank - 1]);
nonzero_arraylen = build2 (NE_EXPR, boolean_type_node,
tmp, integer_zero_node);
}
if (!arg2->expr)
{
/* No optional target. */
@ -2865,6 +2848,13 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
{
/* An optional target. */
ss2 = gfc_walk_expr (arg2->expr);
nonzero_charlen = NULL_TREE;
if (arg1->expr->ts.type == BT_CHARACTER)
nonzero_charlen = build2 (NE_EXPR, boolean_type_node,
arg1->expr->ts.cl->backend_decl,
integer_zero_node);
if (ss1 == gfc_ss_terminator)
{
/* A pointer to a scalar. */
@ -2878,12 +2868,23 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
}
else
{
/* An array pointer of zero length is not associated if target is
present. */
arg1se.descriptor_only = 1;
gfc_conv_expr_lhs (&arg1se, arg1->expr);
tmp = gfc_conv_descriptor_stride (arg1se.expr,
gfc_rank_cst[arg1->expr->rank - 1]);
nonzero_arraylen = build2 (NE_EXPR, boolean_type_node,
tmp, integer_zero_node);
/* A pointer to an array, call library function _gfor_associated. */
gcc_assert (ss2 != gfc_ss_terminator);
args = NULL_TREE;
arg1se.want_pointer = 1;
gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
args = gfc_chainon_list (args, arg1se.expr);
arg2se.want_pointer = 1;
gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
gfc_add_block_to_block (&se->pre, &arg2se.pre);
@ -2891,15 +2892,18 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
args = gfc_chainon_list (args, arg2se.expr);
fndecl = gfor_fndecl_associated;
se->expr = build_function_call_expr (fndecl, args);
}
}
se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node,
se->expr, nonzero_arraylen);
}
/* If target is present zero character length pointers cannot
be associated. */
if (nonzero_charlen != NULL_TREE)
se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node,
se->expr, nonzero_charlen);
}
if (nonzero_charlen != NULL_TREE)
se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node,
se->expr, nonzero_charlen);
if (nonzero_arraylen != NULL_TREE)
se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node,
se->expr, nonzero_arraylen);
se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
}

11
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,14 @@
2006-06-01 Paul Thomas <pault@gcc.gnu.org>
PR fortran/25098
* gfortran.dg/dummy_procedure_1.f90: New test.
PR fortran/25147
* gfortran.dg/dummy_procedure_2.f90: New test.
* gfortran.dg/associated_2.f90: Correct to make consistent with
standard.
2006-05-31 Roger Sayle <roger@eyesopen.com>
* gcc.target/i386/387-11.c: New test case.

15
gcc/testsuite/gfortran.dg/associated_2.f90
View File

@ -13,26 +13,37 @@ contains
integer, pointer, dimension(:, :, :) :: a, b
allocate (a(2,0,2))
b => a
if (associated (b)) call abort ()
! Even though b is zero length, associated returns true because
! the target argument is not present (case (i))
if (.not. associated (b)) call abort ()
deallocate (a)
allocate (a(2,1,2))
b => a
if (.not.associated (b)) call abort ()
deallocate (a)
end subroutine test1
subroutine test2 ()
integer, pointer, dimension(:, :, :) :: a, b
allocate (a(2,0,2))
b => a
! Associated returns false because target is present (case(iii)).
if (associated (b, a)) call abort ()
deallocate (a)
allocate (a(2,1,2))
b => a
if (.not.associated (b, a)) call abort ()
deallocate (a)
end subroutine test2
subroutine test3 (n)
integer :: n
character(len=n), pointer, dimension(:) :: a, b
allocate (a(2))
b => a
! Again, with zero character length associated returns false
! if target is present.
if (associated (b, a) .and. (n .eq. 0)) call abort ()
!
if ((.not.associated (b, a)) .and. (n .ne. 0)) call abort ()
deallocate (a)
end subroutine test3
end
end

47
gcc/testsuite/gfortran.dg/dummy_procedure_1.f90 Normal file
View File

@ -0,0 +1,47 @@
! { dg-do compile }
! Test the patch for PR25098, where passing a variable as an
! actual argument to a formal argument that is a procedure
! went undiagnosed.
!
! Based on contribution by Joost VandeVondele <jv244@cam.ac.uk>
!
integer function y()
y = 1
end
integer function z()
z = 1
end
module m1
contains
subroutine s1(f)
interface
function f()
integer f
end function f
end interface
end subroutine s1
end module m1
use m1
external y
interface
function x()
integer x
end function x
end interface
integer :: i, y, z
i=1
call s1(i) ! { dg-error "Expected a procedure for argument" }
call s1(w) ! { dg-error "not allowed as an actual argument" }
call s1(x) ! explicit interface
call s1(y) ! declared external
call s1(z) ! already compiled
contains
integer function w()
w = 1
end function w
end
! { dg-final { cleanup-modules "m1" } }

33
gcc/testsuite/gfortran.dg/dummy_procedure_2.f90 Normal file
View File

@ -0,0 +1,33 @@
! { dg-do compile }
! Checks the fix for the bug exposed in fixing PR25147
!
! Contributed by Tobias Schlueter <tobi@gcc.gnu.org>
!
module integrator
interface
function integrate(f,xmin,xmax)
implicit none
interface
function f(x)
real(8) :: f,x
intent(in) :: x
end function f
end interface
real(8) :: xmin, xmax, integrate
end function integrate
end interface
end module integrator
use integrator
call foo1 ()
call foo2 ()
contains
subroutine foo1 ()
real(8) :: f ! This was not trapped: PR25147/25098
print *,integrate (f,0d0,3d0) ! { dg-error "Expected a procedure" }
end subroutine foo1
subroutine foo2 ()
real(8), external :: g ! This would give an error, incorrectly.
print *,integrate (g,0d0,3d0)
end subroutine foo2
end