OSDN Git Service

2005-04-29 Jakub Jelinek <jakub@redhat.com>
authorjakub <jakub@138bc75d-0d04-0410-961f-82ee72b054a4>
Fri, 29 Apr 2005 15:31:39 +0000 (15:31 +0000)
committerjakub <jakub@138bc75d-0d04-0410-961f-82ee72b054a4>
Fri, 29 Apr 2005 15:31:39 +0000 (15:31 +0000)
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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@98993 138bc75d-0d04-0410-961f-82ee72b054a4

18 files changed:
gcc/fortran/ChangeLog
gcc/fortran/decl.c
gcc/fortran/gfortran.h
gcc/fortran/resolve.c
gcc/fortran/trans-array.c
gcc/fortran/trans-decl.c
gcc/fortran/trans-expr.c
gcc/fortran/trans-types.c
gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.dg/entry_4.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.fortran-torture/execute/entry_1.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.fortran-torture/execute/entry_2.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.fortran-torture/execute/entry_3.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.fortran-torture/execute/entry_4.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.fortran-torture/execute/entry_5.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.fortran-torture/execute/entry_6.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.fortran-torture/execute/entry_7.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.fortran-torture/execute/entry_8.f90 [new file with mode: 0644]

index 6b6067c..be24ec7 100644 (file)
@@ -1,3 +1,34 @@
+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.
+
 2005-04-29  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
 
        * gfortran.h (gfc_namespace): Add seen_implicit_none field,
index 4a566a9..2b763d2 100644 (file)
@@ -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)
index e669403..641e492 100644 (file)
@@ -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;
index a4667b7..9b097fe 100644 (file)
@@ -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;
index 2d0bff8..87e37ea 100644 (file)
@@ -3373,7 +3373,9 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
 
   /* 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
+                 || (sym->ns->proc_name->attr.entry_master
+                     && sym->attr.dummy));
   if (optional_arg)
     {
       tmp = gfc_conv_expr_present (sym);
index 8620572..d5075b9 100644 (file)
@@ -736,6 +736,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.  */
@@ -1371,12 +1375,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 +1431,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,10 +1500,19 @@ 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;
        }
     }
 
@@ -1482,6 +1547,29 @@ gfc_get_fake_result_decl (gfc_symbol * sym)
 
   char name[GFC_MAX_SYMBOL_LEN + 10];
 
+  if (sym
+      && sym->ns->proc_name->backend_decl == current_function_decl
+      && sym->ns->proc_name->attr.mixed_entry_master
+      && sym != sym->ns->proc_name)
+    {
+      decl = gfc_get_fake_result_decl (sym->ns->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 +1587,11 @@ gfc_get_fake_result_decl (gfc_symbol * sym)
 
   if (gfc_return_by_reference (sym))
     {
-      decl = DECL_ARGUMENTS (sym->backend_decl);
+      decl = DECL_ARGUMENTS (current_function_decl);
+
+      if (sym->ns->proc_name->backend_decl == current_function_decl
+         && sym->ns->proc_name->attr.entry_master)
+       decl = TREE_CHAIN (decl);
 
       TREE_USED (decl) = 1;
       if (sym->as)
@@ -1916,11 +2008,17 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
     {
       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,
@@ -2206,6 +2304,19 @@ gfc_generate_function_code (gfc_namespace * ns)
 
   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);
 
index 58a0d6e..caf3d75 100644 (file)
@@ -309,11 +309,43 @@ gfc_conv_variable (gfc_se * se, gfc_expr * 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)
+              && sym->ns->proc_name->backend_decl == current_function_decl)
+       {
+         gfc_entry_list *el = NULL;
+
+         for (el = sym->ns->entries; el; el = el->next)
+           if (sym == el->sym)
+             {
+               se_expr = gfc_get_fake_result_decl (sym);
+               break;
+             }
+       }
+
+      else if (sym->attr.result
+              && sym->ns->proc_name->backend_decl == current_function_decl
+              && sym->ns->proc_name->attr.entry_master
+              && !gfc_return_by_reference (sym->ns->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)
@@ -324,14 +356,6 @@ gfc_conv_variable (gfc_se * se, gfc_expr * 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
index 11f17dd..d63917a 100644 (file)
@@ -1469,6 +1469,50 @@ gfc_return_by_reference (gfc_symbol * sym)
   return 0;
 }
 \f
+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;
+}
+\f
 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);
 
index eddf8c9..fda6420 100644 (file)
@@ -1,3 +1,20 @@
+2005-04-29  Jakub Jelinek  <jakub@redhat.com>
+
+       PR fortran/13082
+       PR fortran/18824
+       * 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.
+
 2005-04-29  Paul Brook   <paul@codesourcery.com>
 
        * gfortran.dg/entry_3.f90: New test.
diff --git a/gcc/testsuite/gfortran.dg/entry_4.f90 b/gcc/testsuite/gfortran.dg/entry_4.f90
new file mode 100644 (file)
index 0000000..edc07fb
--- /dev/null
@@ -0,0 +1,28 @@
+! { dg-do compile { target i?86-*-* x86_64-*-* } }
+function f1 () result (r)              ! { dg-error "can't be a POINTER" }
+integer, pointer :: r
+real e1
+allocate (r)
+r = 6
+return
+entry e1 ()
+e1 = 12
+entry e1a ()
+e1a = 13
+end function
+function f2 ()
+integer, dimension (2, 7, 6) :: e2     ! { dg-error "can't be an array" }
+f2 = 6
+return
+entry e2 ()
+e2 (:, :, :) = 2
+end function
+integer*8 function f3 ()               ! { dg-error "can't be of type" }
+complex*16 e3                          ! { dg-error "can't be of type" }
+f3 = 1
+return
+entry e3 ()
+e3 = 2
+entry e3a ()
+e3a = 3
+end function
diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/entry_1.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/entry_1.f90
new file mode 100644 (file)
index 0000000..bef8a98
--- /dev/null
@@ -0,0 +1,74 @@
+! 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
+       function f7 ()
+       entry e7 ()
+       e7 = 163
+       end function
+       function f8 () result (r)
+       entry e8 ()
+       e8 = 115
+       end function
+       function f9 ()
+       entry e9 () result (r)
+       r = 119
+       end function
+
+       program entrytest
+       integer f1, e1, f5, e5
+       real f2, e2, f6, e6, f7, e7, f8, e8, f9, e9
+       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 ()
+       if (f7 () .ne. 163) call abort ()
+       if (e7 () .ne. 163) call abort ()
+       if (f8 () .ne. 115) call abort ()
+       if (e8 () .ne. 115) call abort ()
+       if (f9 () .ne. 119) call abort ()
+       if (e9 () .ne. 119) call abort ()
+       end
diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/entry_2.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/entry_2.f90
new file mode 100644 (file)
index 0000000..5db39db
--- /dev/null
@@ -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
diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/entry_3.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/entry_3.f90
new file mode 100644 (file)
index 0000000..7174fa8
--- /dev/null
@@ -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
diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/entry_4.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/entry_4.f90
new file mode 100644 (file)
index 0000000..f74440c
--- /dev/null
@@ -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
diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/entry_5.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/entry_5.f90
new file mode 100644 (file)
index 0000000..2fd927f
--- /dev/null
@@ -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
diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/entry_6.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/entry_6.f90
new file mode 100644 (file)
index 0000000..a75c513
--- /dev/null
@@ -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
diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/entry_7.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/entry_7.f90
new file mode 100644 (file)
index 0000000..28a8a3f
--- /dev/null
@@ -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
diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/entry_8.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/entry_8.f90
new file mode 100644 (file)
index 0000000..c68d75a
--- /dev/null
@@ -0,0 +1,24 @@
+module entry_8_m
+type t
+  integer i
+  real x (5)
+end type t
+end module entry_8_m
+
+function f (i)
+  use entry_8_m
+  type (t) :: f,g
+  f % i = i
+  return
+  entry g (x)
+  g%x = x
+end function f
+
+use entry_8_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