[PATCH] Support ENTRY in FUNCTIONs (PR fortran/13082)

[Jakub Jelinek <jakub at redhat dot com>]

Hi!

This patch adds support for ENTRY in FUNCTIONs, though ATM as the first
step only if the result types of all entries match.
Current gfortran supports ENTRY only in SUBROUTINEs.

Non-matching types, such as
        integer function foo ()
        real bar
        foo = 21
        return
        entry bar ()
        bar = 42
        end function
can be handled by creating a union of all result types and returning it
by reference from entry master function, but it will require some more
hacking.

Bootstrapped/regtested on x86_64-redhat-linux.

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

	PR fortran/13082
	* trans.h (current_function_namespace): Declare.
	* trans-expr.c (gfc_conv_variable): Handle return values in functions
	with alternate entry points.
	* resolve.c (resolve_entries): Set result of entry master.
	If all entries have the same type, set entry master's type
	to that common type.
	* decl.c (gfc_match_entry): Set entry->result properly for
	function ENTRY.
	* trans-decl.c (current_function_namespace): New global variable.
	(build_entry_thunks): Save, set and restore
	current_function_namespace.  Handle return values in entry
	thunks if all entries have the same type.  Clear BT_CHARACTER's
	ts.cl->backend_decl, so that it is not shared between multiple
	contexts.
	(gfc_get_fake_result_decl): Use DECL_ARGUMENTS from
	current_function_decl instead of sym->backend_decl.  Skip over
	entry master's entry id argument.
	(gfc_generate_function_code): Save, set and restore
	current_function_namespace.  For entry master returning
	CHARACTER, copy ts.cl->backend_decl to all entry result syms.

	* gfortran.dg/entry_3.f90: New test.
	* gfortran.dg/entry_4.f90: New test.

--- gcc/fortran/trans.h.jj	2005-04-08 13:03:56.000000000 +0200
+++ gcc/fortran/trans.h	2005-04-08 16:18:55.000000000 +0200
@@ -419,6 +419,9 @@ void gfc_get_backend_locus (locus *);
 extern GTY(()) tree gfc_static_ctors;
 void gfc_generate_constructors (void);
 
+/* The namespace of the current function.  */
+extern gfc_namespace *current_function_namespace;
+
 /* Generate a runtime error check.  */
 void gfc_trans_runtime_check (tree, tree, stmtblock_t *);
 
