aboutsummaryrefslogtreecommitdiff
path: root/gcc/fortran/trans-decl.c
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/fortran/trans-decl.c')
-rw-r--r--gcc/fortran/trans-decl.c137
1 files changed, 124 insertions, 13 deletions
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 8620572..d5075b9 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -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);
generated by cgit v1.1 at 2025-05-31 18:52:59 +0000