This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC 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]

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


On Wed, Apr 13, 2005 at 11:44:22PM +0200, Tobias Schl?ter wrote:
> Jakub Jelinek wrote:
> > Ok, showstoppers are to be solved first... ;)  See patch below.
> 
> Thank you, unfortunately this fails the slightly modified testcase
>    function c(a) result (d)
>    character*5 :: e, d
>    d = "HALLO"
>    return
>    entry b() result(e)
>    e = "BLUBB"
>    return
>    end function c
> [tobi@marktplatz tests]$ ~/src/gcc-new/build/gcc/f951 entry3.f90
>  c
>  b
>  master.0.c
> 
> entry3.f90:8: internal compiler error: in gfc_conv_string_parameter, at
> fortran/trans-expr.c:2041
> Please submit a full bug report,
> with preprocessed source if appropriate.
> See <URL:http://gcc.gnu.org/bugs.html> for instructions.

Sorry, have been travelling for the last more than a week.
Here is an updated patch, which integrates all previous fortran patches
from me as well as fixes ENTRY handling in functions returning arrays,
more fixes for CHARACTER results and adds a testcase for returning pointers
as well.

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

	PR fortran/13082
	PR fortran/18824
	* 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): 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 (current_function_namespace): New global variable.
	(gfc_get_symbol_decl): For entry_master, skip over __entry argument.
	(build_entry_thunks): Save, set and restore
	current_function_namespace.  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): Save, set and restore
	current_function_namespace.  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 set OPTIONAL_ARG
	just because in entry_master.

	* 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-25  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>

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

--- gcc/fortran/trans.h.jj	2005-04-25 12:18:03.000000000 +0200
+++ gcc/fortran/trans.h	2005-04-25 12:39:04.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-25 12:18:03.000000000 +0200
+++ gcc/fortran/trans-expr.c	2005-04-25 13:21:00.000000000 +0200
@@ -308,11 +308,41 @@ 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
+	       && !gfc_return_by_reference (current_function_namespace->proc_name))
+	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 +353,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-25 12:18:03.000000000 +0200
+++ gcc/fortran/resolve.c	2005-04-25 16:00:21.000000000 +0200
@@ -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,54 @@ resolve_entries (gfc_namespace * ns)
     gfc_add_subroutine (&proc->attr, proc->name, NULL);
   else
     {
+      gfc_symbol *sym;
+
       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)
+	    && (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 = sym->ts;
+	  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)
+	    if ((sym = el->sym->result)->attr.dimension
+		|| sym->attr.pointer
+		|| (sym->ts.type != BT_INTEGER
+		    && sym->ts.type != BT_REAL
+		    && sym->ts.type != BT_COMPLEX
+		    && sym->ts.type != BT_LOGICAL)
+		|| (sym->ts.kind != gfc_default_integer_kind
+		    && sym->ts.kind != gfc_default_real_kind
+		    && sym->ts.kind != gfc_default_double_kind
+		    && sym->ts.kind != gfc_default_complex_kind
+		    && sym->ts.kind != gfc_default_logical_kind))
+	      {
+		gfc_error ("Characteristics of ENTRY results is not the same");
+		gfc_error ("and not scalar non-POINTER either in '%s' at %L",
+			   sym->name,
+			   &sym->declared_at);
+		break;
+	      }
+	}
     }
   proc->attr.access = ACCESS_PRIVATE;
   proc->attr.entry_master = 1;
--- gcc/fortran/trans-types.c.jj	2005-04-25 12:18:03.000000000 +0200
+++ gcc/fortran/trans-types.c	2005-04-25 12:39:04.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/gfortran.h.jj	2005-04-25 12:18:03.000000000 +0200
+++ gcc/fortran/gfortran.h	2005-04-25 12:39:04.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/decl.c.jj	2005-04-25 12:18:03.000000000 +0200
+++ gcc/fortran/decl.c	2005-04-25 12:39:04.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-25 12:18:03.000000000 +0200
+++ gcc/fortran/trans-decl.c	2005-04-25 14:00:26.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;
@@ -736,6 +741,10 @@ gfc_get_symbol_decl (gfc_symbol * sym)
 	{
 	  sym->backend_decl =
 	    DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);
