[PATCH] Fix gfortran ICE with a call to alternate return subroutine

[Jakub Jelinek <jakub at redhat dot com>]

Hi!

The testcase below ICEs at any optimization level.
There are 2 problems:
1) gfc_trans_call/gfc_conv_function_call use a global
   has_alternate_specifier variable, but it is only cleared in
   gfc_trans_call before gfc_conv_function_call call, but
   gfc_conv_function_call is called from other places too.
   So, if there is a call to a subroutine and label address is
   passed to it, followed later on by some function call,
   gfc_conv_function_call modifies that function's return address
   from its actuall return type to integer_type_node, as nothing
   cleared the has_alternate_specifier flag
2) build_function_type uses a hash table to share function types,
   so changing the return type in place is a bad thing

To fix 1), my understanding is that label addresses can be only
passed to subroutines and therefore should not be nested.  This means
we really don't need a global variable and just can return the flag
in gfc_conv_function_call's return value.

Ok for 4.0/HEAD?

2005-05-23  Jakub Jelinek  <jakub@redhat.com>

	* trans-expr.c (gfc_conv_function_call): Return int instead of
	void.  Use a local variable for has_alternate_specifier and
	return it.  Avoid modification of function type's return value
	in place, since it may be shared.
	* trans.h (has_alternate_specifier): Remove.
	(gfc_conv_function_call): Change return type.
	* trans-stmt.c (has_alternate_specifier): Remove.
	(gfc_trans_call): Add a local has_alternate_specifier variable,
	set it from gfc_conv_function_call return value.

	* gfortran.dg/altreturn_1.f90: New test.

--- gcc/fortran/trans-expr.c.jj	2005-05-23 13:23:06.000000000 +0200
+++ gcc/fortran/trans-expr.c	2005-05-23 14:53:39.000000000 +0200
@@ -1059,9 +1059,10 @@ gfc_conv_function_val (gfc_se * se, gfc_
 
 
 /* Generate code for a procedure call.  Note can return se->post != NULL.
-   If se->direct_byref is set then se->expr contains the return parameter.  */
+   If se->direct_byref is set then se->expr contains the return parameter.
+   Return non-zero, if the call has alternate specifiers.  */
 
-void
+int
 gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 			gfc_actual_arglist * arg)
 {
@@ -1077,6 +1078,7 @@ gfc_conv_function_call (gfc_se * se, gfc
   tree len;
   tree stringargs;
   gfc_formal_arglist *formal;
+  int has_alternate_specifier = 0;
 
   arglist = NULL_TREE;
   stringargs = NULL_TREE;
@@ -1097,7 +1099,7 @@ gfc_conv_function_call (gfc_se * se, gfc
               /* Access the previously obtained result.  */
               gfc_conv_tmp_array_ref (se);
               gfc_advance_se_ss_chain (se);
-              return;
+              return 0;
             }
 	}
       info = &se->ss->data.info;
@@ -1245,9 +1247,17 @@ gfc_conv_function_call (gfc_se * se, gfc
   /* Generate the actual call.  */
   gfc_conv_function_val (se, sym);
   /* If there are alternate return labels, function type should be
-     integer.  */
-  if (has_alternate_specifier)
-    TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
+     integer.  Can't modify the type in place though, since it can be shared
+     with other functions.  */
+  if (has_alternate_specifier
+      && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
+    {
+      gcc_assert (! sym->attr.dummy);
+      TREE_TYPE (sym->backend_decl)
+        = build_function_type (integer_type_node,
+                               TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
+      se->expr = gfc_build_addr_expr (NULL, sym->backend_decl);
+    }
 
   fntype = TREE_TYPE (TREE_TYPE (se->expr));
   se->expr = build3 (CALL_EXPR, TREE_TYPE (fntype), se->expr,
@@ -1312,6 +1322,8 @@ gfc_conv_function_call (gfc_se * se, gfc
 	    }
 	}
     }
+
+  return has_alternate_specifier;
 }
 
 
--- gcc/fortran/trans.h.jj	2005-04-29 09:36:07.000000000 +0200
+++ gcc/fortran/trans.h	2005-05-23 13:56:02.000000000 +0200
@@ -301,7 +301,7 @@ void gfc_conv_intrinsic_function (gfc_se
 int gfc_is_intrinsic_libcall (gfc_expr *);
 
 /* Also used to CALL subroutines.  */
-void gfc_conv_function_call (gfc_se *, gfc_symbol *, gfc_actual_arglist *);
+int gfc_conv_function_call (gfc_se *, gfc_symbol *, gfc_actual_arglist *);
 /* gfc_trans_* shouldn't call push/poplevel, use gfc_push/pop_scope */
 
 /* Generate code for a scalar assignment.  */
@@ -574,7 +574,4 @@ struct lang_decl		GTY(())
                                           arg1, arg2)
 #define build3_v(code, arg1, arg2, arg3) build3(code, void_type_node, \
                                                 arg1, arg2, arg3)
-
-/* flag for alternative return labels.  */
-extern int has_alternate_specifier;  /* for caller */
 #endif /* GFC_TRANS_H */
--- gcc/fortran/trans-stmt.c.jj	2005-05-19 09:31:31.000000000 +0200
+++ gcc/fortran/trans-stmt.c	2005-05-23 14:07:55.000000000 +0200
@@ -37,8 +37,6 @@ Software Foundation, 59 Temple Place - S
 #include "trans-const.h"
 #include "arith.h"
 
-int has_alternate_specifier;
-
 typedef struct iter_info
 {
   tree var;
@@ -206,6 +204,7 @@ tree
 gfc_trans_call (gfc_code * code)
 {
   gfc_se se;
+  int has_alternate_specifier;
 
   /* A CALL starts a new block because the actual arguments may have to
      be evaluated first.  */
@@ -213,10 +212,10 @@ gfc_trans_call (gfc_code * code)
   gfc_start_block (&se.pre);
 
   gcc_assert (code->resolved_sym);
-  has_alternate_specifier = 0;
 
   /* Translate the call.  */
-  gfc_conv_function_call (&se, code->resolved_sym, code->ext.actual);
+  has_alternate_specifier
+    = gfc_conv_function_call (&se, code->resolved_sym, code->ext.actual);
 
   /* A subroutine without side-effect, by definition, does nothing!  */
   TREE_SIDE_EFFECTS (se.expr) = 1;
--- gcc/testsuite/gfortran.dg/altreturn_1.f90.jj	2005-05-23 15:02:18.000000000 +0200
+++ gcc/testsuite/gfortran.dg/altreturn_1.f90	2005-05-23 15:02:50.000000000 +0200
@@ -0,0 +1,7 @@
+! { dg-do compile }
+	subroutine foo (a)
+	real t, a, baz
+	call bar (*10)
+	t = 2 * baz ()
+	IF (t.gt.0) t = baz ()
+10	END

	Jakub