+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,
|| gfc_add_function (&entry->attr, entry->name, NULL) == FAILURE)
return MATCH_ERROR;
- entry->result = proc->result;
-
+ entry->result = entry;
}
else
{
|| gfc_add_function (&entry->attr, result->name,
NULL) == FAILURE)
return MATCH_ERROR;
+
+ entry->result = result;
}
if (proc->attr.recursive && result == NULL)
/* 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;
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);
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;
/* 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);
{
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. */
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;
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. */
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;
}
}
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;
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)
{
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,
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);
}
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)
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
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)
{
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);
+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.
--- /dev/null
+! { 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
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+ 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
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+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
projects / gcc.git / commitdiff