+	  /* For entry master function skip over the __entry
+	     argument.  */
+	  if (sym->ns->proc_name->attr.entry_master)
+	    sym->backend_decl = TREE_CHAIN (sym->backend_decl);
 	}
 
       /* Dummy variables should already have been created.  */
@@ -1348,10 +1357,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,12 +1384,24 @@ 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 (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)
 	{
+	  /* Ignore alternate returns.  */
+	  if (formal->sym == NULL)
+	    continue;
+
 	  /* We don't have a clever way of identifying arguments, so resort to
 	     a brute-force search.  */
 	  for (thunk_formal = thunk_sym->formal;
@@ -1415,7 +1440,47 @@ 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 (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)),
+			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.  */
@@ -1444,14 +1509,25 @@ build_entry_thunks (gfc_namespace * ns)
 	 points and the master function.  Clear them so that they are
 	 recreated for each function.  */
       for (formal = thunk_sym->formal; formal; formal = formal->next)
+	if (formal->sym != NULL)  /* Ignore alternate returns.  */
+	  {
+	    formal->sym->backend_decl = NULL_TREE;
+	    if (formal->sym->ts.type == BT_CHARACTER)
+	      formal->sym->ts.cl->backend_decl = NULL_TREE;
+	  }
+
+      if (thunk_sym->attr.function)
 	{
-	  formal->sym->backend_decl = NULL_TREE;
-	  if (formal->sym->ts.type == BT_CHARACTER)
-	    formal->sym->ts.cl->backend_decl = NULL_TREE;
+	  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;
 }
 
 
@@ -1482,6 +1558,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;
 
@@ -1499,7 +1596,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)
@@ -1916,11 +2016,17 @@ gfc_trans_deferred_vars (gfc_symbol * pr
     {
       if (!current_fake_result_decl)
 	{
-	  warning (0, "Function does not return a value");
-	  return fnbody;
+	  gfc_entry_list *el = NULL;
+	  if (proc_sym->attr.entry_master)
+	    {
+	      for (el = proc_sym->ns->entries; el; el = el->next)
+		if (el->sym != el->sym->result)
+		  break;
+	    }
+	  if (el == NULL)
+	    warning (0, "Function does not return a value");
 	}
-
-      if (proc_sym->as)
+      else if (proc_sym->as)
 	{
 	  fnbody = gfc_trans_dummy_array_bias (proc_sym,
 					       current_fake_result_decl,
@@ -2176,6 +2282,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 +2304,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.  */
@@ -2206,6 +2316,19 @@ gfc_generate_function_code (gfc_namespac
 
   gfc_generate_contained_functions (ns);
 
+  if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
+    {
+      /* Copy length backend_decls to all entry point result
+	 symbols.  */
+      gfc_entry_list *el;
+      tree backend_decl;
+
+      gfc_conv_const_charlen (ns->proc_name->ts.cl);
+      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;
+    }
+
   /* Translate COMMON blocks.  */
   gfc_trans_common (ns);
 
@@ -2305,6 +2428,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/fortran/trans-array.c.jj	2005-03-25 11:37:26.000000000 +0100
+++ gcc/fortran/trans-array.c	2005-04-25 16:04:45.000000000 +0200
@@ -3373,7 +3373,7 @@ gfc_trans_dummy_array_bias (gfc_symbol *
 
   /* Only do the entry/initialization code if the arg is present.  */
   dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
-  optional_arg = sym->attr.optional || sym->ns->proc_name->attr.entry_master;
+  optional_arg = sym->attr.optional;
   if (optional_arg)
     {
       tmp = gfc_conv_expr_present (sym);
--- gcc/testsuite/gfortran.fortran-torture/execute/entry_5.f90.jj	2005-04-25 12:39:04.000000000 +0200
+++ gcc/testsuite/gfortran.fortran-torture/execute/entry_5.f90	2005-04-25 12:39:04.000000000 +0200
@@ -0,0 +1,51 @@
+! Test alternate entry points for functions when the result types
+! of all entry points match
+
+	function f1 (str, i, j) result (r)
+	character str*(*), r1*(*), r2*(*), r*(*)
+	integer i, j
+	r = str (i:j)
+	return
+	entry e1 (str, i, j) result (r1)
+	i = i + 1
+	entry e2 (str, i, j) result (r2)
+	j = j - 1
+	r2 = str (i:j)
+	end function
+
+	function f3 () result (r)
+	character r3*5, r4*5, r*5
+	integer i
+	r = 'ABCDE'
+	return
+	entry e3 (i) result (r3)
+	entry e4 (i) result (r4)
+	if (i .gt. 0) then
+	  r3 = 'abcde'
+	else
+	  r4 = 'UVWXY'
+	endif
+	end function
+
+	program entrytest
+	character f1*16, e1*16, e2*16, str*16, ret*16
+	character f3*5, e3*5, e4*5
+	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 ()
+	if (f3 () .ne. 'ABCDE') call abort ()
+	if (e3 (1) .ne. 'abcde') call abort ()
+	if (e4 (1) .ne. 'abcde') call abort ()
+	if (e3 (0) .ne. 'UVWXY') call abort ()
+	if (e4 (0) .ne. 'UVWXY') call abort ()
+	end program
--- gcc/testsuite/gfortran.fortran-torture/execute/entry_2.f90.jj	2005-04-25 12:39:04.000000000 +0200
+++ gcc/testsuite/gfortran.fortran-torture/execute/entry_2.f90	2005-04-25 12:39:04.000000000 +0200
@@ -0,0 +1,51 @@
+! 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
+
+	character*5 function f3 ()
+	character e3*(*), e4*(*)
+	integer i
+	f3 = 'ABCDE'
+	return
+	entry e3 (i)
+	entry e4 (i)
+	if (i .gt. 0) then
+	  e3 = 'abcde'
+	else
+	  e4 = 'UVWXY'
+	endif
+	end function
+
+	program entrytest
+	character f1*16, e1*16, e2*16, str*16, ret*16
+	character f3*5, e3*5, e4*5
+	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 ()
+	if (f3 () .ne. 'ABCDE') call abort ()
+	if (e3 (1) .ne. 'abcde') call abort ()
+	if (e4 (1) .ne. 'abcde') call abort ()
+	if (e3 (0) .ne. 'UVWXY') call abort ()
+	if (e4 (0) .ne. 'UVWXY') call abort ()
+	end program
--- gcc/testsuite/gfortran.fortran-torture/execute/entry_3.f90.jj	2005-04-25 12:39:04.000000000 +0200
+++ gcc/testsuite/gfortran.fortran-torture/execute/entry_3.f90	2005-04-25 12:39:04.000000000 +0200
@@ -0,0 +1,40 @@
+	subroutine f1 (n, *, i)
+	integer n, i
+	if (i .ne. 42) call abort ()
+	entry e1 (n, *)
+	if (n .eq. 1) return 1
+	if (n .eq. 2) return
+	return
+	entry e2 (n, i, *, *, *)
+	if (i .ne. 46) call abort ()
+	if (n .ge. 4) return
+	return n
+	entry e3 (n, i)
+	if ((i .ne. 48) .or. (n .ne. 61)) call abort ()
+	end subroutine
+
+	program alt_return
+	implicit none
+
+	call f1 (1, *10, 42)
+20	continue
+	call abort ()
+10	continue
+	call f1 (2, *20, 42)
+	call f1 (3, *20, 42)
+	call e1 (2, *20)
+	call e1 (1, *30)
+	call abort ()
+30	continue
+	call e2 (1, 46, *40, *20, *20)
+	call abort ()
+40	continue
+	call e2 (2, 46, *20, *50, *20)
+	call abort ()
+50	continue
+	call e2 (3, 46, *20, *20, *60)
+	call abort ()
+60	continue
+	call e2 (4, 46, *20, *20, *20)
+	call e3 (61, 48)
+	end program
--- gcc/testsuite/gfortran.fortran-torture/execute/entry_7.f90.jj	2005-04-25 17:53:22.000000000 +0200
+++ gcc/testsuite/gfortran.fortran-torture/execute/entry_7.f90	2005-04-25 18:13:57.000000000 +0200
@@ -0,0 +1,106 @@
+! Test alternate entry points for functions when the result types
+! of all entry points match
+
+	function f1 (a)
+	integer a, b
+	integer, pointer :: f1, e1
+	allocate (f1)
+	f1 = 15 + a
+	return
+	entry e1 (b)
+	allocate (e1)
+	e1 = 42 + b
+	end function
+	function f2 ()
+	real, pointer :: f2, e2
+	entry e2 ()
+	allocate (e2)
+	e2 = 45
+	end function
+	function f3 ()
+	double precision, pointer :: f3, e3
+	entry e3 ()
+	allocate (f3)
+	f3 = 47
+	end function
+	function f4 (a) result (r)
+	double precision a, b
+	double precision, pointer :: r, s
+	allocate (r)
+	r = 15 + a
+	return
+	entry e4 (b) result (s)
+	allocate (s)
+	s = 42 + b
+	end function
+	function f5 () result (r)
+	integer, pointer :: r, s
+	entry e5 () result (s)
+	allocate (r)
+	r = 45
+	end function
+	function f6 () result (r)
+	real, pointer :: r, s
+	entry e6 () result (s)
+	allocate (s)
+	s = 47
+	end function
+
+	program entrytest
+	interface
+	function f1 (a)
+	integer a
+	integer, pointer :: f1
+	end function
+	function e1 (b)
+	integer b
+	integer, pointer :: e1
+	end function
+	function f2 ()
+	real, pointer :: f2
+	end function
+	function e2 ()
+	real, pointer :: e2
+	end function
+	function f3 ()
+	double precision, pointer :: f3
+	end function
+	function e3 ()
+	double precision, pointer :: e3
+	end function
+	function f4 (a)
+	double precision a
+	double precision, pointer :: f4
+	end function
+	function e4 (b)
+	double precision b
+	double precision, pointer :: e4
+	end function
+	function f5 ()
+	integer, pointer :: f5
+	end function
+	function e5 ()
+	integer, pointer :: e5
+	end function
+	function f6 ()
+	real, pointer :: f6
+	end function
+	function e6 ()
+	real, pointer :: e6
+	end function
+	end interface
+	double precision 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.fortran-torture/execute/entry_6.f90.jj	2005-04-25 17:45:59.000000000 +0200
+++ gcc/testsuite/gfortran.fortran-torture/execute/entry_6.f90	2005-04-25 17:45:21.000000000 +0200
@@ -0,0 +1,109 @@
+! Test alternate entry points for functions when the result types
+! of all entry points match
+
+	function f1 (a)
+	integer, dimension (2, 2) :: a, b, f1, e1
+	f1 (:, :) = 15 + a (1, 1)
+	return
+	entry e1 (b)
+	e1 (:, :) = 42 + b (1, 1)
+	end function
+	function f2 ()
+	real, dimension (2, 2) :: f2, e2
+	entry e2 ()
+	e2 (:, :) = 45
+	end function
+	function f3 ()
+	double precision, dimension (2, 2) :: a, b, f3, e3
+	entry e3 ()
+	f3 (:, :) = 47
+	end function
+	function f4 (a) result (r)
+	double precision, dimension (2, 2) :: a, b, r, s
+	r (:, :) = 15 + a (1, 1)
+	return
+	entry e4 (b) result (s)
+	s (:, :) = 42 + b (1, 1)
+	end function
+	function f5 () result (r)
+	integer, dimension (2, 2) :: r, s
+	entry e5 () result (s)
+	r (:, :) = 45
+	end function
+	function f6 () result (r)
+	real, dimension (2, 2) :: r, s
+	entry e6 () result (s)
+	s (:, :) = 47
+	end function
+
+	program entrytest
+	interface
+	function f1 (a)
+	integer, dimension (2, 2) :: a, f1
+	end function
+	function e1 (b)
+	integer, dimension (2, 2) :: b, e1
+	end function
+	function f2 ()
+	real, dimension (2, 2) :: f2
+	end function
+	function e2 ()
+	real, dimension (2, 2) :: e2
+	end function
+	function f3 ()
+	double precision, dimension (2, 2) :: f3
+	end function
+	function e3 ()
+	double precision, dimension (2, 2) :: e3
+	end function
+	function f4 (a)
+ 	double precision, dimension (2, 2) :: a, f4
+	end function
+	function e4 (b)
+ 	double precision, dimension (2, 2) :: b, e4
+	end function
+	function f5 ()
+	integer, dimension (2, 2) :: f5
+	end function
+	function e5 ()
+	integer, dimension (2, 2) :: e5
+	end function
+	function f6 ()
+	real, dimension (2, 2) :: f6
+	end function
+	function e6 ()
+	real, dimension (2, 2) :: e6
+	end function
+	end interface
+	integer, dimension (2, 2) :: i, j
+	real, dimension (2, 2) :: r
+	double precision, dimension (2, 2) :: d, e
+	i (:, :) = 6
+	j = f1 (i)
+	if (any (j .ne. 21)) call abort ()
+	i (:, :) = 7
+	j = e1 (i)
+	j (:, :) = 49
+	if (any (j .ne. 49)) call abort ()
+	r = f2 ()
+	if (any (r .ne. 45)) call abort ()
+	r = e2 ()
+	if (any (r .ne. 45)) call abort ()
+	e = f3 ()
+	if (any (e .ne. 47)) call abort ()
+	e = e3 ()
+	if (any (e .ne. 47)) call abort ()
+	d (:, :) = 17
+	e = f4 (d)
+	if (any (e .ne. 32)) call abort ()
+	e = e4 (d)
+	if (any (e .ne. 59)) call abort ()
+	j = f5 ()
+	if (any (j .ne. 45)) call abort ()
+	j = e5 ()
+	if (any (j .ne. 45)) call abort ()
+	r = f6 ()
+	if (any (r .ne. 47)) call abort ()
+	r = e6 ()
+	if (any (r .ne. 47)) call abort ()
+	end
--- gcc/testsuite/gfortran.fortran-torture/execute/entry_4.f90.jj	2005-04-25 12:39:04.000000000 +0200
+++ gcc/testsuite/gfortran.fortran-torture/execute/entry_4.f90	2005-04-25 12:39:04.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
--- gcc/testsuite/gfortran.fortran-torture/execute/entry_1.f90.jj	2005-04-25 12:39:04.000000000 +0200
+++ gcc/testsuite/gfortran.fortran-torture/execute/entry_1.f90	2005-04-25 12:39:04.000000000 +0200
@@ -0,0 +1,56 @@
+! 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.fortran-torture/execute/entry_8.f90.jj	2005-04-25 18:18:23.000000000 +0200
+++ gcc/testsuite/gfortran.fortran-torture/execute/entry_8.f90	2005-04-25 18:17:58.000000000 +0200
@@ -0,0 +1,24 @@
+module m
+type t
+  integer i
+  real x (5)
+end type t
+end module m
+
+function f (i)
+  use m
+  type (t) :: f,g
+  f % i = i
+  return
+  entry g (x)
+  g%x = x
+end function f
+
+use m
+type (t) :: f, g, res
+
+res = f (42)
+if (res%i /= 42) call abort ()
+res = g (1.)
+if (any (res%x /= 1.)) call abort ()
+end


	Jakub


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