aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--gcc/fortran/ChangeLog15
-rw-r--r--gcc/fortran/interface.c22
-rw-r--r--gcc/fortran/trans-intrinsic.c52
-rw-r--r--gcc/testsuite/ChangeLog11
-rw-r--r--gcc/testsuite/gfortran.dg/associated_2.f9015
-rw-r--r--gcc/testsuite/gfortran.dg/dummy_procedure_1.f9047
-rw-r--r--gcc/testsuite/gfortran.dg/dummy_procedure_2.f9033
7 files changed, 168 insertions, 27 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 59da690..a91cb42 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -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
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 74f7669..521876e 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -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
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 9575a31..c361ad4 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -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 (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);
+ /* 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);
+ }
+
se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
}
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index c1f6dec..7743fa0 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -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.
diff --git a/gcc/testsuite/gfortran.dg/associated_2.f90 b/gcc/testsuite/gfortran.dg/associated_2.f90
index 7ef955f..5b8b689 100644
--- a/gcc/testsuite/gfortran.dg/associated_2.f90
+++ b/gcc/testsuite/gfortran.dg/associated_2.f90
@@ -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 \ No newline at end of file
+end
diff --git a/gcc/testsuite/gfortran.dg/dummy_procedure_1.f90 b/gcc/testsuite/gfortran.dg/dummy_procedure_1.f90
new file mode 100644
index 0000000..66aca21
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/dummy_procedure_1.f90
@@ -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" } }
diff --git a/gcc/testsuite/gfortran.dg/dummy_procedure_2.f90 b/gcc/testsuite/gfortran.dg/dummy_procedure_2.f90
new file mode 100644
index 0000000..dd609bd
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/dummy_procedure_2.f90
@@ -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
generated by cgit v1.1 at 2024-11-02 09:44:02 +0000