--- gcc/fortran/trans-expr.c.jj	2005-04-08 13:03:56.000000000 +0200
+++ gcc/fortran/trans-expr.c	2005-04-08 16:18:55.000000000 +0200
@@ -308,11 +308,48 @@ gfc_conv_variable (gfc_se * se, gfc_expr
     }
   else
     {
+      tree se_expr = NULL_TREE;
+
       se->expr = gfc_get_symbol_decl (sym);
 
+      /* Special case for assigning the return value of a function.
+	 Self recursive functions must have an explicit return value.  */
+      if (se->expr == current_function_decl && sym->attr.function
+	  && (sym->result == sym))
+	se_expr = gfc_get_fake_result_decl (sym);
+
+      /* Similarly for alternate entry points.  */
+      else if (sym->attr.function && sym->attr.entry
+	       && (sym->result == sym) && current_function_namespace)
+	{
+	  gfc_entry_list *el = NULL;
+
+	  for (el = current_function_namespace->entries; el; el = el->next)
+	    if (sym == el->sym)
+	      {
+		se_expr = gfc_get_fake_result_decl (sym);
+		break;
+	      }
+	}
+
+      else if (sym->attr.result && current_function_namespace
+	       && current_function_namespace->proc_name->attr.entry_master)
+	{
+	  if (current_function_namespace->proc_name->ts.type == BT_UNKNOWN)
+	    {
+	      /* TODO: Handle non-matching returns.  */
+	      gfc_internal_error ("TODO: Functions with alternate entry points with non-matching types");
+	    }
+	  else
+	    se_expr = gfc_get_fake_result_decl (sym);
+	}
+
+      if (se_expr)
+	se->expr = se_expr;
+
       /* Procedure actual arguments.  */
-      if (sym->attr.flavor == FL_PROCEDURE
-	  && se->expr != current_function_decl)
+      else if (sym->attr.flavor == FL_PROCEDURE
+	       && se->expr != current_function_decl)
 	{
 	  gcc_assert (se->want_pointer);
 	  if (!sym->attr.dummy)
@@ -323,14 +360,6 @@ gfc_conv_variable (gfc_se * se, gfc_expr
 	  return;
 	}
 
-      /* Special case for assigning the return value of a function.
-         Self recursive functions must have an explicit return value.  */
-      if (se->expr == current_function_decl && sym->attr.function
-	  && (sym->result == sym))
-	{
-	  se->expr = gfc_get_fake_result_decl (sym);
-	}
-
       /* Dereference scalar dummy variables.  */
       if (sym->attr.dummy
 	  && sym->ts.type != BT_CHARACTER
--- gcc/fortran/resolve.c.jj	2005-04-08 13:03:56.000000000 +0200
+++ gcc/fortran/resolve.c	2005-04-08 16:18:55.000000000 +0200
@@ -370,7 +370,22 @@ resolve_entries (gfc_namespace * ns)
   else
     {
       gfc_add_function (&proc->attr, proc->name, NULL);
-      gfc_internal_error ("TODO: Functions with alternate entry points");
+      proc->result = proc;
+      for (el = ns->entries->next; el; el = el->next)
+	if (! gfc_compare_types (&el->sym->result->ts,
+				 &ns->entries->sym->result->ts))
+	  break;
+
+      if (el == NULL)
+	/* 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");
+	}
     }
   proc->attr.access = ACCESS_PRIVATE;
   proc->attr.entry_master = 1;
--- gcc/fortran/decl.c.jj	2005-04-08 13:03:56.000000000 +0200
+++ gcc/fortran/decl.c	2005-04-08 16:18:55.000000000 +0200
@@ -2407,8 +2407,7 @@ gfc_match_entry (void)
 	      || gfc_add_function (&entry->attr, entry->name, NULL) == FAILURE)
 	    return MATCH_ERROR;
 
-	  entry->result = proc->result;
-
+	  entry->result = entry;
 	}
       else
 	{
@@ -2423,6 +2422,8 @@ gfc_match_entry (void)
 	      || gfc_add_function (&entry->attr, result->name,
 				   NULL) == FAILURE)
 	    return MATCH_ERROR;
+
+	  entry->result = result;
 	}
 
       if (proc->attr.recursive && result == NULL)
--- gcc/fortran/trans-decl.c.jj	2005-04-08 13:03:56.000000000 +0200
+++ gcc/fortran/trans-decl.c	2005-04-08 16:18:55.000000000 +0200
@@ -65,6 +65,11 @@ static GTY(()) tree saved_parent_functio
 static gfc_namespace *module_namespace;
 
 
+/* The namespace of the current function.  */
+
+gfc_namespace *current_function_namespace;
+
+
 /* List of static constructor functions.  */
 
 tree gfc_static_ctors;
@@ -1348,10 +1353,14 @@ build_entry_thunks (gfc_namespace * ns)
   tree string_args;
   tree tmp;
   locus old_loc;
+  gfc_namespace *old_ns;
 
   /* This should always be a toplevel function.  */
   gcc_assert (current_function_decl == NULL_TREE);
 
+  old_ns = current_function_namespace;
+  current_function_namespace = ns;
+
   gfc_get_backend_locus (&old_loc);
   for (el = ns->entries; el; el = el->next)
     {
@@ -1371,10 +1380,20 @@ build_entry_thunks (gfc_namespace * ns)
       args = tree_cons (NULL_TREE, tmp, NULL_TREE);
       string_args = NULL_TREE;
 
-      /* TODO: Pass return by reference parameters.  */
-      if (ns->proc_name->attr.function)
-	gfc_todo_error ("Functons with multiple entry points");
-      
+      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))
+	    {
+	      tree ref = DECL_ARGUMENTS (current_function_decl);
+	      args = tree_cons (NULL_TREE, ref, args);
+	      if (ns->proc_name->ts.type == BT_CHARACTER)
+		args = tree_cons (NULL_TREE, TREE_CHAIN (ref),
+				  args);
+	    }
+	}
+
       for (formal = ns->proc_name->formal; formal; formal = formal->next)
 	{
 	  /* We don't have a clever way of identifying arguments, so resort to
@@ -1415,7 +1434,17 @@ 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);
-      /* TODO: function return value.  */
+      if (thunk_sym->attr.function)
+	{
+	  if (TREE_TYPE (DECL_RESULT (current_function_decl))
+	      != void_type_node)
+	    {
+	      tmp = build2 (MODIFY_EXPR,
+			    TREE_TYPE (DECL_RESULT (current_function_decl)),
+			    DECL_RESULT (current_function_decl), tmp);
+	      tmp = build1_v (RETURN_EXPR, tmp);
+	    }
+	}
       gfc_add_expr_to_block (&body, tmp);
 
       /* Finish off this function and send it for code generation.  */
@@ -1449,9 +1478,19 @@ build_entry_thunks (gfc_namespace * ns)
 	  if (formal->sym->ts.type == BT_CHARACTER)
 	    formal->sym->ts.cl->backend_decl = NULL_TREE;
 	}
+
+      if (thunk_sym->attr.function)
+	{
+	  if (thunk_sym->ts.type == BT_CHARACTER)
+	    thunk_sym->ts.cl->backend_decl = NULL_TREE;
+	  if (thunk_sym->result->ts.type == BT_CHARACTER)
+	    thunk_sym->result->ts.cl->backend_decl = NULL_TREE;
+	}
     }
 
   gfc_set_backend_locus (&old_loc);
+
+  current_function_namespace = old_ns;
 }
 
 
