Commit c6acea9d by Janus Weil

re PR fortran/36322 (ICE with PROCEDURE using a complicated interface)

2008-11-01  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-11-01  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.

From-SVN: r141515
parent 002bd9f0
2008-11-01 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-11-01 Dennis Wassel <dennis.wassel@gmail.com>
PR fortran/37159
......
......@@ -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. */
......
......@@ -3502,3 +3502,28 @@ gfc_expr_check_typed (gfc_expr* e, gfc_namespace* ns, bool strict)
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);
}
......@@ -2448,8 +2448,8 @@ bool gfc_traverse_expr (gfc_expr *, gfc_symbol *,
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;
......
......@@ -8917,8 +8917,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')
{
......
......@@ -219,7 +219,7 @@ gfc_get_default_type (gfc_symbol *sym, gfc_namespace *ns)
"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_symbol *src)
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
......
......@@ -2716,7 +2716,8 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
&& 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;
......
2008-11-01 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.
2008-11-01 Richard Guenther <rguenther@suse.de>
PR middle-end/37976
......
! { dg-do run }
!
! PR 36322/36463
!
! Original code by James Van Buskirk.
! Modified 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()
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" } }
! { 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" } }
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment