diff options
Diffstat (limited to 'gcc/fortran')
| -rw-r--r-- | gcc/fortran/ChangeLog | 40 | ||||
| -rw-r--r-- | gcc/fortran/cpp.c | 5 | ||||
| -rw-r--r-- | gcc/fortran/decl.c | 108 | ||||
| -rw-r--r-- | gcc/fortran/gfortran.h | 21 | ||||
| -rw-r--r-- | gcc/fortran/match.h | 1 | ||||
| -rw-r--r-- | gcc/fortran/parse.c | 81 | ||||
| -rw-r--r-- | gcc/fortran/resolve.c | 144 | ||||
| -rw-r--r-- | gcc/fortran/symbol.c | 55 |
8 files changed, 440 insertions, 15 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index a928c25b386..fd0817becbd 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,43 @@ +2008-06-02 Janus Weil <janus@gcc.gnu.org> + + PR fortran/36361 + * symbol.c (gfc_add_allocatable,gfc_add_dimension, + gfc_add_explicit_interface): Added checks. + * decl.c (attr_decl1): Added missing "var_locus". + * parse.c (parse_interface): Checking for errors. + +2008-06-02 Daniel Kraft <d@domob.eu> + + * gfortran.h: New statement-type ST_FINAL for FINAL declarations. + (struct gfc_symbol): New member f2k_derived. + (struct gfc_namespace): New member finalizers, for use in the above + mentioned f2k_derived namespace. + (struct gfc_finalizer): New type defined for finalizers linked list. + * match.h (gfc_match_final_decl): New function header. + * decl.c (gfc_match_derived_decl): Create f2k_derived namespace on + constructed symbol node. + (gfc_match_final_decl): New function to match a FINAL declaration line. + * parse.c (decode_statement): match-call for keyword FINAL. + (parse_derived): Parse CONTAINS section and accept FINAL statements. + * resolve.c (gfc_resolve_finalizers): New function to resolve (that is + in this case, check) a list of finalizer procedures. + (resolve_fl_derived): Call gfc_resolve_finalizers here. + * symbol.c (gfc_get_namespace): Initialize new finalizers to NULL. + (gfc_free_namespace): Free finalizers list. + (gfc_new_symbol): Initialize new f2k_derived to NULL. + (gfc_free_symbol): Free f2k_derived namespace. + (gfc_free_finalizer): New function to free a single gfc_finalizer node. + (gfc_free_finalizer_list): New function to free a linked list of + gfc_finalizer nodes. + +2008-06-02 Daniel Franke <franke.daniel@gmail.com> + + PR fortran/36375 + PR fortran/36377 + * cpp.c (gfc_cpp_init): Do not initialize builtins if + processing already preprocessed input. + (gfc_cpp_preprocess): Finalize output with newline. + 2008-05-31 Jerry DeLisle <jvdelisle@gcc.gnu.org> * intrinsic.texi: Revert wrong commit. diff --git a/gcc/fortran/cpp.c b/gcc/fortran/cpp.c index 865e2efc79d..170f6cdcd63 100644 --- a/gcc/fortran/cpp.c +++ b/gcc/fortran/cpp.c @@ -524,6 +524,9 @@ gfc_cpp_init (void) { int i; + if (gfc_option.flag_preprocessed) + return; + cpp_change_file (cpp_in, LC_RENAME, _("<built-in>")); if (!gfc_cpp_option.no_predefined) cpp_define_builtins (cpp_in); @@ -574,6 +577,8 @@ gfc_cpp_preprocess (const char *source_file) cpp_forall_identifiers (cpp_in, dump_macro, NULL); } + putc ('\n', print.outf); + if (!gfc_cpp_preprocess_only () || (gfc_cpp_preprocess_only () && gfc_cpp_option.output_filename)) fclose (print.outf); diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 79044eb1846..ea87c211d49 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -5216,7 +5216,7 @@ attr_decl1 (void) /* Update symbol table. DIMENSION attribute is set in gfc_set_array_spec(). */ if (current_attr.dimension == 0 - && gfc_copy_attr (&sym->attr, ¤t_attr, NULL) == FAILURE) + && gfc_copy_attr (&sym->attr, ¤t_attr, &var_locus) == FAILURE) { m = MATCH_ERROR; goto cleanup; @@ -6270,6 +6270,10 @@ gfc_match_derived_decl (void) if (attr.is_bind_c != 0) sym->attr.is_bind_c = attr.is_bind_c; + /* Construct the f2k_derived namespace if it is not yet there. */ + if (!sym->f2k_derived) + sym->f2k_derived = gfc_get_namespace (NULL, 0); + gfc_new_block = sym; return MATCH_YES; @@ -6480,3 +6484,105 @@ cleanup: } +/* Match a FINAL declaration inside a derived type. */ + +match +gfc_match_final_decl (void) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_symbol* sym; + match m; + gfc_namespace* module_ns; + bool first, last; + + if (gfc_state_stack->state != COMP_DERIVED) + { + gfc_error ("FINAL declaration at %C must be inside a derived type " + "definition!"); + return MATCH_ERROR; + } + + gcc_assert (gfc_current_block ()); + + if (!gfc_state_stack->previous + || gfc_state_stack->previous->state != COMP_MODULE) + { + gfc_error ("Derived type declaration with FINAL at %C must be in the" + " specification part of a MODULE"); + return MATCH_ERROR; + } + + module_ns = gfc_current_ns; + gcc_assert (module_ns); + gcc_assert (module_ns->proc_name->attr.flavor == FL_MODULE); + + /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */ + if (gfc_match (" ::") == MATCH_ERROR) + return MATCH_ERROR; + + /* Match the sequence of procedure names. */ + first = true; + last = false; + do + { + gfc_finalizer* f; + + if (first && gfc_match_eos () == MATCH_YES) + { + gfc_error ("Empty FINAL at %C"); + return MATCH_ERROR; + } + + m = gfc_match_name (name); + if (m == MATCH_NO) + { + gfc_error ("Expected module procedure name at %C"); + return MATCH_ERROR; + } + else if (m != MATCH_YES) + return MATCH_ERROR; + + if (gfc_match_eos () == MATCH_YES) + last = true; + if (!last && gfc_match_char (',') != MATCH_YES) + { + gfc_error ("Expected ',' at %C"); + return MATCH_ERROR; + } + + if (gfc_get_symbol (name, module_ns, &sym)) + { + gfc_error ("Unknown procedure name \"%s\" at %C", name); + return MATCH_ERROR; + } + + /* Mark the symbol as module procedure. */ + if (sym->attr.proc != PROC_MODULE + && gfc_add_procedure (&sym->attr, PROC_MODULE, + sym->name, NULL) == FAILURE) + return MATCH_ERROR; + + /* Check if we already have this symbol in the list, this is an error. */ + for (f = gfc_current_block ()->f2k_derived->finalizers; f; f = f->next) + if (f->procedure == sym) + { + gfc_error ("'%s' at %C is already defined as FINAL procedure!", + name); + return MATCH_ERROR; + } + + /* Add this symbol to the list of finalizers. */ + gcc_assert (gfc_current_block ()->f2k_derived); + ++sym->refs; + f = gfc_getmem (sizeof (gfc_finalizer)); + f->procedure = sym; + f->where = gfc_current_locus; + f->next = gfc_current_block ()->f2k_derived->finalizers; + gfc_current_block ()->f2k_derived->finalizers = f; + + first = false; + } + while (!last); + + return MATCH_YES; +} diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index e3a9446333e..d4f9771e610 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -210,7 +210,7 @@ typedef enum ST_CALL, ST_CASE, ST_CLOSE, ST_COMMON, ST_CONTINUE, ST_CONTAINS, ST_CYCLE, ST_DATA, ST_DATA_DECL, ST_DEALLOCATE, ST_DO, ST_ELSE, ST_ELSEIF, ST_ELSEWHERE, ST_END_BLOCK_DATA, ST_ENDDO, ST_IMPLIED_ENDDO, - ST_END_FILE, ST_FLUSH, ST_END_FORALL, ST_END_FUNCTION, ST_ENDIF, + ST_END_FILE, ST_FINAL, ST_FLUSH, ST_END_FORALL, ST_END_FUNCTION, ST_ENDIF, ST_END_INTERFACE, ST_END_MODULE, ST_END_PROGRAM, ST_END_SELECT, ST_END_SUBROUTINE, ST_END_WHERE, ST_END_TYPE, ST_ENTRY, ST_EQUIVALENCE, ST_EXIT, ST_FORALL, ST_FORALL_BLOCK, ST_FORMAT, ST_FUNCTION, ST_GOTO, @@ -1014,6 +1014,10 @@ typedef struct gfc_symbol gfc_formal_arglist *formal; struct gfc_namespace *formal_ns; + /* The namespace containing type-associated procedure symbols. */ + /* TODO: Make this union with formal? */ + struct gfc_namespace *f2k_derived; + struct gfc_expr *value; /* Parameter/Initializer value */ gfc_array_spec *as; struct gfc_symbol *result; /* function result symbol */ @@ -1151,6 +1155,8 @@ typedef struct gfc_namespace gfc_symtree *uop_root; /* Tree containing all the common blocks. */ gfc_symtree *common_root; + /* Linked list of finalizer procedures. */ + struct gfc_finalizer *finalizers; /* If set_flag[letter] is set, an implicit type has been set for letter. */ int set_flag[GFC_LETTERS]; @@ -1942,6 +1948,17 @@ typedef struct iterator_stack iterator_stack; extern iterator_stack *iter_stack; + +/* Node in the linked list used for storing finalizer procedures. */ + +typedef struct gfc_finalizer +{ + struct gfc_finalizer* next; + gfc_symbol* procedure; + locus where; /* Where the FINAL declaration occured. */ +} +gfc_finalizer; + /************************ Function prototypes *************************/ /* decl.c */ @@ -2210,6 +2227,8 @@ gfc_gsymbol *gfc_find_gsymbol (gfc_gsymbol *, const char *); void copy_formal_args (gfc_symbol *dest, gfc_symbol *src); +void gfc_free_finalizer (gfc_finalizer *el); /* Needed in resolve.c, too */ + /* intrinsic.c */ extern int gfc_init_expr; diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h index d46e1630136..3f8d31074e8 100644 --- a/gcc/fortran/match.h +++ b/gcc/fortran/match.h @@ -140,6 +140,7 @@ match gfc_match_function_decl (void); match gfc_match_entry (void); match gfc_match_subroutine (void); match gfc_match_derived_decl (void); +match gfc_match_final_decl (void); match gfc_match_implicit_none (void); match gfc_match_implicit (void); diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index b7e63919e8e..33f13c92200 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -366,6 +366,7 @@ decode_statement (void) break; case 'f': + match ("final", gfc_match_final_decl, ST_FINAL); match ("flush", gfc_match_flush, ST_FLUSH); match ("format", gfc_match_format, ST_FORMAT); break; @@ -1682,6 +1683,7 @@ static void parse_derived (void) { int compiling_type, seen_private, seen_sequence, seen_component, error_flag; + int seen_contains, seen_contains_comp; gfc_statement st; gfc_state_data s; gfc_symbol *derived_sym = NULL; @@ -1697,6 +1699,8 @@ parse_derived (void) seen_private = 0; seen_sequence = 0; seen_component = 0; + seen_contains = 0; + seen_contains_comp = 0; compiling_type = 1; @@ -1710,23 +1714,57 @@ parse_derived (void) case ST_DATA_DECL: case ST_PROCEDURE: + if (seen_contains) + { + gfc_error ("Components in TYPE at %C must precede CONTAINS"); + error_flag = 1; + } + accept_statement (st); seen_component = 1; break; + case ST_FINAL: + if (!seen_contains) + { + gfc_error ("FINAL declaration at %C must be inside CONTAINS"); + error_flag = 1; + } + + if (gfc_notify_std (GFC_STD_F2003, + "Fortran 2003: FINAL procedure declaration" + " at %C") == FAILURE) + error_flag = 1; + + accept_statement (ST_FINAL); + seen_contains_comp = 1; + break; + case ST_END_TYPE: compiling_type = 0; if (!seen_component && (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Derived type " - "definition at %C without components") + "definition at %C without components") == FAILURE)) error_flag = 1; + if (seen_contains && !seen_contains_comp + && (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Derived type " + "definition at %C with empty CONTAINS " + "section") == FAILURE)) + error_flag = 1; + accept_statement (ST_END_TYPE); break; case ST_PRIVATE: + if (seen_contains) + { + gfc_error ("PRIVATE statement at %C must precede CONTAINS"); + error_flag = 1; + } + if (gfc_find_state (COMP_MODULE) == FAILURE) { gfc_error ("PRIVATE statement in TYPE at %C must be inside " @@ -1755,6 +1793,12 @@ parse_derived (void) break; case ST_SEQUENCE: + if (seen_contains) + { + gfc_error ("SEQUENCE statement at %C must precede CONTAINS"); + error_flag = 1; + } + if (seen_component) { gfc_error ("SEQUENCE statement at %C must precede " @@ -1778,6 +1822,22 @@ parse_derived (void) gfc_current_block ()->name, NULL); break; + case ST_CONTAINS: + if (gfc_notify_std (GFC_STD_F2003, + "Fortran 2003: CONTAINS block in derived type" + " definition at %C") == FAILURE) + error_flag = 1; + + if (seen_contains) + { + gfc_error ("Already inside a CONTAINS block at %C"); + error_flag = 1; + } + + seen_contains = 1; + accept_statement (ST_CONTAINS); + break; + default: unexpected_statement (st); break; @@ -1914,23 +1974,18 @@ loop: unexpected_eof (); case ST_SUBROUTINE: - new_state = COMP_SUBROUTINE; - gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY, - gfc_new_block->formal, NULL); - if (current_interface.type != INTERFACE_ABSTRACT && - !gfc_new_block->attr.dummy && - gfc_add_external (&gfc_new_block->attr, &gfc_current_locus) == FAILURE) + case ST_FUNCTION: + if (st == ST_SUBROUTINE) + new_state = COMP_SUBROUTINE; + else if (st == ST_FUNCTION) + new_state = COMP_FUNCTION; + if (gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY, + gfc_new_block->formal, NULL) == FAILURE) { reject_statement (); gfc_free_namespace (gfc_current_ns); goto loop; } - break; - - case ST_FUNCTION: - new_state = COMP_FUNCTION; - gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY, - gfc_new_block->formal, NULL); if (current_interface.type != INTERFACE_ABSTRACT && !gfc_new_block->attr.dummy && gfc_add_external (&gfc_new_block->attr, &gfc_current_locus) == FAILURE) diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 8044990b7dd..c9809351c94 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -7439,6 +7439,146 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) } +/* Resolve a list of finalizer procedures. That is, after they have hopefully + been defined and we now know their defined arguments, check that they fulfill + the requirements of the standard for procedures used as finalizers. */ + +static try +gfc_resolve_finalizers (gfc_symbol* derived) +{ + gfc_finalizer* list; + gfc_finalizer** prev_link; /* For removing wrong entries from the list. */ + try result = SUCCESS; + bool seen_scalar = false; + + if (!derived->f2k_derived || !derived->f2k_derived->finalizers) + return SUCCESS; + + /* Walk over the list of finalizer-procedures, check them, and if any one + does not fit in with the standard's definition, print an error and remove + it from the list. */ + prev_link = &derived->f2k_derived->finalizers; + for (list = derived->f2k_derived->finalizers; list; list = *prev_link) + { + gfc_symbol* arg; + gfc_finalizer* i; + int my_rank; + + /* Check this exists and is a SUBROUTINE. */ + if (!list->procedure->attr.subroutine) + { + gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE", + list->procedure->name, &list->where); + goto error; + } + + /* We should have exactly one argument. */ + if (!list->procedure->formal || list->procedure->formal->next) + { + gfc_error ("FINAL procedure at %L must have exactly one argument", + &list->where); + goto error; + } + arg = list->procedure->formal->sym; + + /* This argument must be of our type. */ + if (arg->ts.type != BT_DERIVED || arg->ts.derived != derived) + { + gfc_error ("Argument of FINAL procedure at %L must be of type '%s'", + &arg->declared_at, derived->name); + goto error; + } + + /* It must neither be a pointer nor allocatable nor optional. */ + if (arg->attr.pointer) + { + gfc_error ("Argument of FINAL procedure at %L must not be a POINTER", + &arg->declared_at); + goto error; + } + if (arg->attr.allocatable) + { + gfc_error ("Argument of FINAL procedure at %L must not be" + " ALLOCATABLE", &arg->declared_at); + goto error; + } + if (arg->attr.optional) + { + gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL", + &arg->declared_at); + goto error; + } + + /* It must not be INTENT(OUT). */ + if (arg->attr.intent == INTENT_OUT) + { + gfc_error ("Argument of FINAL procedure at %L must not be" + " INTENT(OUT)", &arg->declared_at); + goto error; + } + + /* Warn if the procedure is non-scalar and not assumed shape. */ + if (gfc_option.warn_surprising && arg->as && arg->as->rank > 0 + && arg->as->type != AS_ASSUMED_SHAPE) + gfc_warning ("Non-scalar FINAL procedure at %L should have assumed" + " shape argument", &arg->declared_at); + + /* Check that it does not match in kind and rank with a FINAL procedure + defined earlier. To really loop over the *earlier* declarations, + we need to walk the tail of the list as new ones were pushed at the + front. */ + /* TODO: Handle kind parameters once they are implemented. */ + my_rank = (arg->as ? arg->as->rank : 0); + for (i = list->next; i; i = i->next) + { + /* Argument list might be empty; that is an error signalled earlier, + but we nevertheless continued resolving. */ + if (i->procedure->formal) + { + gfc_symbol* i_arg = i->procedure->formal->sym; + const int i_rank = (i_arg->as ? i_arg->as->rank : 0); + if (i_rank == my_rank) + { + gfc_error ("FINAL procedure '%s' declared at %L has the same" + " rank (%d) as '%s'", + list->procedure->name, &list->where, my_rank, + i->procedure->name); + goto error; + } + } + } + + /* Is this the/a scalar finalizer procedure? */ + if (!arg->as || arg->as->rank == 0) + seen_scalar = true; + + prev_link = &list->next; + continue; + + /* Remove wrong nodes immediatelly from the list so we don't risk any + troubles in the future when they might fail later expectations. */ +error: + result = FAILURE; + i = list; + *prev_link = list->next; + gfc_free_finalizer (i); + } + + /* Warn if we haven't seen a scalar finalizer procedure (but we know there + were nodes in the list, must have been for arrays. It is surely a good + idea to have a scalar version there if there's something to finalize. */ + if (gfc_option.warn_surprising && result == SUCCESS && !seen_scalar) + gfc_warning ("Only array FINAL procedures declared for derived type '%s'" + " defined at %L, suggest also scalar one", + derived->name, &derived->declared_at); + + /* TODO: Remove this error when finalization is finished. */ + gfc_error ("Finalization at %L is not yet implemented", &derived->declared_at); + + return result; +} + + /* Resolve the components of a derived type. */ static try @@ -7517,6 +7657,10 @@ resolve_fl_derived (gfc_symbol *sym) } } + /* Resolve the finalizer procedures. */ + if (gfc_resolve_finalizers (sym) == FAILURE) + return FAILURE; + /* Add derived type to the derived type list. */ for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next) if (sym == dt_list->derived) diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index e98a19c57fa..e4e43244d59 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -814,6 +814,14 @@ gfc_add_allocatable (symbol_attribute *attr, locus *where) return FAILURE; } + if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY + && gfc_find_state (COMP_INTERFACE) == FAILURE) + { + gfc_error ("ALLOCATABLE specified outside of INTERFACE body at %L", + where); + return FAILURE; + } + attr->allocatable = 1; return check_conflict (attr, NULL, where); } @@ -832,6 +840,14 @@ gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where) return FAILURE; } + if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY + && gfc_find_state (COMP_INTERFACE) == FAILURE) + { + gfc_error ("DIMENSION specified for '%s' outside its INTERFACE body " + "at %L", name, where); + return FAILURE; + } + attr->dimension = 1; return check_conflict (attr, name, where); } @@ -1453,6 +1469,13 @@ gfc_add_explicit_interface (gfc_symbol *sym, ifsrc source, return FAILURE; } + if (source == IFSRC_IFBODY && (sym->attr.dimension || sym->attr.allocatable)) + { + gfc_error ("'%s' at %L has attributes specified outside its INTERFACE " + "body", sym->name, where); + return FAILURE; + } + sym->formal = formal; sym->attr.if_source = source; @@ -2096,6 +2119,7 @@ gfc_get_namespace (gfc_namespace *parent, int parent_types) ns = gfc_getmem (sizeof (gfc_namespace)); ns->sym_root = NULL; ns->uop_root = NULL; + ns->finalizers = NULL; ns->default_access = ACCESS_UNKNOWN; ns->parent = parent; @@ -2284,6 +2308,8 @@ gfc_free_symbol (gfc_symbol *sym) gfc_free_formal_arglist (sym->formal); + gfc_free_namespace (sym->f2k_derived); + gfc_free (sym); } @@ -2316,6 +2342,7 @@ gfc_new_symbol (const char *name, gfc_namespace *ns) /* Clear the ptrs we may need. */ p->common_block = NULL; + p->f2k_derived = NULL; return p; } @@ -2884,6 +2911,33 @@ gfc_free_equiv_lists (gfc_equiv_list *l) } +/* Free a finalizer procedure list. */ + +void +gfc_free_finalizer (gfc_finalizer* el) +{ + if (el) + { + --el->procedure->refs; + if (!el->procedure->refs) + gfc_free_symbol (el->procedure); + + gfc_free (el); + } +} + +static void +gfc_free_finalizer_list (gfc_finalizer* list) +{ + while (list) + { + gfc_finalizer* current = list; + list = list->next; + gfc_free_finalizer (current); + } +} + + /* Free a namespace structure and everything below it. Interface lists associated with intrinsic operators are not freed. These are taken care of when a specific name is freed. */ @@ -2908,6 +2962,7 @@ gfc_free_namespace (gfc_namespace *ns) free_sym_tree (ns->sym_root); free_uop_tree (ns->uop_root); free_common_tree (ns->common_root); + gfc_free_finalizer_list (ns->finalizers); for (cl = ns->cl_list; cl; cl = cl2) { |