[PATCH] Support ENTRY in FUNCTIONs (PR fortran/13082) (take 2)
Jakub Jelinek
jakub@redhat.com
Mon Apr 25 16:54:00 GMT 2005
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
More information about the Gcc-patches
mailing list