OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes]

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

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

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

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

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

From-SVN: r98993
This commit is contained in:
Jakub Jelinek 2005-04-29 17:31:39 +02:00
parent be12e697e4
commit d198b59ab1
18 changed files with 889 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
gcc/fortran/ChangeLog
View 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,

5
gcc/fortran/decl.c
View 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)

3
gcc/fortran/gfortran.h
View 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;

83
gcc/fortran/resolve.c
View 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;

4
gcc/fortran/trans-array.c
View 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);

137
gcc/fortran/trans-decl.c
View 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);

44
gcc/fortran/trans-expr.c
View 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

46
gcc/fortran/trans-types.c
View File

@ -1469,6 +1469,50 @@ gfc_return_by_reference (gfc_symbol * sym)
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);

17
gcc/testsuite/ChangeLog
View 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.

28
gcc/testsuite/gfortran.dg/entry_4.f90 Normal file
View File

@ -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

74
gcc/testsuite/gfortran.fortran-torture/execute/entry_1.f90 Normal file
View File

@ -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

51
gcc/testsuite/gfortran.fortran-torture/execute/entry_2.f90 Normal file
View File

@ -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

40
gcc/testsuite/gfortran.fortran-torture/execute/entry_3.f90 Normal file
View File

@ -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

64
gcc/testsuite/gfortran.fortran-torture/execute/entry_4.f90 Normal file
View File

@ -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

51
gcc/testsuite/gfortran.fortran-torture/execute/entry_5.f90 Normal file
View File

@ -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

109
gcc/testsuite/gfortran.fortran-torture/execute/entry_6.f90 Normal file
View File

@ -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

106
gcc/testsuite/gfortran.fortran-torture/execute/entry_7.f90 Normal file
View File

@ -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

24
gcc/testsuite/gfortran.fortran-torture/execute/entry_8.f90 Normal file
View File

@ -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