[Patch, fortran] PR31214 - User-defined operator using entry leads to ICE

[Patch, fortran] PR31214 - User-defined operator using entry leads to ICE

[Paul Thomas]

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

:ADDPATCH fortran:

This was one of those snare and delusion PRs - fixing the reduced 
testcase did not fix the original and I just plain forgot that there was 
an original :-(

The patch is self-explanatory, since I have commented it reasonably 
profusely.  Note that I have moved get_unique_symtree so that symtrees 
pointing to unneeded symbols can be added - this then ensures that they 
are properly cleaned up.  The testcase is based on the original with the 
addition of explicit use of the entry name as a value.

The correction to gfc_show_code_node arose because I kept getting this 
internal error with the PR's testcase..... it took a while to realise 
that it was not my patch!

Also, I noticed that entry_12 did not have the command to clean up the 
module file, so I have included that in the pr.

Regetested on Cygwin_NT/amd64 - OK for trunk?

Paul

2007-08-04  Paul Thomas  <pault@gcc.gnu.org>

    PR fortran/31214
    * symbol.c (get_unique_symtree): Moved from module.c.
    * module.c (get_unique_symtree): Moved to symbol.c.
    * decl.c (get_proc_name): Transfer the typespec from the local
    symbol to the module symbol, in the case that an entry is also
    a module procedure.  Ensure the local symbol is cleaned up by
    pointing to it with a unique symtree.

    * dump_parse_tree (gfc_show_code_node): Add EXEC_ASSIGN_CALL.

2007-08-04  Paul Thomas  <pault@gcc.gnu.org>

    PR fortran/31214
    * gfortran.dg/entry_13.f90: New test.

    * gfortran.dg/entry_12.f90: Clean up .mod file.



[-- Attachment #2: pr31214.diff --]
[-- Type: text/x-patch, Size: 6664 bytes --]

Index: gcc/fortran/symbol.c
===================================================================
*** gcc/fortran/symbol.c	(revision 127107)
--- gcc/fortran/symbol.c	(working copy)
*************** gfc_find_symtree (gfc_symtree *st, const
*** 2130,2135 ****
--- 2130,2149 ----
  }
  
  
+ /* Return a symtree node with a name that is guaranteed to be unique
+    within the namespace and corresponds to an illegal fortran name.  */
+ 
+ gfc_symtree *
+ get_unique_symtree (gfc_namespace *ns)
+ {
+   char name[GFC_MAX_SYMBOL_LEN + 1];
+   static int serial = 0;
+ 
+   sprintf (name, "@%d", serial++);
+   return gfc_new_symtree (&ns->sym_root, name);
+ }
+ 
+ 
  /* Given a name find a user operator node, creating it if it doesn't
     exist.  These are much simpler than symbols because they can't be
     ambiguous with one another.  */
Index: gcc/fortran/decl.c
===================================================================
*** gcc/fortran/decl.c	(revision 127107)
--- gcc/fortran/decl.c	(working copy)
*************** get_proc_name (const char *name, gfc_sym
*** 682,689 ****
--- 682,708 ----
      {
        /* Present if entry is declared to be a module procedure.  */
        rc = gfc_find_symbol (name, gfc_current_ns->parent, 0, result);
+ 
        if (*result == NULL)
  	rc = gfc_get_symbol (name, NULL, result);
+       else if (gfc_get_symbol (name, NULL, &sym) == 0
+ 		 && sym
+ 		 && sym->ts.type != BT_UNKNOWN
+ 		 && (*result)->ts.type == BT_UNKNOWN
+ 		 && sym->attr.flavor == FL_UNKNOWN)
+ 	/* Pick up the typespec for the entry, if declared in the function
+ 	   body.  Note that this symbol is FL_UNKNOWN because it will
+ 	   only have appeared in a type declaration.  The local symtree
+ 	   is set to point to the module symbol and a unique symtree
+ 	   to the local version.  This latter ensures a correct clearing
+ 	   of the symbols.  */
+ 	  {
+ 	    (*result)->ts = sym->ts;
+ 	    gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
+ 	    st->n.sym = *result;
+ 	    st = get_unique_symtree (gfc_current_ns);
+ 	    st->n.sym = sym;
+ 	  }
      }
    else
      rc = gfc_get_symbol (name, gfc_current_ns->parent, result);
Index: gcc/fortran/dump-parse-tree.c
===================================================================
*** gcc/fortran/dump-parse-tree.c	(revision 127107)
--- gcc/fortran/dump-parse-tree.c	(working copy)
*************** gfc_show_code_node (int level, gfc_code 
*** 1085,1090 ****
--- 1085,1091 ----
        break;
  
      case EXEC_CALL:
+     case EXEC_ASSIGN_CALL:
        if (c->resolved_sym)
  	gfc_status ("CALL %s ", c->resolved_sym->name);
        else if (c->symtree)
Index: gcc/fortran/gfortran.h
===================================================================
*** gcc/fortran/gfortran.h	(revision 127107)
--- gcc/fortran/gfortran.h	(working copy)
*************** gfc_expr * gfc_lval_expr_from_sym (gfc_s
*** 2125,2130 ****
--- 2125,2131 ----
  gfc_namespace *gfc_get_namespace (gfc_namespace *, int);
  gfc_symtree *gfc_new_symtree (gfc_symtree **, const char *);
  gfc_symtree *gfc_find_symtree (gfc_symtree *, const char *);
+ gfc_symtree *get_unique_symtree (gfc_namespace *);
  gfc_user_op *gfc_get_uop (const char *);
  gfc_user_op *gfc_find_uop (const char *, gfc_namespace *);
  void gfc_free_symbol (gfc_symbol *);
Index: gcc/fortran/module.c
===================================================================
*** gcc/fortran/module.c	(revision 127107)
--- gcc/fortran/module.c	(working copy)
*************** mio_charlen (gfc_charlen **clp)
*** 1823,1842 ****
  }
  
  
- /* Return a symtree node with a name that is guaranteed to be unique
-    within the namespace and corresponds to an illegal fortran name.  */
- 
- static gfc_symtree *
- get_unique_symtree (gfc_namespace *ns)
- {
-   char name[GFC_MAX_SYMBOL_LEN + 1];
-   static int serial = 0;
- 
-   sprintf (name, "@%d", serial++);
-   return gfc_new_symtree (&ns->sym_root, name);
- }
- 
- 
  /* See if a name is a generated name.  */
  
  static int
--- 1823,1828 ----
Index: gcc/testsuite/gfortran.dg/entry_12.f90
===================================================================
*** gcc/testsuite/gfortran.dg/entry_12.f90	(revision 127108)
--- gcc/testsuite/gfortran.dg/entry_12.f90	(working copy)
*************** END MODULE ksbin1_aux_mod
*** 28,30 ****
--- 28,31 ----
      if (any ((/foo (), bar (99), foobar (), foobar (99), j (), k (99)/) .ne. &
               (/1, 2, 1, 2, 1, 2/))) Call abort ()
  end
+ ! { dg-final { cleanup-modules "ksbin1_aux_mod" } }
Index: gcc/testsuite/gfortran.dg/entry_13.f90
===================================================================
*** gcc/testsuite/gfortran.dg/entry_13.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/entry_13.f90	(revision 0)
***************
*** 0 ****
--- 1,80 ----
+ ! { dg-do run }
+ ! Tests the fix for pr31214, in which the typespec for the entry would be lost,
+ ! thereby causing the function to be disallowed, since the function and entry
+ ! types did not match.
+ !
+ ! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
+ !
+ module type_mod
+   implicit none
+ 
+   type x
+      real x
+   end type x
+   type y
+      real x
+   end type y
+   type z
+      real x
+   end type z
+ 
+   interface assignment(=)
+      module procedure equals
+   end interface assignment(=)
+ 
+   interface operator(//)
+      module procedure a_op_b, b_op_a
+   end interface operator(//)
+ 
+   interface operator(==)
+      module procedure a_po_b, b_po_a
+   end interface operator(==)
+ 
+   contains
+      subroutine equals(x,y)
+         type(z), intent(in) :: y
+         type(z), intent(out) :: x
+ 
+         x%x = y%x
+      end subroutine equals
+ 
+      function a_op_b(a,b)
+         type(x), intent(in) :: a
+         type(y), intent(in) :: b
+         type(z) a_op_b
+         type(z) b_op_a
+         a_op_b%x = a%x + b%x
+         return
+      entry b_op_a(b,a)
+         b_op_a%x = a%x - b%x
+      end function a_op_b
+ 
+      function a_po_b(a,b)
+         type(x), intent(in) :: a
+         type(y), intent(in) :: b
+         type(z) a_po_b
+         type(z) b_po_a
+      entry b_po_a(b,a)
+         a_po_b%x = a%x/b%x
+      end function a_po_b
+ end module type_mod
+ 
+ program test
+   use type_mod
+   implicit none
+   type(x) :: x1 = x(19.0_4)
+   type(y) :: y1 = y(7.0_4)
+   type(z) z1
+ 
+   z1 = x1//y1
+   if (z1%x .ne. 19.0_4 + 7.0_4) call abort ()
+   z1 = y1//x1
+   if (z1%x .ne. 19.0_4 - 7.0_4) call abort ()
+ 
+   z1 = x1==y1
+   if (z1%x .ne. 19.0_4/7.0_4) call abort ()
+   z1 = y1==x1
+   if (z1%x .ne. 19.0_4/7.0_4) call abort ()
+ end program test
+ ! { dg-final { cleanup-modules "type_mod" } }
+ 

Re: [Patch, fortran] PR31214 - User-defined operator using entry leads to ICE

[FX Coudert]

:REVIEWMAIL:

> 2007-08-04  Paul Thomas  <pault@gcc.gnu.org>
>
>    PR fortran/31214
>    * symbol.c (get_unique_symtree): Moved from module.c.
>    * module.c (get_unique_symtree): Moved to symbol.c.
>    * decl.c (get_proc_name): Transfer the typespec from the local
>    symbol to the module symbol, in the case that an entry is also
>    a module procedure.  Ensure the local symbol is cleaned up by
>    pointing to it with a unique symtree.
>    * dump_parse_tree (gfc_show_code_node): Add EXEC_ASSIGN_CALL.

OK

Re: [Patch, fortran] PR31214 - User-defined operator using entry leads to ICE

[Paul Thomas]

..and by the way, I will s/get_unique_symtree/gfc_get_unique_symtree/

Paul
> :ADDPATCH fortran:
>
> This was one of those snare and delusion PRs - fixing the reduced 
> testcase did not fix the original and I just plain forgot that there 
> was an original :-(
>
> The patch is self-explanatory, since I have commented it reasonably 
> profusely.  Note that I have moved get_unique_symtree so that symtrees 
> pointing to unneeded symbols can be added - this then ensures that 
> they are properly cleaned up.  The testcase is based on the original 
> with the addition of explicit use of the entry name as a value.
>
> The correction to gfc_show_code_node arose because I kept getting this 
> internal error with the PR's testcase..... it took a while to realise 
> that it was not my patch!
>
> Also, I noticed that entry_12 did not have the command to clean up the 
> module file, so I have included that in the pr.
>
> Regetested on Cygwin_NT/amd64 - OK for trunk?
>
> Paul
>
> 2007-08-04  Paul Thomas  <pault@gcc.gnu.org>
>
>    PR fortran/31214
>    * symbol.c (get_unique_symtree): Moved from module.c.
>    * module.c (get_unique_symtree): Moved to symbol.c.
>    * decl.c (get_proc_name): Transfer the typespec from the local
>    symbol to the module symbol, in the case that an entry is also
>    a module procedure.  Ensure the local symbol is cleaned up by
>    pointing to it with a unique symtree.
>
>    * dump_parse_tree (gfc_show_code_node): Add EXEC_ASSIGN_CALL.
>
> 2007-08-04  Paul Thomas  <pault@gcc.gnu.org>
>
>    PR fortran/31214
>    * gfortran.dg/entry_13.f90: New test.
>
>    * gfortran.dg/entry_12.f90: Clean up .mod file.
>
>
> ------------------------------------------------------------------------
>
> Index: gcc/fortran/symbol.c
> ===================================================================
> *** gcc/fortran/symbol.c	(revision 127107)
> --- gcc/fortran/symbol.c	(working copy)
> *************** gfc_find_symtree (gfc_symtree *st, const
> *** 2130,2135 ****
> --- 2130,2149 ----
>   }
>   
>   
> + /* Return a symtree node with a name that is guaranteed to be unique
> +    within the namespace and corresponds to an illegal fortran name.  */
> + 
> + gfc_symtree *
> + get_unique_symtree (gfc_namespace *ns)
> + {
> +   char name[GFC_MAX_SYMBOL_LEN + 1];
> +   static int serial = 0;
> + 
> +   sprintf (name, "@%d", serial++);
> +   return gfc_new_symtree (&ns->sym_root, name);
> + }
> + 
> + 
>   /* Given a name find a user operator node, creating it if it doesn't
>      exist.  These are much simpler than symbols because they can't be
>      ambiguous with one another.  */
> Index: gcc/fortran/decl.c
> ===================================================================
> *** gcc/fortran/decl.c	(revision 127107)
> --- gcc/fortran/decl.c	(working copy)
> *************** get_proc_name (const char *name, gfc_sym
> *** 682,689 ****
> --- 682,708 ----
>       {
>         /* Present if entry is declared to be a module procedure.  */
>         rc = gfc_find_symbol (name, gfc_current_ns->parent, 0, result);
> + 
>         if (*result == NULL)
>   	rc = gfc_get_symbol (name, NULL, result);
> +       else if (gfc_get_symbol (name, NULL, &sym) == 0
> + 		 && sym
> + 		 && sym->ts.type != BT_UNKNOWN
> + 		 && (*result)->ts.type == BT_UNKNOWN
> + 		 && sym->attr.flavor == FL_UNKNOWN)
> + 	/* Pick up the typespec for the entry, if declared in the function
> + 	   body.  Note that this symbol is FL_UNKNOWN because it will
> + 	   only have appeared in a type declaration.  The local symtree
> + 	   is set to point to the module symbol and a unique symtree
> + 	   to the local version.  This latter ensures a correct clearing
> + 	   of the symbols.  */
> + 	  {
> + 	    (*result)->ts = sym->ts;
> + 	    gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
> + 	    st->n.sym = *result;
> + 	    st = get_unique_symtree (gfc_current_ns);
> + 	    st->n.sym = sym;
> + 	  }
>       }
>     else
>       rc = gfc_get_symbol (name, gfc_current_ns->parent, result);
> Index: gcc/fortran/dump-parse-tree.c
> ===================================================================
> *** gcc/fortran/dump-parse-tree.c	(revision 127107)
> --- gcc/fortran/dump-parse-tree.c	(working copy)
> *************** gfc_show_code_node (int level, gfc_code 
> *** 1085,1090 ****
> --- 1085,1091 ----
>         break;
>   
>       case EXEC_CALL:
> +     case EXEC_ASSIGN_CALL:
>         if (c->resolved_sym)
>   	gfc_status ("CALL %s ", c->resolved_sym->name);
>         else if (c->symtree)
> Index: gcc/fortran/gfortran.h
> ===================================================================
> *** gcc/fortran/gfortran.h	(revision 127107)
> --- gcc/fortran/gfortran.h	(working copy)
> *************** gfc_expr * gfc_lval_expr_from_sym (gfc_s
> *** 2125,2130 ****
> --- 2125,2131 ----
>   gfc_namespace *gfc_get_namespace (gfc_namespace *, int);
>   gfc_symtree *gfc_new_symtree (gfc_symtree **, const char *);
>   gfc_symtree *gfc_find_symtree (gfc_symtree *, const char *);
> + gfc_symtree *get_unique_symtree (gfc_namespace *);
>   gfc_user_op *gfc_get_uop (const char *);
>   gfc_user_op *gfc_find_uop (const char *, gfc_namespace *);
>   void gfc_free_symbol (gfc_symbol *);
> Index: gcc/fortran/module.c
> ===================================================================
> *** gcc/fortran/module.c	(revision 127107)
> --- gcc/fortran/module.c	(working copy)
> *************** mio_charlen (gfc_charlen **clp)
> *** 1823,1842 ****
>   }
>   
>   
> - /* Return a symtree node with a name that is guaranteed to be unique
> -    within the namespace and corresponds to an illegal fortran name.  */
> - 
> - static gfc_symtree *
> - get_unique_symtree (gfc_namespace *ns)
> - {
> -   char name[GFC_MAX_SYMBOL_LEN + 1];
> -   static int serial = 0;
> - 
> -   sprintf (name, "@%d", serial++);
> -   return gfc_new_symtree (&ns->sym_root, name);
> - }
> - 
> - 
>   /* See if a name is a generated name.  */
>   
>   static int
> --- 1823,1828 ----
> Index: gcc/testsuite/gfortran.dg/entry_12.f90
> ===================================================================
> *** gcc/testsuite/gfortran.dg/entry_12.f90	(revision 127108)
> --- gcc/testsuite/gfortran.dg/entry_12.f90	(working copy)
> *************** END MODULE ksbin1_aux_mod
> *** 28,30 ****
> --- 28,31 ----
>       if (any ((/foo (), bar (99), foobar (), foobar (99), j (), k (99)/) .ne. &
>                (/1, 2, 1, 2, 1, 2/))) Call abort ()
>   end
> + ! { dg-final { cleanup-modules "ksbin1_aux_mod" } }
> Index: gcc/testsuite/gfortran.dg/entry_13.f90
> ===================================================================
> *** gcc/testsuite/gfortran.dg/entry_13.f90	(revision 0)
> --- gcc/testsuite/gfortran.dg/entry_13.f90	(revision 0)
> ***************
> *** 0 ****
> --- 1,80 ----
> + ! { dg-do run }
> + ! Tests the fix for pr31214, in which the typespec for the entry would be lost,
> + ! thereby causing the function to be disallowed, since the function and entry
> + ! types did not match.
> + !
> + ! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
> + !
> + module type_mod
> +   implicit none
> + 
> +   type x
> +      real x
> +   end type x
> +   type y
> +      real x
> +   end type y
> +   type z
> +      real x
> +   end type z
> + 
> +   interface assignment(=)
> +      module procedure equals
> +   end interface assignment(=)
> + 
> +   interface operator(//)
> +      module procedure a_op_b, b_op_a
> +   end interface operator(//)
> + 
> +   interface operator(==)
> +      module procedure a_po_b, b_po_a
> +   end interface operator(==)
> + 
> +   contains
> +      subroutine equals(x,y)
> +         type(z), intent(in) :: y
> +         type(z), intent(out) :: x
> + 
> +         x%x = y%x
> +      end subroutine equals
> + 
> +      function a_op_b(a,b)
> +         type(x), intent(in) :: a
> +         type(y), intent(in) :: b
> +         type(z) a_op_b
> +         type(z) b_op_a
> +         a_op_b%x = a%x + b%x
> +         return
> +      entry b_op_a(b,a)
> +         b_op_a%x = a%x - b%x
> +      end function a_op_b
> + 
> +      function a_po_b(a,b)
> +         type(x), intent(in) :: a
> +         type(y), intent(in) :: b
> +         type(z) a_po_b
> +         type(z) b_po_a
> +      entry b_po_a(b,a)
> +         a_po_b%x = a%x/b%x
> +      end function a_po_b
> + end module type_mod
> + 
> + program test
> +   use type_mod
> +   implicit none
> +   type(x) :: x1 = x(19.0_4)
> +   type(y) :: y1 = y(7.0_4)
> +   type(z) z1
> + 
> +   z1 = x1//y1
> +   if (z1%x .ne. 19.0_4 + 7.0_4) call abort ()
> +   z1 = y1//x1
> +   if (z1%x .ne. 19.0_4 - 7.0_4) call abort ()
> + 
> +   z1 = x1==y1
> +   if (z1%x .ne. 19.0_4/7.0_4) call abort ()
> +   z1 = y1==x1
> +   if (z1%x .ne. 19.0_4/7.0_4) call abort ()
> + end program test
> + ! { dg-final { cleanup-modules "type_mod" } }
> + 
>