Skip to content

R
riscv-gcc-1
Commit d198b59a by Jakub Jelinek
Options

[multiple changes] 

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
parent be12e697
Showing with 889 additions and 28 deletions
gcc/fortran/ChangeLog
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> 2005-04-29 Francois-Xavier Coudert <coudert@clipper.ens.fr>
* gfortran.h (gfc_namespace): Add seen_implicit_none field, * gfortran.h (gfc_namespace): Add seen_implicit_none field,
......
gcc/fortran/decl.c
...@@ -2407,8 +2407,7 @@ gfc_match_entry (void) ...@@ -2407,8 +2407,7 @@ gfc_match_entry (void)
|| gfc_add_function (&entry->attr, entry->name, NULL) == FAILURE) || gfc_add_function (&entry->attr, entry->name, NULL) == FAILURE)
return MATCH_ERROR; return MATCH_ERROR;
entry->result = proc->result; entry->result = entry;
} }
else else
{ {
...@@ -2423,6 +2422,8 @@ gfc_match_entry (void) ...@@ -2423,6 +2422,8 @@ gfc_match_entry (void)
|| gfc_add_function (&entry->attr, result->name, || gfc_add_function (&entry->attr, result->name,
NULL) == FAILURE) NULL) == FAILURE)
return MATCH_ERROR; return MATCH_ERROR;
entry->result = result;
} }
if (proc->attr.recursive && result == NULL) if (proc->attr.recursive && result == NULL)
......
gcc/fortran/gfortran.h
...@@ -431,6 +431,9 @@ typedef struct ...@@ -431,6 +431,9 @@ typedef struct
/* Set if this is the master function for a procedure with multiple /* Set if this is the master function for a procedure with multiple
entry points. */ entry points. */
unsigned entry_master:1; 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. */ /* Set if a function must always be referenced by an explicit interface. */
unsigned always_explicit:1; unsigned always_explicit:1;
......
gcc/fortran/resolve.c
...@@ -360,7 +360,6 @@ resolve_entries (gfc_namespace * ns) ...@@ -360,7 +360,6 @@ resolve_entries (gfc_namespace * ns)
out what is going on. */ out what is going on. */
snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s", snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
master_count++, ns->proc_name->name); master_count++, ns->proc_name->name);
name[GFC_MAX_SYMBOL_LEN] = '\0';
gfc_get_ha_symbol (name, &proc); gfc_get_ha_symbol (name, &proc);
gcc_assert (proc != NULL); gcc_assert (proc != NULL);
...@@ -369,8 +368,88 @@ resolve_entries (gfc_namespace * ns) ...@@ -369,8 +368,88 @@ resolve_entries (gfc_namespace * ns)
gfc_add_subroutine (&proc->attr, proc->name, NULL); gfc_add_subroutine (&proc->attr, proc->name, NULL);
else else
{ {
gfc_symbol *sym;
gfc_typespec *ts, *fts;
gfc_add_function (&proc->attr, proc->name, NULL); 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.access = ACCESS_PRIVATE;
proc->attr.entry_master = 1; proc->attr.entry_master = 1;
......
gcc/fortran/trans-array.c
...@@ -3373,7 +3373,9 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) ...@@ -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. */ /* Only do the entry/initialization code if the arg is present. */
dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc); 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) if (optional_arg)
{ {
tmp = gfc_conv_expr_present (sym); tmp = gfc_conv_expr_present (sym);
......
gcc/fortran/trans-decl.c
...@@ -736,6 +736,10 @@ gfc_get_symbol_decl (gfc_symbol * sym) ...@@ -736,6 +736,10 @@ gfc_get_symbol_decl (gfc_symbol * sym)
{ {
sym->backend_decl = sym->backend_decl =
DECL_ARGUMENTS (sym->ns->proc_name->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. */ /* Dummy variables should already have been created. */
...@@ -1371,12 +1375,24 @@ build_entry_thunks (gfc_namespace * ns) ...@@ -1371,12 +1375,24 @@ build_entry_thunks (gfc_namespace * ns)
args = tree_cons (NULL_TREE, tmp, NULL_TREE); args = tree_cons (NULL_TREE, tmp, NULL_TREE);
string_args = NULL_TREE; string_args = NULL_TREE;
/* TODO: Pass return by reference parameters. */ if (thunk_sym->attr.function)
if (ns->proc_name->attr.function) {
gfc_todo_error ("Functons with multiple entry points"); 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) 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 /* We don't have a clever way of identifying arguments, so resort to
a brute-force search. */ a brute-force search. */
for (thunk_formal = thunk_sym->formal; for (thunk_formal = thunk_sym->formal;
...@@ -1415,7 +1431,47 @@ build_entry_thunks (gfc_namespace * ns) ...@@ -1415,7 +1431,47 @@ build_entry_thunks (gfc_namespace * ns)
args = chainon (args, nreverse (string_args)); args = chainon (args, nreverse (string_args));
tmp = ns->proc_name->backend_decl; tmp = ns->proc_name->backend_decl;
tmp = gfc_build_function_call (tmp, args); 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); gfc_add_expr_to_block (&body, tmp);
/* Finish off this function and send it for code generation. */ /* Finish off this function and send it for code generation. */
...@@ -1444,10 +1500,19 @@ build_entry_thunks (gfc_namespace * ns) ...@@ -1444,10 +1500,19 @@ build_entry_thunks (gfc_namespace * ns)
points and the master function. Clear them so that they are points and the master function. Clear them so that they are
recreated for each function. */ recreated for each function. */
for (formal = thunk_sym->formal; formal; formal = formal->next) 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 (thunk_sym->ts.type == BT_CHARACTER)
if (formal->sym->ts.type == BT_CHARACTER) thunk_sym->ts.cl->backend_decl = NULL_TREE;
formal->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) ...@@ -1482,6 +1547,29 @@ gfc_get_fake_result_decl (gfc_symbol * sym)
char name[GFC_MAX_SYMBOL_LEN + 10]; 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) if (current_fake_result_decl != NULL_TREE)
return current_fake_result_decl; return current_fake_result_decl;
...@@ -1499,7 +1587,11 @@ gfc_get_fake_result_decl (gfc_symbol * sym) ...@@ -1499,7 +1587,11 @@ gfc_get_fake_result_decl (gfc_symbol * sym)
if (gfc_return_by_reference (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; TREE_USED (decl) = 1;
if (sym->as) if (sym->as)
...@@ -1916,11 +2008,17 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody) ...@@ -1916,11 +2008,17 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
{ {
if (!current_fake_result_decl) if (!current_fake_result_decl)
{ {
warning (0, "Function does not return a value"); gfc_entry_list *el = NULL;
return fnbody; 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");
} }
else if (proc_sym->as)
if (proc_sym->as)
{ {
fnbody = gfc_trans_dummy_array_bias (proc_sym, fnbody = gfc_trans_dummy_array_bias (proc_sym,
current_fake_result_decl, current_fake_result_decl,
...@@ -2206,6 +2304,19 @@ gfc_generate_function_code (gfc_namespace * ns) ...@@ -2206,6 +2304,19 @@ gfc_generate_function_code (gfc_namespace * ns)
gfc_generate_contained_functions (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. */ /* Translate COMMON blocks. */
gfc_trans_common (ns); gfc_trans_common (ns);
......
gcc/fortran/trans-expr.c
...@@ -309,11 +309,43 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) ...@@ -309,11 +309,43 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
} }
else else
{ {
tree se_expr = NULL_TREE;
se->expr = gfc_get_symbol_decl (sym); 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. */ /* Procedure actual arguments. */
if (sym->attr.flavor == FL_PROCEDURE else if (sym->attr.flavor == FL_PROCEDURE
&& se->expr != current_function_decl) && se->expr != current_function_decl)
{ {
gcc_assert (se->want_pointer); gcc_assert (se->want_pointer);
if (!sym->attr.dummy) if (!sym->attr.dummy)
...@@ -324,14 +356,6 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) ...@@ -324,14 +356,6 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
return; 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. */ /* Dereference scalar dummy variables. */
if (sym->attr.dummy if (sym->attr.dummy
&& sym->ts.type != BT_CHARACTER && sym->ts.type != BT_CHARACTER
......
gcc/fortran/trans-types.c
...@@ -1469,6 +1469,50 @@ gfc_return_by_reference (gfc_symbol * sym) ...@@ -1469,6 +1469,50 @@ gfc_return_by_reference (gfc_symbol * sym)
return 0; 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 tree
gfc_get_function_type (gfc_symbol * sym) gfc_get_function_type (gfc_symbol * sym)
{ {
...@@ -1571,6 +1615,8 @@ gfc_get_function_type (gfc_symbol * sym) ...@@ -1571,6 +1615,8 @@ gfc_get_function_type (gfc_symbol * sym)
type = integer_type_node; type = integer_type_node;
else if (!sym->attr.function || gfc_return_by_reference (sym)) else if (!sym->attr.function || gfc_return_by_reference (sym))
type = void_type_node; type = void_type_node;
else if (sym->attr.mixed_entry_master)
type = gfc_get_mixed_entry_union (sym->ns);
else else
type = gfc_sym_type (sym); type = gfc_sym_type (sym);
......
gcc/testsuite/ChangeLog
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> 2005-04-29 Paul Brook <paul@codesourcery.com>
* gfortran.dg/entry_3.f90: New test. * gfortran.dg/entry_3.f90: New test.
......
gcc/testsuite/gfortran.dg/entry_4.f90 0 → 100644
! { 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
gcc/testsuite/gfortran.fortran-torture/execute/entry_1.f90 0 → 100644
! 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
gcc/testsuite/gfortran.fortran-torture/execute/entry_2.f90 0 → 100644
! 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 0 → 100644
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_4.f90 0 → 100644
! 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_5.f90 0 → 100644
! 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_6.f90 0 → 100644
! 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_7.f90 0 → 100644
! 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_8.f90 0 → 100644
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
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment