[PATCH] Support ENTRY with differing types (PR fortran/13082)

[Jakub Jelinek <jakub at redhat dot com>]

Hi!

This patch on top of
http://gcc.gnu.org/ml/gcc-patches/2005-04/msg00855.html
http://gcc.gnu.org/ml/gcc-patches/2005-04/msg00908.html
handles even the mixed type cases.
Bootstrapped/regtested on x86_64-linux.

2005-04-11  Jakub Jelinek  <jakub@redhat.com>

	PR fortran/13082
	* gfortran.h (symbol_attribute): Add mixed_entry_master bit.
	* resolve.c (resolve_entries): Set mixed_entry_master attribute if
	entry result types aren't the same.
	* trans-types.c (gfc_get_mixed_entry_union): New function.
	(gfc_get_function_type): Use it for mixed_entry_master functions.
	* trans-decl.c (build_entry_thunks): Create thunks for
	mixed_entry_master.
	(gfc_get_fake_result_decl): For mixed_entry_master entries or their
	results, return a COMPONENT_REF of the fake result.

--- gcc/fortran/gfortran.h.jj	2005-04-01 09:29:56.000000000 +0200
+++ gcc/fortran/gfortran.h	2005-04-11 11:31:48.000000000 +0200
@@ -431,6 +431,9 @@ typedef struct
   /* Set if this is the master function for a procedure with multiple
      entry points.  */
   unsigned entry_master:1;
+  /* Set if this is the master function for a function with multiple
+     entry points where characteristics of the entry points differ.  */
+  unsigned mixed_entry_master:1;
 
   /* Set if a function must always be referenced by an explicit interface.  */
   unsigned always_explicit:1;
--- gcc/fortran/resolve.c.jj	2005-04-11 09:36:24.000000000 +0200
+++ gcc/fortran/resolve.c	2005-04-11 11:36:35.000000000 +0200
@@ -380,12 +380,9 @@ resolve_entries (gfc_namespace * ns)
 	/* All result types the same.  */
 	proc->ts = ns->entries->sym->result->ts;
       else
-	{
-	  /* Otherwise the result will be passed through an union by
-	     reference.  */
-	  proc->ts.type = BT_UNKNOWN;
-	  gfc_internal_error ("TODO: Functions with alternate entry points with non-matching types");
-	}
+	/* Otherwise the result will be passed through an union by
+	   reference.  */
+	proc->attr.mixed_entry_master = 1;
     }
   proc->attr.access = ACCESS_PRIVATE;
   proc->attr.entry_master = 1;
--- gcc/fortran/trans-types.c.jj	2005-04-01 09:29:56.000000000 +0200
+++ gcc/fortran/trans-types.c	2005-04-11 12:29:53.000000000 +0200
@@ -1469,6 +1469,50 @@ gfc_return_by_reference (gfc_symbol * sy
   return 0;
 }
 
