[multiple changes]

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

	PR fortran/13082
	PR fortran/18824
	* trans-expr.c (gfc_conv_variable): Handle return values in functions
	with alternate entry points.
	* resolve.c (resolve_entries): Remove unnecessary string termination
	after snprintf.  Set result of entry master.
	If all entries have the same type, set entry master's type
	to that common type, otherwise set mixed_entry_master attribute.
	* trans-types.c (gfc_get_mixed_entry_union): New function.
	(gfc_get_function_type): Use it for mixed_entry_master functions.
	* gfortran.h (symbol_attribute): Add mixed_entry_master bit.
	* decl.c (gfc_match_entry): Set entry->result properly for
	function ENTRY.
	* trans-decl.c (gfc_get_symbol_decl): For entry_master, skip over
	__entry argument.
	(build_entry_thunks): Handle return values in entry thunks.
	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.  For mixed_entry_master entries or
	their results, return a COMPONENT_REF of the fake result.
	(gfc_trans_deferred_vars): Don't warn about missing return value if
	at least one entry point uses RESULT.
	(gfc_generate_function_code): For entry master returning
	CHARACTER, copy ts.cl->backend_decl to all entry result syms.
	* trans-array.c (gfc_trans_dummy_array_bias): Don't consider return
	values optional just because they are in entry master.

	* gfortran.dg/entry_4.f90: New test.
	* gfortran.fortran-torture/execute/entry_1.f90: New test.
	* gfortran.fortran-torture/execute/entry_2.f90: New test.
	* gfortran.fortran-torture/execute/entry_3.f90: New test.
	* gfortran.fortran-torture/execute/entry_4.f90: New test.
	* gfortran.fortran-torture/execute/entry_5.f90: New test.
	* gfortran.fortran-torture/execute/entry_6.f90: New test.
	* gfortran.fortran-torture/execute/entry_7.f90: New test.

2005-04-29  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>

	* gfortran.fortran-torture/execute/entry_8.f90: New test.

From-SVN: r98993

1 files changed, 81 insertions, 2 deletions

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index a4667b7..9b097fe 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -360,7 +360,6 @@ resolve_entries (gfc_namespace * ns)
      out what is going on.  */
   snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
 	    master_count++, ns->proc_name->name);
-  name[GFC_MAX_SYMBOL_LEN] = '\0';
   gfc_get_ha_symbol (name, &proc);
   gcc_assert (proc != NULL);
 
@@ -369,8 +368,88 @@ resolve_entries (gfc_namespace * ns)
     gfc_add_subroutine (&proc->attr, proc->name, NULL);
   else
     {
+      gfc_symbol *sym;
+      gfc_typespec *ts, *fts;
+
       gfc_add_function (&proc->attr, proc->name, NULL);
-      gfc_internal_error ("TODO: Functions with alternate entry points");
+      proc->result = proc;
+      fts = &ns->entries->sym->result->ts;
+      if (fts->type == BT_UNKNOWN)
+	fts = gfc_get_default_type (ns->entries->sym->result, NULL);
+      for (el = ns->entries->next; el; el = el->next)
+	{
+	  ts = &el->sym->result->ts;
+	  if (ts->type == BT_UNKNOWN)
+	    ts = gfc_get_default_type (el->sym->result, NULL);
+	  if (! gfc_compare_types (ts, fts)
+	      || (el->sym->result->attr.dimension
+		  != ns->entries->sym->result->attr.dimension)
+	      || (el->sym->result->attr.pointer
+		  != ns->entries->sym->result->attr.pointer))
+	    break;
+	}
+
+      if (el == NULL)
+	{
+	  sym = ns->entries->sym->result;
+	  /* All result types the same.  */
+	  proc->ts = *fts;
+	  if (sym->attr.dimension)
+	    gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
+	  if (sym->attr.pointer)
+	    gfc_add_pointer (&proc->attr, NULL);
+	}
+      else
+	{
+	  /* Otherwise the result will be passed through an union by
+	     reference.  */
+	  proc->attr.mixed_entry_master = 1;
+	  for (el = ns->entries; el; el = el->next)
+	    {
+	      sym = el->sym->result;
+	      if (sym->attr.dimension)
+		gfc_error ("%s result %s can't be an array in FUNCTION %s at %L",
+			   el == ns->entries ? "FUNCTION" : "ENTRY", sym->name,
+			   ns->entries->sym->name, &sym->declared_at);
+	      else if (sym->attr.pointer)
+		gfc_error ("%s result %s can't be a POINTER in FUNCTION %s at %L",
+			   el == ns->entries ? "FUNCTION" : "ENTRY", sym->name,
+			   ns->entries->sym->name, &sym->declared_at);
+	      else
+		{
+		  ts = &sym->ts;
+		  if (ts->type == BT_UNKNOWN)
+		    ts = gfc_get_default_type (sym, NULL);
+		  switch (ts->type)
+		    {
+		    case BT_INTEGER:
+		      if (ts->kind == gfc_default_integer_kind)
+			sym = NULL;
+		      break;
+		    case BT_REAL:
+		      if (ts->kind == gfc_default_real_kind
+			  || ts->kind == gfc_default_double_kind)
+			sym = NULL;
+		      break;
+		    case BT_COMPLEX:
+		      if (ts->kind == gfc_default_complex_kind)
+			sym = NULL;
+		      break;
+		    case BT_LOGICAL:
+		      if (ts->kind == gfc_default_logical_kind)
+			sym = NULL;
+		      break;
+		    default:
+		      break;
+		    }
+		  if (sym)
+		    gfc_error ("%s result %s can't be of type %s in FUNCTION %s at %L",
+			       el == ns->entries ? "FUNCTION" : "ENTRY", sym->name,
+			       gfc_typename (ts), ns->entries->sym->name,
+			       &sym->declared_at);
+		}
+	    }
+	}
     }
   proc->attr.access = ACCESS_PRIVATE;
   proc->attr.entry_master = 1;