diff options
| -rw-r--r-- | gcc/fortran/ChangeLog | 48 | ||||
| -rw-r--r-- | gcc/fortran/decl.c | 78 | ||||
| -rw-r--r-- | gcc/fortran/dump-parse-tree.c | 5 | ||||
| -rw-r--r-- | gcc/fortran/gfortran.h | 44 | ||||
| -rw-r--r-- | gcc/fortran/module.c | 21 | ||||
| -rw-r--r-- | gcc/fortran/parse.c | 10 | ||||
| -rw-r--r-- | gcc/fortran/resolve.c | 218 | ||||
| -rw-r--r-- | gcc/fortran/st.c | 2 | ||||
| -rw-r--r-- | gcc/fortran/symbol.c | 8 | ||||
| -rw-r--r-- | gcc/fortran/trans-array.c | 6 | ||||
| -rw-r--r-- | gcc/fortran/trans-decl.c | 381 | ||||
| -rw-r--r-- | gcc/fortran/trans-stmt.c | 8 | ||||
| -rw-r--r-- | gcc/fortran/trans-stmt.h | 1 | ||||
| -rw-r--r-- | gcc/fortran/trans-types.c | 7 | ||||
| -rw-r--r-- | gcc/fortran/trans.c | 6 | ||||
| -rw-r--r-- | gcc/fortran/trans.h | 2 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 5 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/entry_1.f90 | 44 |
18 files changed, 718 insertions, 176 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index e0d97f2..e8af227 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,51 @@ +2004-08-17 Paul Brook <paul@codesourcery.com> + Tobias Schlueter <tobias.schlueter@physik.uni-muenchen.de> + + PR fortran/13082 + * decl.c (get_proc_name): Update mystery comment. + (gfc_match_entry): Check for errors earlier. Add entry point to list. + * dump-parse-tree.c (gfc_show_code_node): Print EXEC_ENTRY nodes. + * gfortran.h (symbol_attribute): Add entry_master. Document entry. + (struct gfc_entry_list): Define. + (gfc_get_entry_list): Define. + (struct gfc_namespace): Add refs and entries. + (enum gfc_exec_op): Add EXEC_ENTRY. + (struct gfc_code): Add ext.entry. + * module.c (ab_attribute, attr_bits): Remove AB_ENTRY. + (mio_symbol_attribute): Don't save/reture addr->entry. + (mio_namespace_ref): Refcount namespaces. + * parse.c (accept_statement): Handle ST_ENTRY. + (gfc_fixup_sibling_symbols): Mark symbol as referenced. + (parse_contained): Fixup sibling references to entry points + after parsing the procedure body. + * resolve.c (resolve_contained_fntype): New function. + (merge_argument_lists, resolve_entries): New functions. + (resolve_contained_functions): Use them. + (resolve_code): Handle EXEC_ENTRY. + (gfc_resolve): Call resolve_entries. + * st.c (gfc_free_statement): Handle EXEC_ENTRY. + * symbol.c (gfc_get_namespace): Refcount namespaces. + (gfc_free_namespace): Ditto. + * trans-array.c (gfc_trans_dummy_array_bias): Treat all args as + optional when multiple entry points are present. + * trans-decl.c (gfc_get_symbol_decl): Remove incorrect check. + (gfc_get_extern_function_decl): Add assertion. Fix coment. + (create_function_arglist, trans_function_start, build_entry_thunks): + New functions. + (gfc_build_function_decl): Rename ... + (build_function_decl): ... to this. + (gfc_create_function_decl): New function. + (gfc_generate_contained_functions): Use it. + (gfc_trans_entry_master_switch): New function. + (gfc_generate_function_code): Use new functions. + * trans-stmt.c (gfc_trans_entry): New function. + * trans-stmt.h (gfc_trans_entry): Add prototype. + * trans-types.c (gfc_get_function_type): Add entry point argument. + * trans.c (gfc_trans_code): Handle EXEC_ENTRY. + (gfc_generate_module_code): Call gfc_create_function_decl. + * trans.h (gfc_build_function_decl): Remove. + (gfc_create_function_decl): Add prototype. + 2004-08-15 Andrew Pinski <apinski@apple.com> PR fortran/17030 diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 3a78efc..e00a614 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -186,7 +186,7 @@ get_proc_name (const char *name, gfc_symbol ** result) if (*result == NULL) return rc; - /* Deal with ENTRY problem */ + /* ??? Deal with ENTRY problem */ st = gfc_new_symtree (&gfc_current_ns->sym_root, name); @@ -1871,44 +1871,59 @@ cleanup: match gfc_match_entry (void) { - gfc_symbol *function, *result, *entry; + gfc_symbol *proc; + gfc_symbol *result; + gfc_symbol *entry; char name[GFC_MAX_SYMBOL_LEN + 1]; gfc_compile_state state; match m; + gfc_entry_list *el; m = gfc_match_name (name); if (m != MATCH_YES) return m; + state = gfc_current_state (); + if (state != COMP_SUBROUTINE + && state != COMP_FUNCTION) + { + gfc_error ("ENTRY statement at %C cannot appear within %s", + gfc_state_name (gfc_current_state ())); + return MATCH_ERROR; + } + + if (gfc_current_ns->parent != NULL + && gfc_current_ns->parent->proc_name + && gfc_current_ns->parent->proc_name->attr.flavor != FL_MODULE) + { + gfc_error("ENTRY statement at %C cannot appear in a " + "contained procedure"); + return MATCH_ERROR; + } + if (get_proc_name (name, &entry)) return MATCH_ERROR; - gfc_enclosing_unit (&state); - switch (state) + proc = gfc_current_block (); + + if (state == COMP_SUBROUTINE) { - case COMP_SUBROUTINE: + /* And entry in a subroutine. */ m = gfc_match_formal_arglist (entry, 0, 1); if (m != MATCH_YES) return MATCH_ERROR; - if (gfc_current_state () != COMP_SUBROUTINE) - goto exec_construct; - if (gfc_add_entry (&entry->attr, NULL) == FAILURE || gfc_add_subroutine (&entry->attr, NULL) == FAILURE) return MATCH_ERROR; - - break; - - case COMP_FUNCTION: + } + else + { + /* An entry in a function. */ m = gfc_match_formal_arglist (entry, 0, 0); if (m != MATCH_YES) return MATCH_ERROR; - if (gfc_current_state () != COMP_FUNCTION) - goto exec_construct; - function = gfc_state_stack->sym; - result = NULL; if (gfc_match_eos () == MATCH_YES) @@ -1917,12 +1932,12 @@ gfc_match_entry (void) || gfc_add_function (&entry->attr, NULL) == FAILURE) return MATCH_ERROR; - entry->result = function->result; + entry->result = proc->result; } else { - m = match_result (function, &result); + m = match_result (proc, &result); if (m == MATCH_NO) gfc_syntax_error (ST_ENTRY); if (m != MATCH_YES) @@ -1934,16 +1949,11 @@ gfc_match_entry (void) return MATCH_ERROR; } - if (function->attr.recursive && result == NULL) + if (proc->attr.recursive && result == NULL) { gfc_error ("RESULT attribute required in ENTRY statement at %C"); return MATCH_ERROR; } - - break; - - default: - goto exec_construct; } if (gfc_match_eos () != MATCH_YES) @@ -1952,13 +1962,23 @@ gfc_match_entry (void) return MATCH_ERROR; } - return MATCH_YES; + entry->attr.recursive = proc->attr.recursive; + entry->attr.elemental = proc->attr.elemental; + entry->attr.pure = proc->attr.pure; -exec_construct: - gfc_error ("ENTRY statement at %C cannot appear within %s", - gfc_state_name (gfc_current_state ())); + el = gfc_get_entry_list (); + el->sym = entry; + el->next = gfc_current_ns->entries; + gfc_current_ns->entries = el; + if (el->next) + el->id = el->next->id + 1; + else + el->id = 1; - return MATCH_ERROR; + new_st.op = EXEC_ENTRY; + new_st.ext.entry = el; + + return MATCH_YES; } diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index 1c948d9..e5e56db 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -800,12 +800,17 @@ gfc_show_code_node (int level, gfc_code * c) gfc_status ("CONTINUE"); break; + case EXEC_ENTRY: + gfc_status ("ENTRY %s", c->ext.entry->sym->name); + break; + case EXEC_ASSIGN: gfc_status ("ASSIGN "); gfc_show_expr (c->expr); gfc_status_char (' '); gfc_show_expr (c->expr2); break; + case EXEC_LABEL_ASSIGN: gfc_status ("LABEL ASSIGN "); gfc_show_expr (c->expr); diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 80cdbbe..4585161 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -386,7 +386,7 @@ typedef struct /* Variable attributes. */ unsigned allocatable:1, dimension:1, external:1, intrinsic:1, optional:1, pointer:1, save:1, target:1, - dummy:1, result:1, entry:1, assign:1; + dummy:1, result:1, assign:1; unsigned data:1, /* Symbol is named in a DATA statement. */ use_assoc:1; /* Symbol has been use-associated. */ @@ -399,6 +399,14 @@ typedef struct unsigned sequence:1, elemental:1, pure:1, recursive:1; unsigned unmaskable:1, masked:1, contained:1; + /* Set if this procedure is an alternate entry point. These procedures + don't have any code associated, and the backend will turn them into + thunks to the master function. */ + unsigned entry:1; + /* Set if this is the master function for a procedure with multiple + entry points. */ + unsigned entry_master:1; + /* Set if a function must always be referenced by an explicit interface. */ unsigned always_explicit:1; @@ -668,7 +676,6 @@ typedef struct gfc_symbol struct gfc_namespace *ns; /* namespace containing this symbol */ tree backend_decl; - } gfc_symbol; @@ -687,6 +694,23 @@ gfc_common_head; #define gfc_get_common_head() gfc_getmem(sizeof(gfc_common_head)) +/* A list of all the alternate entry points for a procedure. */ + +typedef struct gfc_entry_list +{ + /* The symbol for this entry point. */ + gfc_symbol *sym; + /* The zero-based id of this entry point. */ + int id; + /* The LABEL_EXPR marking this entry point. */ + tree label; + /* The nest item in the list. */ + struct gfc_entry_list *next; +} +gfc_entry_list; + +#define gfc_get_entry_list() \ + (gfc_entry_list *) gfc_getmem(sizeof(gfc_entry_list)) /* Within a namespace, symbols are pointed to by symtree nodes that are linked together in a balanced binary tree. There can be @@ -712,6 +736,10 @@ typedef struct gfc_symtree gfc_symtree; +/* A namespace describes the contents of procedure, module or + interface block. */ +/* ??? Anything else use these? */ + typedef struct gfc_namespace { /* Tree containing all the symbols in this namespace. */ @@ -755,6 +783,14 @@ typedef struct gfc_namespace gfc_charlen *cl_list; int save_all, seen_save; + + /* Normally we don't need to refcount namespaces. However when we read + a module containing a function with multiple entry points, this + will appear as several functions with the same formal namespace. */ + int refs; + + /* A list of all alternate entry points to this procedure (or NULL). */ + gfc_entry_list *entries; } gfc_namespace; @@ -1204,7 +1240,8 @@ gfc_forall_iterator; typedef enum { EXEC_NOP = 1, EXEC_ASSIGN, EXEC_LABEL_ASSIGN, EXEC_POINTER_ASSIGN, - EXEC_GOTO, EXEC_CALL, EXEC_RETURN, EXEC_PAUSE, EXEC_STOP, EXEC_CONTINUE, + EXEC_GOTO, EXEC_CALL, EXEC_RETURN, EXEC_ENTRY, + EXEC_PAUSE, EXEC_STOP, EXEC_CONTINUE, EXEC_IF, EXEC_ARITHMETIC_IF, EXEC_DO, EXEC_DO_WHILE, EXEC_SELECT, EXEC_FORALL, EXEC_WHERE, EXEC_CYCLE, EXEC_EXIT, EXEC_ALLOCATE, EXEC_DEALLOCATE, @@ -1243,6 +1280,7 @@ typedef struct gfc_code gfc_forall_iterator *forall_iterator; struct gfc_code *whichloop; int stop_code; + gfc_entry_list *entry; } ext; /* Points to additional structures required by statement */ diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index a9d0fa6..cd41e66 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -1367,7 +1367,7 @@ mio_internal_string (char *string) typedef enum { AB_ALLOCATABLE, AB_DIMENSION, AB_EXTERNAL, AB_INTRINSIC, AB_OPTIONAL, AB_POINTER, AB_SAVE, AB_TARGET, AB_DUMMY, AB_RESULT, - AB_ENTRY, AB_DATA, AB_IN_NAMELIST, AB_IN_COMMON, + AB_DATA, AB_IN_NAMELIST, AB_IN_COMMON, AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE, AB_ELEMENTAL, AB_PURE, AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT } @@ -1385,7 +1385,6 @@ static const mstring attr_bits[] = minit ("TARGET", AB_TARGET), minit ("DUMMY", AB_DUMMY), minit ("RESULT", AB_RESULT), - minit ("ENTRY", AB_ENTRY), minit ("DATA", AB_DATA), minit ("IN_NAMELIST", AB_IN_NAMELIST), minit ("IN_COMMON", AB_IN_COMMON), @@ -1455,8 +1454,7 @@ mio_symbol_attribute (symbol_attribute * attr) MIO_NAME(ab_attribute) (AB_DUMMY, attr_bits); if (attr->result) MIO_NAME(ab_attribute) (AB_RESULT, attr_bits); - if (attr->entry) - MIO_NAME(ab_attribute) (AB_ENTRY, attr_bits); + /* We deliberately don't preserve the "entry" flag. */ if (attr->data) MIO_NAME(ab_attribute) (AB_DATA, attr_bits); @@ -1529,9 +1527,6 @@ mio_symbol_attribute (symbol_attribute * attr) case AB_RESULT: attr->result = 1; break; - case AB_ENTRY: - attr->entry = 1; - break; case AB_DATA: attr->data = 1; break; @@ -2628,10 +2623,16 @@ mio_namespace_ref (gfc_namespace ** nsp) if (p->type == P_UNKNOWN) p->type = P_NAMESPACE; - if (iomode == IO_INPUT && p->integer != 0 && p->u.pointer == NULL) + if (iomode == IO_INPUT && p->integer != 0) { - ns = gfc_get_namespace (NULL); - associate_integer_pointer (p, ns); + ns = (gfc_namespace *)p->u.pointer; + if (ns == NULL) + { + ns = gfc_get_namespace (NULL); + associate_integer_pointer (p, ns); + } + else + ns->refs++; } } diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index bd74139..abc3c29 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -1076,6 +1076,7 @@ accept_statement (gfc_statement st) break; + case ST_ENTRY: case_executable: case_exec_markers: add_statement (); @@ -2140,6 +2141,7 @@ gfc_fixup_sibling_symbols (gfc_symbol * sym, gfc_namespace * siblings) gfc_symtree *st; gfc_symbol *old_sym; + sym->attr.referenced = 1; for (ns = siblings; ns; ns = ns->sibling) { gfc_find_sym_tree (sym->name, ns, 0, &st); @@ -2174,6 +2176,7 @@ parse_contained (int module) gfc_state_data s1, s2; gfc_statement st; gfc_symbol *sym; + gfc_entry_list *el; push_state (&s1, COMP_CONTAINS, NULL); parent_ns = gfc_current_ns; @@ -2234,10 +2237,13 @@ parse_contained (int module) sym->attr.contained = 1; sym->attr.referenced = 1; + parse_progunit (ST_NONE); + /* Fix up any sibling functions that refer to this one. */ gfc_fixup_sibling_symbols (sym, gfc_current_ns); - - parse_progunit (ST_NONE); + /* Or refer to any of its alternate entry points. */ + for (el = gfc_current_ns->entries; el; el = el->next) + gfc_fixup_sibling_symbols (el->sym, gfc_current_ns); gfc_current_ns->code = s2.head; gfc_current_ns = parent_ns; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 00d9e3d..1dc4db8 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -247,6 +247,162 @@ resolve_formal_arglists (gfc_namespace * ns) } +static void +resolve_contained_fntype (gfc_symbol * sym, gfc_namespace * ns) +{ + try t; + + /* If this namespace is not a function, ignore it. */ + if (! sym + || !(sym->attr.function + || sym->attr.flavor == FL_VARIABLE)) + return; + + /* Try to find out of what type the function is. If there was an + explicit RESULT clause, try to get the type from it. If the + function is never defined, set it to the implicit type. If + even that fails, give up. */ + if (sym->result != NULL) + sym = sym->result; + + if (sym->ts.type == BT_UNKNOWN) + { + /* Assume we can find an implicit type. */ + t = SUCCESS; + + if (sym->result == NULL) + t = gfc_set_default_type (sym, 0, ns); + else + { + if (sym->result->ts.type == BT_UNKNOWN) + t = gfc_set_default_type (sym->result, 0, NULL); + + sym->ts = sym->result->ts; + } + + if (t == FAILURE) + gfc_error ("Contained function '%s' at %L has no IMPLICIT type", + sym->name, &sym->declared_at); /* FIXME */ + } +} + + +/* Add NEW_ARGS to the formal argument list of PROC, taking care not to + introduce duplicates. */ + +static void +merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args) +{ + gfc_formal_arglist *f, *new_arglist; + gfc_symbol *new_sym; + + for (; new_args != NULL; new_args = new_args->next) + { + new_sym = new_args->sym; + /* See if ths arg is already in the formal argument list. */ + for (f = proc->formal; f; f = f->next) + { + if (new_sym == f->sym) + break; + } + + if (f) + continue; + + /* Add a new argument. Argument order is not important. */ + new_arglist = gfc_get_formal_arglist (); + new_arglist->sym = new_sym; + new_arglist->next = proc->formal; + proc->formal = new_arglist; + } +} + + +/* Resolve alternate entry points. If a symbol has multiple entry points we + create a new master symbol for the main routine, and turn the existing + symbol into an entry point. */ + +static void +resolve_entries (gfc_namespace * ns) +{ + gfc_namespace *old_ns; + gfc_code *c; + gfc_symbol *proc; + gfc_entry_list *el; + char name[GFC_MAX_SYMBOL_LEN + 1]; + static int master_count = 0; + + if (ns->proc_name == NULL) + return; + + /* No need to do anything if this procedure doesn't have alternate entry + points. */ + if (!ns->entries) + return; + + /* We may already have resolved alternate entry points. */ + if (ns->proc_name->attr.entry_master) + return; + + /* If this isn't a procedure something as gone horribly wrong. */ + assert (ns->proc_name->attr.flavor == FL_PROCEDURE); + + /* Remember the current namespace. */ + old_ns = gfc_current_ns; + + gfc_current_ns = ns; + + /* Add the main entry point to the list of entry points. */ + el = gfc_get_entry_list (); + el->sym = ns->proc_name; + el->id = 0; + el->next = ns->entries; + ns->entries = el; + ns->proc_name->attr.entry = 1; + + /* Add an entry statement for it. */ + c = gfc_get_code (); + c->op = EXEC_ENTRY; + c->ext.entry = el; + c->next = ns->code; + ns->code = c; + + /* Create a new symbol for the master function. */ + /* Give the internal function a unique name (within this file). + Also include teh function name so the user has some hope of figuring + out whats 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); + assert (proc != NULL); + + gfc_add_procedure (&proc->attr, PROC_INTERNAL, NULL); + if (ns->proc_name->attr.subroutine) + gfc_add_subroutine (&proc->attr, NULL); + else + { + gfc_add_function (&proc->attr, NULL); + gfc_internal_error ("TODO: Functions with alternate entry points"); + } + proc->attr.access = ACCESS_PRIVATE; + proc->attr.entry_master = 1; + + /* Merge all the entry point arguments. */ + for (el = ns->entries; el; el = el->next) + merge_argument_lists (proc, el->sym->formal); + + /* And use it for the function body. */ + ns->proc_name = proc; + + /* FInalize the new symbols. */ + gfc_commit_symbols (); + + /* Restore the original namespace. */ + gfc_current_ns = old_ns; +} + + /* Resolve contained function types. Because contained functions can call one another, they have to be worked out before any of the contained procedures can be resolved. @@ -259,65 +415,20 @@ resolve_formal_arglists (gfc_namespace * ns) static void resolve_contained_functions (gfc_namespace * ns) { - gfc_symbol *contained_sym, *sym_lower; gfc_namespace *child; - try t; + gfc_entry_list *el; resolve_formal_arglists (ns); for (child = ns->contained; child; child = child->sibling) { - sym_lower = child->proc_name; - - /* If this namespace is not a function, ignore it. */ - if (! sym_lower - || !( sym_lower->attr.function - || sym_lower->attr.flavor == FL_VARIABLE)) - continue; - - /* Find the contained symbol in the current namespace. */ - gfc_find_symbol (sym_lower->name, ns, 0, &contained_sym); - - if (contained_sym == NULL) - gfc_internal_error ("resolve_contained_functions(): Contained " - "function not found in parent namespace"); - - /* Try to find out of what type the function is. If there was an - explicit RESULT clause, try to get the type from it. If the - function is never defined, set it to the implicit type. If - even that fails, give up. */ - if (sym_lower->result != NULL) - sym_lower = sym_lower->result; - - if (sym_lower->ts.type == BT_UNKNOWN) - { - /* Assume we can find an implicit type. */ - t = SUCCESS; - - if (sym_lower->result == NULL) - t = gfc_set_default_type (sym_lower, 0, child); - else - { - if (sym_lower->result->ts.type == BT_UNKNOWN) - t = gfc_set_default_type (sym_lower->result, 0, NULL); - - sym_lower->ts = sym_lower->result->ts; - } - - if (t == FAILURE) - gfc_error ("Contained function '%s' at %L has no IMPLICIT type", - sym_lower->name, &sym_lower->declared_at); /* FIXME */ - } + /* Resolve alternate entry points first. */ + resolve_entries (child); - /* If the symbol in the parent of the contained namespace is not - the same as the one in contained namespace itself, copy over - the type information. */ - /* ??? Shouldn't we replace the symbol with the parent symbol instead? */ - if (contained_sym != sym_lower) - { - contained_sym->ts = sym_lower->ts; - contained_sym->as = gfc_copy_array_spec (sym_lower->as); - } + /* Then check function return types. */ + resolve_contained_fntype (child->proc_name, child); + for (el = child->entries; el; el = el->next) + resolve_contained_fntype (el->sym, child); } } @@ -3458,6 +3569,7 @@ resolve_code (gfc_code * code, gfc_namespace * ns) case EXEC_CONTINUE: case EXEC_DT_END: case EXEC_TRANSFER: + case EXEC_ENTRY: break; case EXEC_WHERE: @@ -4440,6 +4552,8 @@ gfc_resolve (gfc_namespace * ns) old_ns = gfc_current_ns; gfc_current_ns = ns; + resolve_entries (ns); + resolve_contained_functions (ns); gfc_traverse_ns (ns, resolve_symbol); diff --git a/gcc/fortran/st.c b/gcc/fortran/st.c index 743769c..f3e3671 100644 --- a/gcc/fortran/st.c +++ b/gcc/fortran/st.c @@ -106,7 +106,7 @@ gfc_free_statement (gfc_code * p) case EXEC_CONTINUE: case EXEC_TRANSFER: case EXEC_LABEL_ASSIGN: - + case EXEC_ENTRY: case EXEC_ARITHMETIC_IF: break; diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 4b6c6e4..c125865 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -25,6 +25,7 @@ Software Foundation, 59 Temple Place - Suite 330, Boston, MA #include <string.h> #include <stdio.h> #include <stdlib.h> +#include <assert.h> #include "gfortran.h" #include "parse.h" @@ -1614,6 +1615,8 @@ gfc_get_namespace (gfc_namespace * parent) } } + ns->refs = 1; + return ns; } @@ -2228,6 +2231,11 @@ gfc_free_namespace (gfc_namespace * ns) if (ns == NULL) return; + ns->refs--; + if (ns->refs > 0) + return; + assert (ns->refs == 0); + gfc_free_statements (ns->code); free_sym_tree (ns->sym_root); diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index a6dea46..3abb195 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -3074,6 +3074,7 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) int n; int checkparm; int no_repack; + bool optional_arg; /* Do nothing for pointer and allocatable arrays. */ if (sym->attr.pointer || sym->attr.allocatable) @@ -3281,7 +3282,8 @@ 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); - if (sym->attr.optional) + optional_arg = sym->attr.optional || sym->ns->proc_name->attr.entry_master; + if (optional_arg) { tmp = gfc_conv_expr_present (sym); stmt = build_v (COND_EXPR, tmp, stmt, build_empty_stmt ()); @@ -3318,7 +3320,7 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) tmp = build (NE_EXPR, boolean_type_node, tmp, tmpdesc); stmt = build_v (COND_EXPR, tmp, stmt, build_empty_stmt ()); - if (sym->attr.optional) + if (optional_arg) { tmp = gfc_conv_expr_present (sym); stmt = build_v (COND_EXPR, tmp, stmt, build_empty_stmt ()); diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index d9476b822..9dfcc18 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -740,9 +740,6 @@ gfc_get_symbol_decl (gfc_symbol * sym) if (sym->backend_decl) return sym->backend_decl; - if (sym->attr.entry) - gfc_todo_error ("alternate entry"); - /* Catch function declarations. Only used for actual parameters. */ if (sym->attr.flavor == FL_PROCEDURE) { @@ -876,6 +873,11 @@ gfc_get_extern_function_decl (gfc_symbol * sym) if (sym->backend_decl) return sym->backend_decl; + /* We should never be creating external decls for alternate entry points. + The procedure may be an alternate entry point, but we don't want/need + to know that. */ + assert (!(sym->attr.entry || sym->attr.entry_master)); + if (sym->attr.intrinsic) { /* Call the resolution function to get the actual name. This is @@ -949,7 +951,7 @@ gfc_get_extern_function_decl (gfc_symbol * sym) /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT) parameters and don't use alternate returns (is this allowed?). In that case, calls to them are meaningless, and - can be optimized away. See also in gfc_build_function_decl(). */ + can be optimized away. See also in build_function_decl(). */ TREE_SIDE_EFFECTS (fndecl) = 0; } @@ -963,16 +965,16 @@ gfc_get_extern_function_decl (gfc_symbol * sym) /* Create a declaration for a procedure. For external functions (in the C - sense) use gfc_get_extern_function_decl. */ + sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is + a master function with alternate entry points. */ -void -gfc_build_function_decl (gfc_symbol * sym) +static void +build_function_decl (gfc_symbol * sym) { - tree fndecl, type, result_decl, typelist, arglist; - tree length; + tree fndecl, type; symbol_attribute attr; + tree result_decl; gfc_formal_arglist *f; - tree parm; assert (!sym->backend_decl); assert (!sym->attr.external); @@ -1048,7 +1050,8 @@ gfc_build_function_decl (gfc_symbol * sym) /* This specifies if a function is globaly visible, ie. it is the opposite of declaring static in C. */ - if (DECL_CONTEXT (fndecl) == NULL_TREE) + if (DECL_CONTEXT (fndecl) == NULL_TREE + && !sym->attr.entry_master) TREE_PUBLIC (fndecl) = 1; /* TREE_STATIC means the function body is defined here. */ @@ -1070,11 +1073,45 @@ gfc_build_function_decl (gfc_symbol * sym) /* Layout the function declaration and put it in the binding level of the current function. */ pushdecl (fndecl); + + sym->backend_decl = fndecl; +} + + +/* Create the DECL_ARGUMENTS for a procedure. */ + +static void +create_function_arglist (gfc_symbol * sym) +{ + tree fndecl; + gfc_formal_arglist *f; + tree typelist; + tree arglist; + tree length; + tree type; + tree parm; + + fndecl = sym->backend_decl; + /* Build formal argument list. Make sure that their TREE_CONTEXT is the new FUNCTION_DECL node. */ - current_function_decl = fndecl; arglist = NULL_TREE; typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl)); + + if (sym->attr.entry_master) + { + type = TREE_VALUE (typelist); + parm = build_decl (PARM_DECL, get_identifier ("__entry"), type); + + DECL_CONTEXT (parm) = fndecl; + DECL_ARG_TYPE (parm) = type; + TREE_READONLY (parm) = 1; + gfc_finish_decl (parm, NULL_TREE); + + arglist = chainon (arglist, parm); + typelist = TREE_CHAIN (typelist); + } + if (gfc_return_by_reference (sym)) { type = TREE_VALUE (typelist); @@ -1201,14 +1238,224 @@ gfc_build_function_decl (gfc_symbol * sym) assert (TREE_VALUE (typelist) == void_type_node); DECL_ARGUMENTS (fndecl) = arglist; +} - /* Restore the old context. */ - current_function_decl = DECL_CONTEXT (fndecl); - sym->backend_decl = fndecl; +/* Finalize DECL and all nested functions with cgraph. */ + +static void +gfc_finalize (tree decl) +{ + struct cgraph_node *cgn; + + cgn = cgraph_node (decl); + for (cgn = cgn->nested; cgn ; cgn = cgn->next_nested) + gfc_finalize (cgn->decl); + + cgraph_finalize_function (decl, false); } +/* Convert FNDECL's code to GIMPLE and handle any nested functions. */ + +static void +gfc_gimplify_function (tree fndecl) +{ + struct cgraph_node *cgn; + + gimplify_function_tree (fndecl); + dump_function (TDI_generic, fndecl); + + /* Convert all nested functions to GIMPLE now. We do things in this order + so that items like VLA sizes are expanded properly in the context of the + correct function. */ + cgn = cgraph_node (fndecl); + for (cgn = cgn->nested; cgn; cgn = cgn->next_nested) + gfc_gimplify_function (cgn->decl); +} + + +/* Do the setup necessary before generating the body of a function. */ + +static void +trans_function_start (gfc_symbol * sym) +{ + tree fndecl; + + fndecl = sym->backend_decl; + + /* let GCC know the current scope is this function */ + current_function_decl = fndecl; + + /* Let the world know what e're about to do. */ + announce_function (fndecl); + + if (DECL_CONTEXT (fndecl) == NULL_TREE) + { + /* create RTL for function declaration */ + rest_of_decl_compilation (fndecl, 1, 0); + } + + /* create RTL for function definition */ + make_decl_rtl (fndecl); + + /* Set the line and filename. sym->decalred_at seems to point to the + last statement for subroutines, but it'll do for now. */ + gfc_set_backend_locus (&sym->declared_at); + + init_function_start (fndecl); + + /* Even though we're inside a function body, we still don't want to + call expand_expr to calculate the size of a variable-sized array. + We haven't necessarily assigned RTL to all variables yet, so it's + not safe to try to expand expressions involving them. */ + cfun->x_dont_save_pending_sizes_p = 1; + + /* function.c requires a push at the start of the function */ + pushlevel (0); +} + +/* Create thunks for alternate entry points. */ + +static void +build_entry_thunks (gfc_namespace * ns) +{ + gfc_formal_arglist *formal; + gfc_formal_arglist *thunk_formal; + gfc_entry_list *el; + gfc_symbol *thunk_sym; + stmtblock_t body; + tree thunk_fndecl; + tree args; + tree string_args; + tree tmp; + + /* This should always be a toplevel function. */ + assert (current_function_decl == NULL_TREE); + + /* Remeber the master function argument decls. */ + for (formal = ns->proc_name->formal; formal; formal = formal->next) + { + } + + for (el = ns->entries; el; el = el->next) + { + thunk_sym = el->sym; + + build_function_decl (thunk_sym); + create_function_arglist (thunk_sym); + + trans_function_start (thunk_sym); + + thunk_fndecl = thunk_sym->backend_decl; + + gfc_start_block (&body); + + /* Pass extra parater identifying this entry point. */ + tmp = build_int_cst (gfc_array_index_type, el->id, 0); + 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"); + + for (formal = ns->proc_name->formal; formal; formal = formal->next) + { + /* We don't have a clever way of identifying arguments, so resort to + a brute-force search. */ + for (thunk_formal = thunk_sym->formal; + thunk_formal; + thunk_formal = thunk_formal->next) + { + if (thunk_formal->sym == formal->sym) + break; + } + + if (thunk_formal) + { + /* Pass the argument. */ + args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl, + args); + if (formal->sym->ts.type == BT_CHARACTER) + { + tmp = thunk_formal->sym->ts.cl->backend_decl; + string_args = tree_cons (NULL_TREE, tmp, string_args); + } + } + else + { + /* Pass NULL for a missing argument. */ + args = tree_cons (NULL_TREE, null_pointer_node, args); + if (formal->sym->ts.type == BT_CHARACTER) + { + tmp = convert (gfc_strlen_type_node, integer_zero_node); + string_args = tree_cons (NULL_TREE, tmp, string_args); + } + } + } + + /* Call the master function. */ + args = nreverse (args); + args = chainon (args, nreverse (string_args)); + tmp = ns->proc_name->backend_decl; + tmp = gfc_build_function_call (tmp, args); + /* TODO: function return value. */ + gfc_add_expr_to_block (&body, tmp); + + /* Finish off this function and send it for code generation. */ + DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body); + poplevel (1, 0, 1); + BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl; + + /* Output the GENERIC tree. */ + dump_function (TDI_original, thunk_fndecl); + + /* Store the end of the function, so that we get good line number + info for the epilogue. */ + cfun->function_end_locus = input_location; + + /* We're leaving the context of this function, so zap cfun. + It's still in DECL_STRUCT_FUNCTION, and we'll restore it in + tree_rest_of_compilation. */ + cfun = NULL; + + current_function_decl = NULL_TREE; + + gfc_gimplify_function (thunk_fndecl); + lower_nested_functions (thunk_fndecl); + gfc_finalize (thunk_fndecl); + + /* We share the symbols in the formal argument list with other entry + points and the master function. Clear them so that they are + recreated for each function. */ + for (formal = thunk_sym->formal; formal; formal = formal->next) + { + formal->sym->backend_decl = NULL_TREE; + if (formal->sym->ts.type == BT_CHARACTER) + formal->sym->ts.cl->backend_decl = NULL_TREE; + } + } +} + + +/* Create a decl for a function, and create any thunks for alternate entry + points. */ + +void +gfc_create_function_decl (gfc_namespace * ns) +{ + /* Create a declaration for the master function. */ + build_function_decl (ns->proc_name); + + /* Compile teh entry thunks. */ + if (ns->entries) + build_entry_thunks (ns); + + /* Now create the read argument list. */ + create_function_arglist (ns->proc_name); +} + /* Return the decl used to hold the function return value. */ tree @@ -1811,7 +2058,7 @@ gfc_generate_contained_functions (gfc_namespace * parent) if (ns->parent != parent) continue; - gfc_build_function_decl (ns->proc_name); + gfc_create_function_decl (ns); } for (ns = parent->contained; ns; ns = ns->sibling) @@ -1856,37 +2103,44 @@ generate_local_vars (gfc_namespace * ns) } -/* Finalize DECL and all nested functions with cgraph. */ +/* Generate a switch statement to jump to the correct entry point. Also + creates the label decls for the entry points. */ -static void -gfc_finalize (tree decl) +static tree +gfc_trans_entry_master_switch (gfc_entry_list * el) { - struct cgraph_node *cgn; - - cgn = cgraph_node (decl); - for (cgn = cgn->nested; cgn ; cgn = cgn->next_nested) - gfc_finalize (cgn->decl); + stmtblock_t block; + tree label; + tree tmp; + tree val; - cgraph_finalize_function (decl, false); + gfc_init_block (&block); + for (; el; el = el->next) + { + /* Add the case label. */ + label = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE); + DECL_CONTEXT (label) = current_function_decl; + val = build_int_cst (gfc_array_index_type, el->id, 0); + tmp = build_v (CASE_LABEL_EXPR, val, NULL_TREE, label); + gfc_add_expr_to_block (&block, tmp); + + /* And jump to the actual entry point. */ + label = gfc_build_label_decl (NULL_TREE); + TREE_USED (label) = 1; + DECL_CONTEXT (label) = current_function_decl; + tmp = build1_v (GOTO_EXPR, label); + gfc_add_expr_to_block (&block, tmp); + + /* Save the label decl. */ + el->label = label; + } + tmp = gfc_finish_block (&block); + /* The first argument selects the entry point. */ + val = DECL_ARGUMENTS (current_function_decl); + tmp = build_v (SWITCH_EXPR, val, tmp, NULL_TREE); + return tmp; } -/* Convert FNDECL's code to GIMPLE and handle any nested functions. */ - -static void -gfc_gimplify_function (tree fndecl) -{ - struct cgraph_node *cgn; - - gimplify_function_tree (fndecl); - dump_function (TDI_generic, fndecl); - - /* Convert all nested functions to GIMPLE now. We do things in this order - so that items like VLA sizes are expanded properly in the context of the - correct function. */ - cgn = cgraph_node (fndecl); - for (cgn = cgn->nested; cgn; cgn = cgn->next_nested) - gfc_gimplify_function (cgn->decl); -} /* Generate code for a function. */ @@ -1903,14 +2157,14 @@ gfc_generate_function_code (gfc_namespace * ns) gfc_symbol *sym; sym = ns->proc_name; + /* Check that the frontend isn't still using this. */ assert (sym->tlink == NULL); - sym->tlink = sym; /* Create the declaration for functions with global scope. */ if (!sym->backend_decl) - gfc_build_function_decl (ns->proc_name); + gfc_create_function_decl (ns); fndecl = sym->backend_decl; old_context = current_function_decl; @@ -1922,41 +2176,11 @@ gfc_generate_function_code (gfc_namespace * ns) saved_function_decls = NULL_TREE; } - /* let GCC know the current scope is this function */ - current_function_decl = fndecl; - - /* print function name on the console at compile time - (unless this feature was switched of by command line option "-quiet" */ - announce_function (fndecl); - - if (DECL_CONTEXT (fndecl) == NULL_TREE) - { - /* create RTL for function declaration */ - rest_of_decl_compilation (fndecl, 1, 0); - } - - /* create RTL for function definition */ - make_decl_rtl (fndecl); - - /* Set the line and filename. sym->decalred_at seems to point to the last - statement for subroutines, but it'll do for now. */ - gfc_set_backend_locus (&sym->declared_at); - - /* line and file should not be 0 */ - init_function_start (fndecl); - - /* Even though we're inside a function body, we still don't want to - call expand_expr to calculate the size of a variable-sized array. - We haven't necessarily assigned RTL to all variables yet, so it's - not safe to try to expand expressions involving them. */ - cfun->x_dont_save_pending_sizes_p = 1; + trans_function_start (sym); /* Will be created as needed. */ current_fake_result_decl = NULL_TREE; - /* function.c requires a push at the start of the function */ - pushlevel (0); - gfc_start_block (&block); gfc_generate_contained_functions (ns); @@ -1979,6 +2203,13 @@ gfc_generate_function_code (gfc_namespace * ns) gfc_add_modify_expr (&body, alternate_return, integer_zero_node); } + if (ns->entries) + { + /* Jump to the correct entry point. */ + tmp = gfc_trans_entry_master_switch (ns->entries); + gfc_add_expr_to_block (&body, tmp); + } + tmp = gfc_trans_code (ns->code); gfc_add_expr_to_block (&body, tmp); diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 261bf77..dbe4422 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -179,6 +179,14 @@ gfc_trans_goto (gfc_code * code) } +/* Translate an ENTRY statement. Just adds a label for this entry point. */ +tree +gfc_trans_entry (gfc_code * code) +{ + return build1_v (LABEL_EXPR, code->ext.entry->label); +} + + /* Translate the CALL statement. Builds a call to an F95 subroutine. */ tree diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h index e9d66e8..c7dc229 100644 --- a/gcc/fortran/trans-stmt.h +++ b/gcc/fortran/trans-stmt.h @@ -35,6 +35,7 @@ tree gfc_trans_exit (gfc_code *); tree gfc_trans_label_assign (gfc_code *); tree gfc_trans_label_here (gfc_code *); tree gfc_trans_goto (gfc_code *); +tree gfc_trans_entry (gfc_code *); tree gfc_trans_pause (gfc_code *); tree gfc_trans_stop (gfc_code *); tree gfc_trans_call (gfc_code *); diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index b01298d..85c13fa 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -1155,6 +1155,13 @@ gfc_get_function_type (gfc_symbol * sym) nstr = 0; alternate_return = 0; typelist = NULL_TREE; + + if (sym->attr.entry_master) + { + /* Additional parameter for selecting an entry point. */ + typelist = gfc_chainon_list (typelist, gfc_array_index_type); + } + /* Some functions we use an extra parameter for the return value. */ if (gfc_return_by_reference (sym)) { diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 052da55..1ac8931 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -516,6 +516,10 @@ gfc_trans_code (gfc_code * code) res = gfc_trans_goto (code); break; + case EXEC_ENTRY: + res = gfc_trans_entry (code); + break; + case EXEC_PAUSE: res = gfc_trans_pause (code); break; @@ -679,7 +683,7 @@ gfc_generate_module_code (gfc_namespace * ns) if (!n->proc_name) continue; - gfc_build_function_decl (n->proc_name); + gfc_create_function_decl (n); } for (n = ns->contained; n; n = n->sibling) diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 7f9e997..3faf400 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -394,7 +394,7 @@ void gfc_allocate_lang_decl (tree); tree gfc_advance_chain (tree, int); /* Create a decl for a function. */ -void gfc_build_function_decl (gfc_symbol *); +void gfc_create_function_decl (gfc_namespace *); /* Generate the code for a function. */ void gfc_generate_function_code (gfc_namespace *); /* Output a decl for a module variable. */ diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index a4952b1..7ceee25 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2004-08-17 Paul Brook <paul@codesourcery.com> + + PR fortran/13082 + * gfortran.dg/entry_1.f90: New test. + 2004-08-17 Andrew Pinski <apinski@apple.com> * gcc.dg/darwin-20040812-1.c: Compile only on darwin. diff --git a/gcc/testsuite/gfortran.dg/entry_1.f90 b/gcc/testsuite/gfortran.dg/entry_1.f90 new file mode 100644 index 0000000..0e7f296 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/entry_1.f90 @@ -0,0 +1,44 @@ +! Test alternate entry points in a module procedure +! Also check that references to sibling entry points are resolved correctly. +module m +contains +subroutine indirecta (p) + call p (3, 4) +end subroutine +subroutine indirectb (p) + call p (5) +end subroutine + +subroutine test1 + implicit none + call indidecta (foo) + call indirectb (bar) +end subroutine + +subroutine foo(a, b) + integer a, b + logical, save :: was_foo = .false. + if ((a .ne. 3) .or. (b .ne. 4)) call abort + was_foo = .true. +entry bar(a) + if (was_foo) then + if ((a .ne. 3) .or. (b .ne. 4)) call abort + else + if (a .ne. 5) call abort + end if + was_foo = .false. +end subroutine + +subroutine test2 + call foo (3, 4) + call bar (5) +end subroutine +end module + +program p + use m + call foo (3, 4) + call bar (5) + call test1 () + call test2 () +end program |