[Patch, Fortran] PR 36322/36463

[Patch, Fortran] PR 36322/36463

[Janus Weil]

[-- Attachment #1: Type: text/plain, Size: 1041 bytes --]

Hi all,

here is a patch which fixes most of the problems in PR36322 and
PR36463. I think it's enough for PR3622 to be closed and for PR36463
not to be called a regression any more (I will keep this one open and
fix the remaining trouble in a follow-up patch). I had several test
cases before, but compressed them all into one. The patch is
regression-tested on i686-pc-linux-gnu. Ok for trunk?

Cheers,
Janus



2008-10-24  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.
	* trans-expr.c (gfc_conv_function_call): Bugfix.

2008-10-24  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/36322
	PR fortran/36463
	* gfortran.dg/proc_decl_17.f90: New.

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: pr36322.diff --]
[-- Type: text/x-patch; name=pr36322.diff, Size: 4365 bytes --]

Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c	(revision 141323)
+++ 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 141323)
+++ 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;
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c	(revision 141323)
+++ 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 141323)
+++ 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 141323)
+++ 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.  */
+
+static bool
+replace_symbol (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED)
+{
+  if (!expr->symtree) return false;
+  if (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 141323)
+++ 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')
 	{

[-- Attachment #3: proc_decl_17.f90 --]
[-- Type: application/octet-stream, Size: 1256 bytes --]

! { 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" } }

Re: [Patch, Fortran] PR 36322/36463

[Paul Richard Thomas]

Janus,

On Fri, Oct 24, 2008 at 11:44 AM, Janus Weil <jaydub66@googlemail.com> wrote:
> Hi all,
>
> here is a patch which fixes most of the problems in PR36322 and
> PR36463. I think it's enough for PR3622 to be closed and for PR36463
> not to be called a regression any more (I will keep this one open and
> fix the remaining trouble in a follow-up patch). I had several test
> cases before, but compressed them all into one. The patch is
> regression-tested on i686-pc-linux-gnu. Ok for trunk?

I now do not have enough time to deal with this until early next week
- if nobody has reviewed it by then, I would be glad so to do.

I have a question, though:  Is this patch not substantially
duplicating the interface mapping that goes on in trans-expr.c?(This
only occurred to me a few minutes ago)

Paul

Re: [Patch, Fortran] PR 36322/36463

[Janus Weil]

Hi Paul,

> I have a question, though:  Is this patch not substantially
> duplicating the interface mapping that goes on in trans-expr.c?(This
> only occurred to me a few minutes ago)

Good question. Actually I was not aware of that mapping code,
therefore it may well be that there is some duplication in my patch
(theoretically).

OTOH, if I understand correctly, the code that you are referring to is
used to map the actual args to the formal args in a function call,
which is of course not what I need to do with my patch, though there
might be similarities.

What one needs to do for "PROCEDURE(i) :: p" is to make a complete
copy of the interface i, including all the formal arguments etc. So it
involves not so much a mapping, as merely a duplication of an
interface, which seems to be quite a difference to me.

But obviously I am not familiar with the mapping code, and so I might
be completely wrong. Maybe there is indeed the possibility to exploit
some of the mapping code for the patch. If you have an idea on how
that could work please let me know. I will try to investigate this.

Cheers,
Janus

Re: [Patch, Fortran] PR 36322/36463

[Janus Weil]

[-- Attachment #1: Type: text/plain, Size: 157 bytes --]

Hi all,

here is a slighty modified version of the patch (triggered by a
comment of Tobias), including an additional test case. Ok for trunk?

Cheers,
Janus

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: pr36322.diff --]
[-- Type: text/x-patch; name=pr36322.diff, Size: 9096 bytes --]

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,136 @@
+! { 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" } }
+! { 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 141361)
+++ 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 141361)
+++ 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 141361)
+++ 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 141361)
+++ 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 141361)
+++ 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 141361)
+++ 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')
 	{

Re: [Patch, Fortran] PR 36322/36463

[Janus Weil]

[-- Attachment #1: Type: text/plain, Size: 224 bytes --]

> 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 ...

Cheers,
Janus

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: pr36322.diff --]
[-- Type: text/x-patch; name=pr36322.diff, Size: 7771 bytes --]

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')
 	{

Re: [Patch, Fortran] PR 36322/36463

[Janus Weil]

[-- Attachment #1: Type: text/plain, Size: 1033 bytes --]

>> 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.

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: pr36322.diff --]
[-- Type: text/x-patch; name=pr36322.diff, Size: 7771 bytes --]

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')
 	{

Re: [Patch, Fortran] PR 36322/36463

[Paul Richard Thomas]

Janus,

Have patience - the few reviewers that there are have daytime jobs too.

This looks OK for trunk, subject a remark being resolved according
unto conscience:

It is conventional to tip a hat to the reporters in the "Contributed
by" line in the test cases, unless the final result is very far
removed from the original.  Whilst I am sure that Tobias and Dominique
just want the bugs fixed, it helps in general if we acknowledge the
reporter.  Your claim to fame is in the Changelog:-)


Cheers

Paul



On Fri, Oct 31, 2008 at 8:40 PM, Janus Weil <jaydub66@googlemail.com> wrote:
>>> 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.
>



-- 
The knack of flying is learning how to throw yourself at the ground and miss.
       --Hitchhikers Guide to the Galaxy

Re: [Patch, Fortran] PR 36322/36463

[Janus Weil]

> This looks OK for trunk, subject a remark being resolved according
> unto conscience:

Committed as r141515, including a mention of James van Buskirk as the
original author in proc_decl_17.f90.

Cheers,
Janus