This is the mail archive of the fortran@gcc.gnu.org mailing list for the GNU Fortran project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

Re: PR 36322/36463


Hi all,

I still haven't managed to get rid of the ICE in testcase5, but I
think I'm getting closer. Attached you find a slightly modified patch,
and a new version of testcase5. The funny thing there is: If
get_funloc is called from within the same module where it is defined,
it gives an ICE, while calling it from a separate program or module
works.

The dump shows the following:

gp ()
{
  get_funloc (make_mess, ..__result);
}

make_mess (character(kind=1)[1:..__result] & __result, integer(kind=4)
.__result, struct array1_integer(kind=4) & y)
{
...
}

get_funloc (void (*<T3bc>) (character(kind=1)[1:.p] &,
integer(kind=4), struct array1_integer(kind=4) &) p, integer(kind=4)
_p)
{
...
}

p ()
{
  static integer(kind=4) options.18[8] = {68, 255, 0, 0, 0, 1, 0, 1};

  _gfortran_set_options (8, (void *) &options.18);
  get_funloc (make_mess);
}

So: The working call inside p looks as expected, while the failing one
in gp has an additional parameter "..__result". The question is just
how and why this gets there. If anybody has some thoughts on this
please let me know ...

Thanks,
Janus
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c	(revision 141303)
+++ 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 141303)
+++ gcc/fortran/gfortran.h	(working copy)
@@ -2450,6 +2450,7 @@ bool gfc_traverse_expr (gfc_expr *, gfc_
 void gfc_expr_set_symbols_referenced (gfc_expr *);
 
 gfc_try gfc_expr_check_typed (gfc_expr*, gfc_namespace*, bool);
+int 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 141303)
+++ gcc/fortran/expr.c	(working copy)
@@ -3487,3 +3487,31 @@ 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)
+{
+  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;
+      i++;
+    }
+  return false;
+}
+
+int
+gfc_expr_replace_symbols (gfc_expr *expr, gfc_symbol *dest)
+{
+  int i = 0;
+  gfc_traverse_expr (expr, dest, &replace_symbol, i);
+  return i;
+}
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 141303)
+++ gcc/fortran/resolve.c	(working copy)
@@ -8864,6 +8864,7 @@ resolve_symbol (gfc_symbol *sym)
       /* Get the attributes from the interface (now resolved).  */
       if (sym->ts.interface->attr.if_source || sym->ts.interface->attr.intrinsic)
 	{
+	  int i;
 	  gfc_symbol *ifc = sym->ts.interface;
 	  sym->ts = ifc->ts;
 	  sym->ts.interface = ifc;
@@ -8876,8 +8877,23 @@ 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)
+	    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: testcase5.f90
Description: Binary data


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]