This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
Re: [Patch, Fortran] PR 36322/36463
>> here is a slighty modified version of the patch (triggered by a
>> comment of Tobias), including an additional test case.
>
> Sorry, the test case in the patch was messed up. Here goes the
> corrected version ...
ping!
I'm still waiting for this patch to be approved ...
Updated Changelog:
2008-10-31 Janus Weil <janus@gcc.gnu.org>
PR fortran/36322
PR fortran/36463
* gfortran.h: New function gfc_expr_replace_symbols.
* decl.c (match_procedure_decl): Increase reference count for interface.
* expr.c: New functions replace_symbol and gfc_expr_replace_symbols.
* resolve.c (resolve_symbol): Correctly copy array spec and char len
of PROCEDURE declarations from their interface.
* symbol.c (gfc_get_default_type): Enhanced error message.
(copy_formal_args): Call copy_formal_args recursively for arguments.
* trans-expr.c (gfc_conv_function_call): Bugfix.
2008-10-31 Janus Weil <janus@gcc.gnu.org>
PR fortran/36322
PR fortran/36463
* gfortran.dg/proc_decl_17.f90: New.
* gfortran.dg/proc_decl_18.f90: New.
Index: gcc/testsuite/gfortran.dg/proc_decl_18.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_decl_18.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/proc_decl_18.f90 (revision 0)
@@ -0,0 +1,63 @@
+! { dg-do run }
+!
+! PR 36322/36463
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+module m
+
+contains
+
+ pure integer function mysize(a)
+ integer,intent(in) :: a(:)
+ mysize = size(a)
+ end function
+
+end module
+
+
+program prog
+
+use m
+implicit none
+
+abstract interface
+ function abs_fun(x,sz)
+ integer :: x(:)
+ interface
+ pure integer function sz(b)
+ integer,intent(in) :: b(:)
+ end function
+ end interface
+ integer :: abs_fun(sz(x))
+ end function
+end interface
+
+procedure(abs_fun) :: p
+
+integer :: k,j(3),i(3) = (/1,2,3/)
+
+j = p(i,mysize)
+
+do k=1,mysize(i)
+ if (j(k) /= 2*i(k)) call abort()
+end do
+
+end
+
+ function p(y,asz)
+ implicit none
+ integer,intent(in) :: y(:)
+ interface
+ pure integer function asz(c)
+ integer,intent(in) :: c(:)
+ end function
+ end interface
+ integer :: p(asz(y))
+ integer l
+ do l=1,asz(y)
+ p(l) = y(l)*2
+ end do
+ end function
+
+! { dg-final { cleanup-modules "m" } }
Index: gcc/testsuite/gfortran.dg/proc_decl_17.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_decl_17.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/proc_decl_17.f90 (revision 0)
@@ -0,0 +1,68 @@
+! { dg-do run }
+!
+! PR 36322/36463
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+module m
+
+ use ISO_C_BINDING
+
+ character, allocatable, save :: my_message(:)
+
+ abstract interface
+ function abs_fun(x)
+ use ISO_C_BINDING
+ import my_message
+ integer(C_INT) x(:)
+ character(size(my_message),C_CHAR) abs_fun(size(x))
+ end function abs_fun
+ end interface
+
+contains
+
+ function foo(y)
+ implicit none
+ integer(C_INT) :: y(:)
+ character(size(my_message),C_CHAR) :: foo(size(y))
+ integer i,j
+ do i=1,size(y)
+ do j=1,size(my_message)
+ foo(i)(j:j) = achar(iachar(my_message(j))+y(i))
+ end do
+ end do
+ end function
+
+ subroutine check(p,a)
+ integer a(:)
+ procedure(abs_fun) :: p
+ character(size(my_message),C_CHAR) :: c(size(a))
+ integer k,l,m
+ c = p(a)
+ m=iachar('a')
+ do k=1,size(a)
+ do l=1,size(my_message)
+ if (c(k)(l:l) /= achar(m)) call abort()
+ !print *,c(k)(l:l)
+ m = m + 1
+ end do
+ end do
+ end subroutine
+
+end module
+
+program prog
+
+use m
+
+integer :: i(4) = (/0,6,12,18/)
+
+allocate(my_message(1:6))
+
+my_message = (/'a','b','c','d','e','f'/)
+
+call check(foo,i)
+
+end program
+
+! { dg-final { cleanup-modules "m" } }
Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c (revision 141381)
+++ gcc/fortran/trans-expr.c (working copy)
@@ -2716,7 +2716,8 @@ gfc_conv_function_call (gfc_se * se, gfc
&& parmse.string_length == NULL_TREE
&& e->ts.type == BT_PROCEDURE
&& e->symtree->n.sym->ts.type == BT_CHARACTER
- && e->symtree->n.sym->ts.cl->length != NULL)
+ && e->symtree->n.sym->ts.cl->length != NULL
+ && e->symtree->n.sym->ts.cl->length->expr_type == EXPR_CONSTANT)
{
gfc_conv_const_charlen (e->symtree->n.sym->ts.cl);
parmse.string_length = e->symtree->n.sym->ts.cl->backend_decl;
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c (revision 141381)
+++ gcc/fortran/symbol.c (working copy)
@@ -219,7 +219,7 @@ gfc_get_default_type (gfc_symbol *sym, g
"implicitly typed variables");
if (letter < 'a' || letter > 'z')
- gfc_internal_error ("gfc_get_default_type(): Bad symbol");
+ gfc_internal_error ("gfc_get_default_type(): Bad symbol '%s'",sym->name);
if (ns == NULL)
ns = gfc_current_ns;
@@ -3790,6 +3790,7 @@ copy_formal_args (gfc_symbol *dest, gfc_
formal_arg->sym->attr = curr_arg->sym->attr;
formal_arg->sym->ts = curr_arg->sym->ts;
formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as);
+ copy_formal_args (formal_arg->sym, curr_arg->sym);
/* If this isn't the first arg, set up the next ptr. For the
last arg built, the formal_arg->next will never get set to
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c (revision 141381)
+++ gcc/fortran/decl.c (working copy)
@@ -4125,6 +4125,7 @@ match_procedure_decl (void)
/* Various interface checks. */
if (proc_if)
{
+ proc_if->refs++;
/* Resolve interface if possible. That way, attr.procedure is only set
if it is declared by a later procedure-declaration-stmt, which is
invalid per C1212. */
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (revision 141381)
+++ gcc/fortran/gfortran.h (working copy)
@@ -2448,8 +2448,8 @@ bool gfc_traverse_expr (gfc_expr *, gfc_
bool (*)(gfc_expr *, gfc_symbol *, int*),
int);
void gfc_expr_set_symbols_referenced (gfc_expr *);
-
gfc_try gfc_expr_check_typed (gfc_expr*, gfc_namespace*, bool);
+void gfc_expr_replace_symbols (gfc_expr *, gfc_symbol *);
/* st.c */
extern gfc_code new_st;
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c (revision 141381)
+++ gcc/fortran/expr.c (working copy)
@@ -3487,3 +3487,28 @@ gfc_expr_check_typed (gfc_expr* e, gfc_n
return error_found ? FAILURE : SUCCESS;
}
+
+/* Walk an expression tree and replace all symbols with a corresponding symbol
+ in the formal_ns of "sym". Needed for copying interfaces in PROCEDURE
+ statements. The boolean return value is required by gfc_traverse_expr. */
+
+static bool
+replace_symbol (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED)
+{
+ if ((expr->expr_type == EXPR_VARIABLE || expr->expr_type == EXPR_FUNCTION)
+ && expr->symtree->n.sym->ns != sym->formal_ns
+ && expr->symtree->n.sym->attr.dummy)
+ {
+ gfc_symtree *stree;
+ gfc_get_sym_tree (expr->symtree->name, sym->formal_ns, &stree);
+ stree->n.sym->attr.referenced = expr->symtree->n.sym->attr.referenced;
+ expr->symtree = stree;
+ }
+ return false;
+}
+
+void
+gfc_expr_replace_symbols (gfc_expr *expr, gfc_symbol *dest)
+{
+ gfc_traverse_expr (expr, dest, &replace_symbol, 0);
+}
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (revision 141381)
+++ gcc/fortran/resolve.c (working copy)
@@ -8876,8 +8876,26 @@ resolve_symbol (gfc_symbol *sym)
sym->attr.dimension = ifc->attr.dimension;
sym->attr.recursive = ifc->attr.recursive;
sym->attr.always_explicit = ifc->attr.always_explicit;
- sym->as = gfc_copy_array_spec (ifc->as);
copy_formal_args (sym, ifc);
+ /* Copy array spec. */
+ sym->as = gfc_copy_array_spec (ifc->as);
+ if (sym->as)
+ {
+ int i;
+ for (i = 0; i < sym->as->rank; i++)
+ {
+ gfc_expr_replace_symbols (sym->as->lower[i], sym);
+ gfc_expr_replace_symbols (sym->as->upper[i], sym);
+ }
+ }
+ /* Copy char length. */
+ if (ifc->ts.cl)
+ {
+ sym->ts.cl = gfc_get_charlen();
+ sym->ts.cl->resolved = ifc->ts.cl->resolved;
+ sym->ts.cl->length = gfc_copy_expr (ifc->ts.cl->length);
+ gfc_expr_replace_symbols (sym->ts.cl->length, sym);
+ }
}
else if (sym->ts.interface->name[0] != '\0')
{