+static tree
+gfc_get_mixed_entry_union (gfc_namespace *ns)
+{
+  tree type;
+  tree decl;
+  tree fieldlist;
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  gfc_entry_list *el, *el2;
+
+  gcc_assert (ns->proc_name->attr.mixed_entry_master);
+  gcc_assert (memcmp (ns->proc_name->name, "master.", 7) == 0);
+
+  snprintf (name, GFC_MAX_SYMBOL_LEN, "munion.%s", ns->proc_name->name + 7);
+
+  /* Build the type node.  */
+  type = make_node (UNION_TYPE);
+
+  TYPE_NAME (type) = get_identifier (name);
+  fieldlist = NULL;
+
+  for (el = ns->entries; el; el = el->next)
+    {
+      /* Search for duplicates.  */
+      for (el2 = ns->entries; el2 != el; el2 = el2->next)
+	if (el2->sym->result == el->sym->result)
+	  break;
+
+      if (el == el2)
+	{
+	  decl = build_decl (FIELD_DECL,
+			     get_identifier (el->sym->result->name),
+			     gfc_sym_type (el->sym->result));
+	  DECL_CONTEXT (decl) = type;
+	  fieldlist = chainon (fieldlist, decl);
+	}
+    }
+
+  /* Finish off the type.  */
+  TYPE_FIELDS (type) = fieldlist;
+
+  gfc_finish_type (type);
+  return type;
+}
+
 tree
 gfc_get_function_type (gfc_symbol * sym)
 {
@@ -1571,6 +1615,8 @@ gfc_get_function_type (gfc_symbol * sym)
     type = integer_type_node;
   else if (!sym->attr.function || gfc_return_by_reference (sym))
     type = void_type_node;
+  else if (sym->attr.mixed_entry_master)
+    type = gfc_get_mixed_entry_union (sym->ns);
   else
     type = gfc_sym_type (sym);
 
--- gcc/fortran/trans-decl.c.jj	2005-04-11 09:25:58.000000000 +0200
+++ gcc/fortran/trans-decl.c	2005-04-11 14:39:24.000000000 +0200
@@ -1382,9 +1382,7 @@ build_entry_thunks (gfc_namespace * ns)
 
       if (thunk_sym->attr.function)
 	{
-	  if (ns->proc_name->ts.type == BT_UNKNOWN)
-	    gfc_internal_error ("TODO: Functions with alternate entry points with non-matching types");
-	  else if (gfc_return_by_reference (ns->proc_name))
+	  if (gfc_return_by_reference (ns->proc_name))
 	    {
 	      tree ref = DECL_ARGUMENTS (current_function_decl);
 	      args = tree_cons (NULL_TREE, ref, args);
@@ -1438,7 +1436,41 @@ build_entry_thunks (gfc_namespace * ns)
       args = chainon (args, nreverse (string_args));
       tmp = ns->proc_name->backend_decl;
       tmp = gfc_build_function_call (tmp, args);
-      if (TREE_TYPE (DECL_RESULT (current_function_decl)) != void_type_node)
+      if (ns->proc_name->attr.mixed_entry_master)
+	{
+	  tree union_decl, field;
+	  tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
+
+	  union_decl = build_decl (VAR_DECL, get_identifier ("__result"),
+				   TREE_TYPE (master_type));
+	  DECL_ARTIFICIAL (union_decl) = 1;
+	  DECL_EXTERNAL (union_decl) = 0;
+	  TREE_PUBLIC (union_decl) = 0;
+	  TREE_USED (union_decl) = 1;
+	  layout_decl (union_decl, 0);
+	  pushdecl (union_decl);
+
+	  DECL_CONTEXT (union_decl) = current_function_decl;
+	  tmp = build2 (MODIFY_EXPR,
+			TREE_TYPE (union_decl),
+			union_decl, tmp);
+	  gfc_add_expr_to_block (&body, tmp);
+
+	  for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
+	       field; field = TREE_CHAIN (field))
+	    if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
+		thunk_sym->result->name) == 0)
+	      break;
+	  gcc_assert (field != NULL_TREE);
+	  tmp = build3 (COMPONENT_REF, TREE_TYPE (field), union_decl, field,
+			NULL_TREE);
+	  tmp = build2 (MODIFY_EXPR,
+			TREE_TYPE (DECL_RESULT (current_function_decl)),
+			DECL_RESULT (current_function_decl), tmp);
+	  tmp = build1_v (RETURN_EXPR, tmp);
+	}
+      else if (TREE_TYPE (DECL_RESULT (current_function_decl))
+	       != void_type_node)
 	{
 	  tmp = build2 (MODIFY_EXPR,
 			TREE_TYPE (DECL_RESULT (current_function_decl)),
@@ -1522,6 +1554,27 @@ gfc_get_fake_result_decl (gfc_symbol * s
 
   char name[GFC_MAX_SYMBOL_LEN + 10];
 
+  if (current_function_namespace->proc_name->attr.mixed_entry_master
+      && sym != current_function_namespace->proc_name)
+    {
+      decl = gfc_get_fake_result_decl (current_function_namespace->proc_name);
+      if (decl)
+	{
+	  tree field;
+
+	  for (field = TYPE_FIELDS (TREE_TYPE (decl));
+	       field; field = TREE_CHAIN (field))
+	    if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
+		sym->name) == 0)
+	      break;
+
+	  gcc_assert (field != NULL_TREE);
+	  decl = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field,
+			 NULL_TREE);
+	}
+      return decl;
+    }
+
   if (current_fake_result_decl != NULL_TREE)
     return current_fake_result_decl;
 
--- gcc/testsuite/gfortran.fortran-torture/execute/entry_2.f90.jj	2005-04-11 13:59:08.000000000 +0200
+++ gcc/testsuite/gfortran.fortran-torture/execute/entry_2.f90	2005-04-11 14:41:50.000000000 +0200
@@ -0,0 +1,64 @@
+! Test alternate entry points for functions when the result types
+! of all entry points don't match
+
+	integer function f1 (a)
+	integer a, b
+	double precision e1
+	f1 = 15 + a
+	return
+	entry e1 (b)
+	e1 = 42 + b
+	end function
+	complex function f2 (a)
+	integer a
+	logical e2
+	entry e2 (a)
+	if (a .gt. 0) then
+	  e2 = a .lt. 46
+	else
+	  f2 = 45
+	endif
+	end function
+	function f3 (a) result (r)
+	integer a, b
+	real r
+	logical s
+	complex c
+	r = 15 + a
+	return
+	entry e3 (b) result (s)
+	s = b .eq. 42
+	return
+	entry g3 (b) result (c)
+	c = b + 11
+	end function
+	function f4 (a) result (r)
+	logical r
+	integer a, s
+	double precision t
+	entry e4 (a) result (s)
+	entry g4 (a) result (t)
+	r = a .lt. 0
+	if (a .eq. 0) s = 16 + a
+	if (a .gt. 0) t = 17 + a
+	end function
+
+	program entrytest
+	integer f1, e4
+	real f3
+	double precision e1, g4
+	logical e2, e3, f4
+	complex f2, g3
+	if (f1 (6) .ne. 21) call abort ()
+	if (e1 (7) .ne. 49) call abort ()
+	if (f2 (0) .ne. 45) call abort ()
+	if (.not. e2 (45)) call abort ()
+	if (e2 (46)) call abort ()
+	if (f3 (17) .ne. 32) call abort ()
+	if (.not. e3 (42)) call abort ()
+	if (e3 (41)) call abort ()
+	if (g3 (12) .ne. 23) call abort ()
+	if (.not. f4 (-5)) call abort ()
+	if (e4 (0) .ne. 16) call abort ()
+	if (g4 (2) .ne. 19) call abort ()
+	end


	Jakub