@@ -1499,7 +1538,10 @@ gfc_get_fake_result_decl (gfc_symbol * s
 
   if (gfc_return_by_reference (sym))
     {
-      decl = DECL_ARGUMENTS (sym->backend_decl);
+      decl = DECL_ARGUMENTS (current_function_decl);
+
+      if (current_function_namespace->proc_name->attr.entry_master)
+	decl = TREE_CHAIN (decl);
 
       TREE_USED (decl) = 1;
       if (sym->as)
@@ -2176,6 +2218,7 @@ gfc_generate_function_code (gfc_namespac
   stmtblock_t body;
   tree result;
   gfc_symbol *sym;
+  gfc_namespace *old_ns;
 
   sym = ns->proc_name;
 
@@ -2197,6 +2240,9 @@ gfc_generate_function_code (gfc_namespac
       saved_function_decls = NULL_TREE;
     }
 
+  old_ns = current_function_namespace;
+  current_function_namespace = ns;
+
   trans_function_start (sym);
 
   /* Will be created as needed.  */
@@ -2226,6 +2272,17 @@ gfc_generate_function_code (gfc_namespac
 
   if (ns->entries)
     {
+      if (ns->proc_name->ts.type == BT_CHARACTER)
+	{
+	  /* Copy length backend_decls to all entry point result
+	     symbols.  */
+	  gfc_entry_list *el;
+	  tree backend_decl = ns->proc_name->result->ts.cl->backend_decl;
+
+	  for (el = ns->entries; el; el = el->next)
+	    el->sym->result->ts.cl->backend_decl = backend_decl;
+	}
+
       /* Jump to the correct entry point.  */
       tmp = gfc_trans_entry_master_switch (ns->entries);
       gfc_add_expr_to_block (&body, tmp);
@@ -2305,6 +2362,7 @@ gfc_generate_function_code (gfc_namespac
       saved_function_decls = saved_parent_function_decls;
     }
   current_function_decl = old_context;
+  current_function_namespace = old_ns;
 
   if (decl_function_context (fndecl))
     /* Register this function with cgraph just far enough to get it
--- gcc/testsuite/gfortran.dg/entry_3.f90.jj	2005-04-08 13:24:01.000000000 +0200
+++ gcc/testsuite/gfortran.dg/entry_3.f90	2005-04-08 13:25:00.000000000 +0200
@@ -0,0 +1,57 @@
+! { dg-do run }
+! Test alternate entry points for functions when the result types
+! of all entry points match
+
+	function f1 (a)
+	integer a, b, f1, e1
+	f1 = 15 + a
+	return
+	entry e1 (b)
+	e1 = 42 + b
+	end function
+	function f2 ()
+	real f2, e2
+	entry e2 ()
+	e2 = 45
+	end function
+	function f3 ()
+	double precision a, b, f3, e3
+	entry e3 ()
+	f3 = 47
+	end function
+	function f4 (a) result (r)
+	double precision a, b, r, s
+	r = 15 + a
+	return
+	entry e4 (b) result (s)
+	s = 42 + b
+	end function
+	function f5 () result (r)
+	integer r, s
+	entry e5 () result (s)
+	r = 45
+	end function
+	function f6 () result (r)
+	real r, s
+	entry e6 () result (s)
+	s = 47
+	end function
+
+	program entrytest
+	integer f1, e1, f5, e5
+	real f2, e2, f6, e6
+	double precision f3, e3, f4, e4, d
+	if (f1 (6) .ne. 21) call abort ()
+	if (e1 (7) .ne. 49) call abort ()
+	if (f2 () .ne. 45) call abort ()
+	if (e2 () .ne. 45) call abort ()
+	if (f3 () .ne. 47) call abort ()
+	if (e3 () .ne. 47) call abort ()
+	d = 17
+	if (f4 (d) .ne. 32) call abort ()
+	if (e4 (d) .ne. 59) call abort ()
+	if (f5 () .ne. 45) call abort ()
+	if (e5 () .ne. 45) call abort ()
+	if (f6 () .ne. 47) call abort ()
+	if (e6 () .ne. 47) call abort ()
+	end
--- gcc/testsuite/gfortran.dg/entry_4.f90.jj	2005-04-08 15:42:58.000000000 +0200
+++ gcc/testsuite/gfortran.dg/entry_4.f90	2005-04-08 15:55:50.000000000 +0200
@@ -0,0 +1,32 @@
+! { dg-do run }
+! Test alternate entry points for functions when the result types
+! of all entry points match
+
+	character*(*) function f1 (str, i, j)
+	character str*(*), e1*(*), e2*(*)
+	integer i, j
+	f1 = str (i:j)
+	return
+	entry e1 (str, i, j)
+	i = i + 1
+	entry e2 (str, i, j)
+	j = j - 1
+	e2 = str (i:j)
+	end function
+
+	program entrytest
+	character f1*16, e1*16, e2*16, str*16, ret*16
+	integer i, j
+	str = 'ABCDEFGHIJ'
+	i = 2
+	j = 6
+	ret = f1 (str, i, j)
+	if ((i .ne. 2) .or. (j .ne. 6)) call abort ()
+	if (ret .ne. 'BCDEF') call abort ()
+	ret = e1 (str, i, j)
+	if ((i .ne. 3) .or. (j .ne. 5)) call abort ()
+	if (ret .ne. 'CDE') call abort ()
+	ret = e2 (str, i, j)
+	if ((i .ne. 3) .or. (j .ne. 4)) call abort ()
+	if (ret .ne. 'CD') call abort ()
+	end program

	Jakub