diff options
Diffstat (limited to 'gcc/fortran/decl.c')
| -rw-r--r-- | gcc/fortran/decl.c | 768 |
1 files changed, 525 insertions, 243 deletions
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index da33b22610..5ca664e57a 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -1,5 +1,5 @@ /* Declaration statement matcher - Copyright (C) 2002-2016 Free Software Foundation, Inc. + Copyright (C) 2002-2017 Free Software Foundation, Inc. Contributed by Andy Vaught This file is part of GCC. @@ -395,6 +395,7 @@ match_data_constant (gfc_expr **result) { gfc_error ("Symbol %qs must be a PARAMETER in DATA statement at %C", name); + *result = NULL; return MATCH_ERROR; } else if (dt_sym && gfc_fl_struct (dt_sym->attr.flavor)) @@ -608,10 +609,10 @@ cleanup: /* Like gfc_match_init_expr, but matches a 'clist' (old-style initialization list). The difference here is the expression is a list of constants - and is surrounded by '/'. + and is surrounded by '/'. The typespec ts must match the typespec of the variable which the clist is initializing. - The arrayspec tells whether this should match a list of constants + The arrayspec tells whether this should match a list of constants corresponding to array elements or a scalar (as == NULL). */ static match @@ -905,6 +906,7 @@ char_len_param_value (gfc_expr **expr, bool *deferred) goto syntax; else if ((*expr)->expr_type == EXPR_VARIABLE) { + bool t; gfc_expr *e; e = gfc_copy_expr (*expr); @@ -916,7 +918,17 @@ char_len_param_value (gfc_expr **expr, bool *deferred) && e->ref->u.ar.dimen_type[0] == DIMEN_RANGE) goto syntax; - gfc_reduce_init_expr (e); + t = gfc_reduce_init_expr (e); + + if (!t && e->ts.type == BT_UNKNOWN + && e->symtree->n.sym->attr.untyped == 1 + && (flag_implicit_none + || e->symtree->n.sym->ns->seen_implicit_none == 1 + || e->symtree->n.sym->ns->parent->seen_implicit_none == 1)) + { + gfc_free_expr (e); + goto syntax; + } if ((e->ref && e->ref->type == REF_ARRAY && e->ref->u.ar.type != AR_ELEMENT) @@ -1108,12 +1120,12 @@ get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry) { /* Create a partially populated interface symbol to carry the characteristics of the procedure and the result. */ - sym->ts.interface = gfc_new_symbol (name, sym->ns); - gfc_add_type (sym->ts.interface, &(sym->ts), + sym->tlink = gfc_new_symbol (name, sym->ns); + gfc_add_type (sym->tlink, &(sym->ts), &gfc_current_locus); - gfc_copy_attr (&sym->ts.interface->attr, &sym->attr, NULL); + gfc_copy_attr (&sym->tlink->attr, &sym->attr, NULL); if (sym->attr.dimension) - sym->ts.interface->as = gfc_copy_array_spec (sym->as); + sym->tlink->as = gfc_copy_array_spec (sym->as); /* Ideally, at this point, a copy would be made of the formal arguments and their namespace. However, this does not appear @@ -1122,12 +1134,12 @@ get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry) if (sym->result && sym->result != sym) { - sym->ts.interface->result = sym->result; + sym->tlink->result = sym->result; sym->result = NULL; } else if (sym->result) { - sym->ts.interface->result = sym->ts.interface; + sym->tlink->result = sym->tlink; } } else if (sym && !sym->gfc_new @@ -1485,11 +1497,15 @@ gfc_set_constant_character_len (int len, gfc_expr *expr, int check_len) gfc_char_t *s; int slen; - gcc_assert (expr->expr_type == EXPR_CONSTANT); - if (expr->ts.type != BT_CHARACTER) return; + if (expr->expr_type != EXPR_CONSTANT) + { + gfc_error_now ("CHARACTER length must be a constant at %L", &expr->where); + return; + } + slen = expr->value.character.length; if (len != slen) { @@ -1657,7 +1673,18 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus) else if (init->expr_type == EXPR_ARRAY) { if (init->ts.u.cl) - clen = mpz_get_si (init->ts.u.cl->length->value.integer); + { + const gfc_expr *length = init->ts.u.cl->length; + if (length->expr_type != EXPR_CONSTANT) + { + gfc_error ("Cannot initialize parameter array " + "at %L " + "with variable length elements", + &sym->declared_at); + return false; + } + clen = mpz_get_si (length->value.integer); + } else if (init->value.constructor) { gfc_constructor *c; @@ -1824,7 +1851,6 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init, { gfc_state_data *s; gfc_component *c; - bool t = true; /* F03:C438/C439. If the current symbol is of the same derived type that we're constructing, it must have the pointer attribute. */ @@ -1832,7 +1858,25 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init, && current_ts.u.derived == gfc_current_block () && current_attr.pointer == 0) { - gfc_error ("Component at %C must have the POINTER attribute"); + if (current_attr.allocatable + && !gfc_notify_std(GFC_STD_F2008, "Component at %C " + "must have the POINTER attribute")) + { + return false; + } + else if (current_attr.allocatable == 0) + { + gfc_error ("Component at %C must have the POINTER attribute"); + return false; + } + } + + /* F03:C437. */ + if (current_ts.type == BT_CLASS + && !(current_attr.pointer || current_attr.allocatable)) + { + gfc_error ("Component %qs with CLASS at %C must be allocatable " + "or pointer", name); return false; } @@ -1848,7 +1892,7 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init, /* If we are in a nested union/map definition, gfc_add_component will not properly find repeated components because: - (i) gfc_add_component does a flat search, where components of unions + (i) gfc_add_component does a flat search, where components of unions and maps are implicity chained so nested components may conflict. (ii) Unions and maps are not linked as components of their parent structures until after they are parsed. @@ -1864,7 +1908,7 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init, c = gfc_find_component (s->sym, name, true, true, NULL); if (c != NULL) { - gfc_error_now ("Component '%s' at %C already declared at %L", + gfc_error_now ("Component %qs at %C already declared at %L", name, &c->loc); return false; } @@ -1896,51 +1940,7 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init, } *as = NULL; - /* Should this ever get more complicated, combine with similar section - in add_init_expr_to_sym into a separate function. */ - if (c->ts.type == BT_CHARACTER && !c->attr.pointer && c->initializer - && c->ts.u.cl - && c->ts.u.cl->length && c->ts.u.cl->length->expr_type == EXPR_CONSTANT) - { - int len; - - gcc_assert (c->ts.u.cl && c->ts.u.cl->length); - gcc_assert (c->ts.u.cl->length->expr_type == EXPR_CONSTANT); - gcc_assert (c->ts.u.cl->length->ts.type == BT_INTEGER); - - len = mpz_get_si (c->ts.u.cl->length->value.integer); - - if (c->initializer->expr_type == EXPR_CONSTANT) - gfc_set_constant_character_len (len, c->initializer, -1); - else if (mpz_cmp (c->ts.u.cl->length->value.integer, - c->initializer->ts.u.cl->length->value.integer)) - { - gfc_constructor *ctor; - ctor = gfc_constructor_first (c->initializer->value.constructor); - - if (ctor) - { - int first_len; - bool has_ts = (c->initializer->ts.u.cl - && c->initializer->ts.u.cl->length_from_typespec); - - /* Remember the length of the first element for checking - that all elements *in the constructor* have the same - length. This need not be the length of the LHS! */ - gcc_assert (ctor->expr->expr_type == EXPR_CONSTANT); - gcc_assert (ctor->expr->ts.type == BT_CHARACTER); - first_len = ctor->expr->value.character.length; - - for ( ; ctor; ctor = gfc_constructor_next (ctor)) - if (ctor->expr->expr_type == EXPR_CONSTANT) - { - gfc_set_constant_character_len (len, ctor->expr, - has_ts ? -1 : first_len); - ctor->expr->ts.u.cl->length = gfc_copy_expr (c->ts.u.cl->length); - } - } - } - } + gfc_apply_init (&c->ts, &c->attr, c->initializer); /* Check array components. */ if (!c->attr.dimension) @@ -1952,7 +1952,7 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init, { gfc_error ("Pointer array component of structure at %C must have a " "deferred shape"); - t = false; + return false; } } else if (c->attr.allocatable) @@ -1961,7 +1961,7 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init, { gfc_error ("Allocatable component of structure at %C must have a " "deferred shape"); - t = false; + return false; } } else @@ -1970,20 +1970,15 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init, { gfc_error ("Array component of structure at %C must have an " "explicit shape"); - t = false; + return false; } } scalar: if (c->ts.type == BT_CLASS) - { - bool t2 = gfc_build_class_symbol (&c->ts, &c->attr, &c->as); + return gfc_build_class_symbol (&c->ts, &c->attr, &c->as); - if (t) - t = t2; - } - - return t; + return true; } @@ -2545,7 +2540,6 @@ gfc_match_kind_spec (gfc_typespec *ts, bool kind_expr_only) gfc_expr *e; match m, n; char c; - const char *msg; m = MATCH_NO; n = MATCH_YES; @@ -2603,11 +2597,8 @@ kind_expr: goto no_match; } - msg = gfc_extract_int (e, &ts->kind); - - if (msg != NULL) + if (gfc_extract_int (e, &ts->kind, 1)) { - gfc_error (msg); m = MATCH_ERROR; goto no_match; } @@ -2705,7 +2696,7 @@ match_char_kind (int * kind, int * is_iso_c) locus where; gfc_expr *e; match m, n; - const char *msg; + bool fail; m = MATCH_NO; e = NULL; @@ -2735,11 +2726,10 @@ match_char_kind (int * kind, int * is_iso_c) goto no_match; } - msg = gfc_extract_int (e, kind); + fail = gfc_extract_int (e, kind, 1); *is_iso_c = e->ts.is_iso_c; - if (msg != NULL) + if (fail) { - gfc_error (msg); m = MATCH_ERROR; goto no_match; } @@ -2938,31 +2928,36 @@ done: /* Matches a RECORD declaration. */ static match -match_record_decl (const char *name) +match_record_decl (char *name) { locus old_loc; old_loc = gfc_current_locus; + match m; - if (gfc_match (" record") == MATCH_YES) + m = gfc_match (" record /"); + if (m == MATCH_YES) { - if (!gfc_option.flag_dec_structure) + if (!flag_dec_structure) { gfc_current_locus = old_loc; gfc_error ("RECORD at %C is an extension, enable it with " "-fdec-structure"); return MATCH_ERROR; } - if (gfc_match (" /%n/", name) != MATCH_YES) - { - gfc_error ("Structure name expected after RECORD at %C"); - gfc_current_locus = old_loc; - return MATCH_ERROR; - } - return MATCH_YES; + m = gfc_match (" %n/", name); + if (m == MATCH_YES) + return MATCH_YES; } - gfc_current_locus = old_loc; + gfc_current_locus = old_loc; + if (flag_dec_structure + && (gfc_match (" record% ") == MATCH_YES + || gfc_match (" record%t") == MATCH_YES)) + gfc_error ("Structure name expected after RECORD at %C"); + if (m == MATCH_NO) return MATCH_NO; + + return MATCH_ERROR; } /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts @@ -3143,7 +3138,7 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) * don't need all the extra derived-type stuff for structures. */ if (gfc_find_symbol (gfc_dt_upper_string (name), NULL, 1, &sym)) { - gfc_error ("Type name '%s' at %C is ambiguous", name); + gfc_error ("Type name %qs at %C is ambiguous", name); return MATCH_ERROR; } if (sym && sym->attr.flavor == FL_STRUCT) @@ -3157,26 +3152,26 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) else { /* Match nested STRUCTURE declarations; only valid within another - structure declaration. */ - m = gfc_match (" structure"); - if (m == MATCH_ERROR) - return MATCH_ERROR; - else if (m == MATCH_YES) - { - if ( gfc_current_state () != COMP_STRUCTURE - && gfc_current_state () != COMP_MAP) - return MATCH_ERROR; - - m = gfc_match_structure_decl (); - if (m == MATCH_YES) - { - /* gfc_new_block is updated by match_structure_decl. */ - ts->type = BT_DERIVED; - ts->u.derived = gfc_new_block; - return MATCH_YES; - } - return MATCH_ERROR; - } + structure declaration. */ + if (flag_dec_structure + && (gfc_current_state () == COMP_STRUCTURE + || gfc_current_state () == COMP_MAP)) + { + m = gfc_match (" structure"); + if (m == MATCH_YES) + { + m = gfc_match_structure_decl (); + if (m == MATCH_YES) + { + /* gfc_new_block is updated by match_structure_decl. */ + ts->type = BT_DERIVED; + ts->u.derived = gfc_new_block; + return MATCH_YES; + } + } + if (m == MATCH_ERROR) + return MATCH_ERROR; + } /* Match CLASS declarations. */ m = gfc_match (" class ( * )"); @@ -3202,13 +3197,11 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) upe->attr.zero_comp = 1; if (!gfc_add_flavor (&upe->attr, FL_DERIVED, NULL, &gfc_current_locus)) - return MATCH_ERROR; - } + return MATCH_ERROR; + } else { - st = gfc_find_symtree (gfc_current_ns->sym_root, "STAR"); - if (st == NULL) - st = gfc_new_symtree (&gfc_current_ns->sym_root, "STAR"); + st = gfc_get_tbp_symtree (&gfc_current_ns->sym_root, "STAR"); st->n.sym = upe; upe->refs++; } @@ -3304,7 +3297,7 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) /* Use upper case to save the actual derived-type symbol. */ gfc_get_symbol (dt_name, NULL, &dt_sym); - dt_sym->name = gfc_get_string (sym->name); + dt_sym->name = gfc_get_string ("%s", sym->name); head = sym->generic; intr = gfc_get_interface (); intr->sym = dt_sym; @@ -3824,6 +3817,7 @@ match_attr_spec (void) DECL_ALLOCATABLE = GFC_DECL_BEGIN, DECL_DIMENSION, DECL_EXTERNAL, DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL, DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE, + DECL_STATIC, DECL_AUTOMATIC, DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE, DECL_IS_BIND_C, DECL_CODIMENSION, DECL_ASYNCHRONOUS, DECL_CONTIGUOUS, DECL_NONE, GFC_DECL_END /* Sentinel */ @@ -3887,6 +3881,14 @@ match_attr_spec (void) d = DECL_ASYNCHRONOUS; } break; + + case 'u': + if (match_string_p ("tomatic")) + { + /* Matched "automatic". */ + d = DECL_AUTOMATIC; + } + break; } break; @@ -3911,6 +3913,7 @@ match_attr_spec (void) d = DECL_CODIMENSION; break; } + /* FALLTHRU */ case 'n': if (match_string_p ("tiguous")) { @@ -4015,8 +4018,25 @@ match_attr_spec (void) break; case 's': - if (match_string_p ("save")) - d = DECL_SAVE; + gfc_next_ascii_char (); + switch (gfc_next_ascii_char ()) + { + case 'a': + if (match_string_p ("ve")) + { + /* Matched "save". */ + d = DECL_SAVE; + } + break; + + case 't': + if (match_string_p ("atic")) + { + /* Matched "static". */ + d = DECL_STATIC; + } + break; + } break; case 't': @@ -4153,6 +4173,12 @@ match_attr_spec (void) case DECL_SAVE: attr = "SAVE"; break; + case DECL_STATIC: + attr = "STATIC"; + break; + case DECL_AUTOMATIC: + attr = "AUTOMATIC"; + break; case DECL_TARGET: attr = "TARGET"; break; @@ -4181,6 +4207,18 @@ match_attr_spec (void) if (seen[d] == 0) continue; + if ((d == DECL_STATIC || d == DECL_AUTOMATIC) + && !flag_dec_static) + { + gfc_error ("%s at %L is a DEC extension, enable with -fdec-static", + d == DECL_STATIC ? "STATIC" : "AUTOMATIC", &seen_at[d]); + m = MATCH_ERROR; + goto cleanup; + } + /* Allow SAVE with STATIC, but don't complain. */ + if (d == DECL_STATIC && seen[DECL_SAVE]) + continue; + if (gfc_current_state () == COMP_DERIVED && d != DECL_DIMENSION && d != DECL_CODIMENSION && d != DECL_POINTER && d != DECL_PRIVATE @@ -4319,10 +4357,15 @@ match_attr_spec (void) &seen_at[d]); break; + case DECL_STATIC: case DECL_SAVE: t = gfc_add_save (¤t_attr, SAVE_EXPLICIT, NULL, &seen_at[d]); break; + case DECL_AUTOMATIC: + t = gfc_add_automatic (¤t_attr, NULL, &seen_at[d]); + break; + case DECL_TARGET: t = gfc_add_target (¤t_attr, &seen_at[d]); break; @@ -4807,6 +4850,10 @@ gfc_match_data_decl (void) if (current_attr.pointer && gfc_comp_struct (gfc_current_state ())) goto ok; + if (current_attr.allocatable && gfc_current_state () == COMP_DERIVED + && current_ts.u.derived == gfc_current_block ()) + goto ok; + gfc_find_symbol (current_ts.u.derived->name, current_ts.u.derived->ns, 1, &sym); @@ -4851,7 +4898,28 @@ ok: } if (!gfc_error_flag_test ()) - gfc_error ("Syntax error in data declaration at %C"); + { + /* An anonymous structure declaration is unambiguous; if we matched one + according to gfc_match_structure_decl, we need to return MATCH_YES + here to avoid confusing the remaining matchers, even if there was an + error during variable_decl. We must flush any such errors. Note this + causes the parser to gracefully continue parsing the remaining input + as a structure body, which likely follows. */ + if (current_ts.type == BT_DERIVED && current_ts.u.derived + && gfc_fl_struct (current_ts.u.derived->attr.flavor)) + { + gfc_error_now ("Syntax error in anonymous structure declaration" + " at %C"); + /* Skip the bad variable_decl and line up for the start of the + structure body. */ + gfc_error_recovery (); + m = MATCH_YES; + goto cleanup; + } + + gfc_error ("Syntax error in data declaration at %C"); + } + m = MATCH_ERROR; gfc_free_data_all (gfc_current_ns); @@ -4997,7 +5065,7 @@ copy_prefix (symbol_attribute *dest, locus *where) { gfc_error ("ELEMENTAL prefix in MODULE PROCEDURE interface is " "missing at %L", where); - return false; + return false; } if (dest->pure && !current_attr.pure) @@ -5362,6 +5430,7 @@ add_hidden_procptr_result (gfc_symbol *sym) gfc_get_sym_tree ("ppr@", gfc_current_ns->parent, &stree, false); st2 = gfc_new_symtree (&gfc_current_ns->sym_root, "ppr@"); st2->n.sym = stree->n.sym; + stree->n.sym->refs++; } sym->result = stree->n.sym; @@ -5454,7 +5523,8 @@ match_procedure_interface (gfc_symbol **proc_if) /* Resolve interface if possible. That way, attr.procedure is only set if it is declared by a later procedure-declaration-stmt, which is invalid per F08:C1216 (cf. resolve_procedure_interface). */ - while ((*proc_if)->ts.interface) + while ((*proc_if)->ts.interface + && *proc_if != (*proc_if)->ts.interface) *proc_if = (*proc_if)->ts.interface; if ((*proc_if)->attr.flavor == FL_UNKNOWN @@ -5990,7 +6060,6 @@ gfc_match_function_decl (void) sym->result = result; } - /* Warn if this procedure has the same name as an intrinsic. */ do_warn_intrinsic_shadow (sym, true); @@ -6688,7 +6757,7 @@ gfc_match_end (gfc_statement *st) match m; gfc_namespace *parent_ns, *ns, *prev_ns; gfc_namespace **nsp; - bool abreviated_modproc_decl; + bool abreviated_modproc_decl = false; bool got_matching_end = false; old_loc = gfc_current_locus; @@ -6712,15 +6781,17 @@ gfc_match_end (gfc_statement *st) state = gfc_state_stack->previous->state; block_name = gfc_state_stack->previous->sym == NULL ? NULL : gfc_state_stack->previous->sym->name; + abreviated_modproc_decl = gfc_state_stack->previous->sym + && gfc_state_stack->previous->sym->abr_modproc_decl; break; default: break; } - abreviated_modproc_decl - = gfc_current_block () - && gfc_current_block ()->abr_modproc_decl; + if (!abreviated_modproc_decl) + abreviated_modproc_decl = gfc_current_block () + && gfc_current_block ()->abr_modproc_decl; switch (state) { @@ -7054,7 +7125,7 @@ attr_decl1 (void) if (current_attr.dimension && sym->value) { gfc_error ("Dimensions specified for %s at %L after its " - "initialisation", sym->name, &var_locus); + "initialization", sym->name, &var_locus); m = MATCH_ERROR; goto cleanup; } @@ -7497,9 +7568,17 @@ access_attr_decl (gfc_statement st) goto syntax; case INTERFACE_GENERIC: + case INTERFACE_DTIO: + if (gfc_get_symbol (name, NULL, &sym)) goto done; + if (type == INTERFACE_DTIO + && gfc_current_ns->proc_name + && gfc_current_ns->proc_name->attr.flavor == FL_MODULE + && sym->attr.flavor == FL_UNKNOWN) + sym->attr.flavor = FL_PROCEDURE; + if (!gfc_add_access (&sym->attr, (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE, @@ -7769,10 +7848,16 @@ cleanup: match gfc_match_parameter (void) { + const char *term = " )%t"; match m; if (gfc_match_char ('(') == MATCH_NO) - return MATCH_NO; + { + /* With legacy PARAMETER statements, don't expect a terminating ')'. */ + if (!gfc_notify_std (GFC_STD_LEGACY, "PARAMETER without '()' at %C")) + return MATCH_NO; + term = " %t"; + } for (;;) { @@ -7780,7 +7865,7 @@ gfc_match_parameter (void) if (m != MATCH_YES) break; - if (gfc_match (" )%t") == MATCH_YES) + if (gfc_match (term) == MATCH_YES) break; if (gfc_match_char (',') != MATCH_YES) @@ -7795,6 +7880,114 @@ gfc_match_parameter (void) } +match +gfc_match_automatic (void) +{ + gfc_symbol *sym; + match m; + bool seen_symbol = false; + + if (!flag_dec_static) + { + gfc_error ("AUTOMATIC at %C is a DEC extension, enable with " + "-fdec-static"); + return MATCH_ERROR; + } + + gfc_match (" ::"); + + for (;;) + { + m = gfc_match_symbol (&sym, 0); + switch (m) + { + case MATCH_NO: + break; + + case MATCH_ERROR: + return MATCH_ERROR; + + case MATCH_YES: + if (!gfc_add_automatic (&sym->attr, sym->name, &gfc_current_locus)) + return MATCH_ERROR; + seen_symbol = true; + break; + } + + if (gfc_match_eos () == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + } + + if (!seen_symbol) + { + gfc_error ("Expected entity-list in AUTOMATIC statement at %C"); + return MATCH_ERROR; + } + + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in AUTOMATIC statement at %C"); + return MATCH_ERROR; +} + + +match +gfc_match_static (void) +{ + gfc_symbol *sym; + match m; + bool seen_symbol = false; + + if (!flag_dec_static) + { + gfc_error ("STATIC at %C is a DEC extension, enable with -fdec-static"); + return MATCH_ERROR; + } + + gfc_match (" ::"); + + for (;;) + { + m = gfc_match_symbol (&sym, 0); + switch (m) + { + case MATCH_NO: + break; + + case MATCH_ERROR: + return MATCH_ERROR; + + case MATCH_YES: + if (!gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name, + &gfc_current_locus)) + return MATCH_ERROR; + seen_symbol = true; + break; + } + + if (gfc_match_eos () == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + } + + if (!seen_symbol) + { + gfc_error ("Expected entity-list in STATIC statement at %C"); + return MATCH_ERROR; + } + + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in STATIC statement at %C"); + return MATCH_ERROR; +} + + /* Save statements have a special syntax. */ match @@ -8066,11 +8259,11 @@ gfc_match_submod_proc (void) /* Make sure that the result field is appropriately filled, even though the result symbol will be replaced later on. */ - if (sym->ts.interface && sym->ts.interface->attr.function) + if (sym->tlink && sym->tlink->attr.function) { - if (sym->ts.interface->result - && sym->ts.interface->result != sym->ts.interface) - sym->result= sym->ts.interface->result; + if (sym->tlink->result + && sym->tlink->result != sym->tlink) + sym->result= sym->tlink->result; else sym->result = sym; } @@ -8366,7 +8559,7 @@ gfc_get_type_attr_spec (symbol_attribute *attr, char *name) does NOT have a generic symbol matching the name given by the user. STRUCTUREs can share names with variables and PARAMETERs so we must allow for the creation of an independent symbol. - Other parameters are a message to prefix errors with, the name of the new + Other parameters are a message to prefix errors with, the name of the new type to be created, and the flavor to add to the resulting symbol. */ static bool @@ -8394,7 +8587,7 @@ get_struct_decl (const char *name, sym_flavor fl, locus *decl, if (sym->components != NULL || sym->attr.zero_comp) { - gfc_error ("Type definition of '%s' at %C was already defined at %L", + gfc_error ("Type definition of %qs at %C was already defined at %L", sym->name, &sym->declared_at); return false; } @@ -8431,31 +8624,31 @@ get_struct_decl (const char *name, sym_flavor fl, locus *decl, match gfc_match_map (void) { - /* Counter used to give unique internal names to map structures. */ - static unsigned int gfc_map_id = 0; - char name[GFC_MAX_SYMBOL_LEN + 1]; - gfc_symbol *sym; - locus old_loc; + /* Counter used to give unique internal names to map structures. */ + static unsigned int gfc_map_id = 0; + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_symbol *sym; + locus old_loc; - old_loc = gfc_current_locus; + old_loc = gfc_current_locus; - if (gfc_match_eos () != MATCH_YES) - { - gfc_error ("Junk after MAP statement at %C"); - gfc_current_locus = old_loc; - return MATCH_ERROR; - } + if (gfc_match_eos () != MATCH_YES) + { + gfc_error ("Junk after MAP statement at %C"); + gfc_current_locus = old_loc; + return MATCH_ERROR; + } - /* Map blocks are anonymous so we make up unique names for the symbol table - which are invalid Fortran identifiers. */ - snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "MM$%u", gfc_map_id++); + /* Map blocks are anonymous so we make up unique names for the symbol table + which are invalid Fortran identifiers. */ + snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "MM$%u", gfc_map_id++); - if (!get_struct_decl (name, FL_STRUCT, &old_loc, &sym)) - return MATCH_ERROR; + if (!get_struct_decl (name, FL_STRUCT, &old_loc, &sym)) + return MATCH_ERROR; - gfc_new_block = sym; + gfc_new_block = sym; - return MATCH_YES; + return MATCH_YES; } @@ -8464,31 +8657,31 @@ gfc_match_map (void) match gfc_match_union (void) { - /* Counter used to give unique internal names to union types. */ - static unsigned int gfc_union_id = 0; - char name[GFC_MAX_SYMBOL_LEN + 1]; - gfc_symbol *sym; - locus old_loc; + /* Counter used to give unique internal names to union types. */ + static unsigned int gfc_union_id = 0; + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_symbol *sym; + locus old_loc; - old_loc = gfc_current_locus; + old_loc = gfc_current_locus; - if (gfc_match_eos () != MATCH_YES) - { - gfc_error ("Junk after UNION statement at %C"); - gfc_current_locus = old_loc; - return MATCH_ERROR; - } + if (gfc_match_eos () != MATCH_YES) + { + gfc_error ("Junk after UNION statement at %C"); + gfc_current_locus = old_loc; + return MATCH_ERROR; + } - /* Unions are anonymous so we make up unique names for the symbol table - which are invalid Fortran identifiers. */ - snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "UU$%u", gfc_union_id++); + /* Unions are anonymous so we make up unique names for the symbol table + which are invalid Fortran identifiers. */ + snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "UU$%u", gfc_union_id++); - if (!get_struct_decl (name, FL_UNION, &old_loc, &sym)) - return MATCH_ERROR; + if (!get_struct_decl (name, FL_UNION, &old_loc, &sym)) + return MATCH_ERROR; - gfc_new_block = sym; + gfc_new_block = sym; - return MATCH_YES; + return MATCH_YES; } @@ -8500,69 +8693,162 @@ gfc_match_union (void) match gfc_match_structure_decl (void) { - /* Counter used to give unique internal names to anonymous structures. */ - int gfc_structure_id = 0; - char name[GFC_MAX_SYMBOL_LEN + 1]; - gfc_symbol *sym; - match m; - locus where; + /* Counter used to give unique internal names to anonymous structures. */ + static unsigned int gfc_structure_id = 0; + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_symbol *sym; + match m; + locus where; - if(!gfc_option.flag_dec_structure) - { - gfc_error ("STRUCTURE at %C is a DEC extension, enable with " - "-fdec-structure"); - return MATCH_ERROR; - } + if (!flag_dec_structure) + { + gfc_error ("STRUCTURE at %C is a DEC extension, enable with " + "-fdec-structure"); + return MATCH_ERROR; + } - name[0] = '\0'; + name[0] = '\0'; - m = gfc_match (" /%n/", name); - if (m != MATCH_YES) - { - /* Non-nested structure declarations require a structure name. */ - if (!gfc_comp_struct (gfc_current_state ())) - { - gfc_error ("Structure name expected in non-nested structure " - "declaration at %C"); - return MATCH_ERROR; - } - /* This is an anonymous structure; make up a unique name for it - (upper-case letters never make it to symbol names from the source). - The important thing is initializing the type variable - and setting gfc_new_symbol, which is immediately used by - parse_structure () and variable_decl () to add components of - this type. */ - snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "SS$%u", gfc_structure_id++); - } + m = gfc_match (" /%n/", name); + if (m != MATCH_YES) + { + /* Non-nested structure declarations require a structure name. */ + if (!gfc_comp_struct (gfc_current_state ())) + { + gfc_error ("Structure name expected in non-nested structure " + "declaration at %C"); + return MATCH_ERROR; + } + /* This is an anonymous structure; make up a unique name for it + (upper-case letters never make it to symbol names from the source). + The important thing is initializing the type variable + and setting gfc_new_symbol, which is immediately used by + parse_structure () and variable_decl () to add components of + this type. */ + snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "SS$%u", gfc_structure_id++); + } - where = gfc_current_locus; - /* No field list allowed after non-nested structure declaration. */ - if (!gfc_comp_struct (gfc_current_state ()) - && gfc_match_eos () != MATCH_YES) - { - gfc_error ("Junk after non-nested STRUCTURE statement at %C"); - return MATCH_ERROR; - } + where = gfc_current_locus; + /* No field list allowed after non-nested structure declaration. */ + if (!gfc_comp_struct (gfc_current_state ()) + && gfc_match_eos () != MATCH_YES) + { + gfc_error ("Junk after non-nested STRUCTURE statement at %C"); + return MATCH_ERROR; + } - /* Make sure the name is not the name of an intrinsic type. */ - if (gfc_is_intrinsic_typename (name)) - { - gfc_error ("Structure name '%s' at %C cannot be the same as an" - " intrinsic type", name); - return MATCH_ERROR; - } + /* Make sure the name is not the name of an intrinsic type. */ + if (gfc_is_intrinsic_typename (name)) + { + gfc_error ("Structure name %qs at %C cannot be the same as an" + " intrinsic type", name); + return MATCH_ERROR; + } - /* Store the actual type symbol for the structure with an upper-case first - letter (an invalid Fortran identifier). */ + /* Store the actual type symbol for the structure with an upper-case first + letter (an invalid Fortran identifier). */ - sprintf (name, gfc_dt_upper_string (name)); - if (!get_struct_decl (name, FL_STRUCT, &where, &sym)) - return MATCH_ERROR; + if (!get_struct_decl (gfc_dt_upper_string (name), FL_STRUCT, &where, &sym)) + return MATCH_ERROR; - gfc_new_block = sym; - return MATCH_YES; + gfc_new_block = sym; + return MATCH_YES; } + +/* This function does some work to determine which matcher should be used to + * match a statement beginning with "TYPE". This is used to disambiguate TYPE + * as an alias for PRINT from derived type declarations, TYPE IS statements, + * and derived type data declarations. */ + +match +gfc_match_type (gfc_statement *st) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + match m; + locus old_loc; + + /* Requires -fdec. */ + if (!flag_dec) + return MATCH_NO; + + m = gfc_match ("type"); + if (m != MATCH_YES) + return m; + /* If we already have an error in the buffer, it is probably from failing to + * match a derived type data declaration. Let it happen. */ + else if (gfc_error_flag_test ()) + return MATCH_NO; + + old_loc = gfc_current_locus; + *st = ST_NONE; + + /* If we see an attribute list before anything else it's definitely a derived + * type declaration. */ + if (gfc_match (" ,") == MATCH_YES || gfc_match (" ::") == MATCH_YES) + { + gfc_current_locus = old_loc; + *st = ST_DERIVED_DECL; + return gfc_match_derived_decl (); + } + + /* By now "TYPE" has already been matched. If we do not see a name, this may + * be something like "TYPE *" or "TYPE <fmt>". */ + m = gfc_match_name (name); + if (m != MATCH_YES) + { + /* Let print match if it can, otherwise throw an error from + * gfc_match_derived_decl. */ + gfc_current_locus = old_loc; + if (gfc_match_print () == MATCH_YES) + { + *st = ST_WRITE; + return MATCH_YES; + } + gfc_current_locus = old_loc; + *st = ST_DERIVED_DECL; + return gfc_match_derived_decl (); + } + + /* A derived type declaration requires an EOS. Without it, assume print. */ + m = gfc_match_eos (); + if (m == MATCH_NO) + { + /* Check manually for TYPE IS (... - this is invalid print syntax. */ + if (strncmp ("is", name, 3) == 0 + && gfc_match (" (", name) == MATCH_YES) + { + gfc_current_locus = old_loc; + gcc_assert (gfc_match (" is") == MATCH_YES); + *st = ST_TYPE_IS; + return gfc_match_type_is (); + } + gfc_current_locus = old_loc; + *st = ST_WRITE; + return gfc_match_print (); + } + else + { + /* By now we have "TYPE <name> <EOS>". Check first if the name is an + * intrinsic typename - if so let gfc_match_derived_decl dump an error. + * Otherwise if gfc_match_derived_decl fails it's probably an existing + * symbol which can be printed. */ + gfc_current_locus = old_loc; + m = gfc_match_derived_decl (); + if (gfc_is_intrinsic_typename (name) || m == MATCH_YES) + { + *st = ST_DERIVED_DECL; + return m; + } + gfc_current_locus = old_loc; + *st = ST_WRITE; + return gfc_match_print (); + } + + return MATCH_NO; +} + + /* Match the beginning of a derived type declaration. If a type name was the result of a function, then it is possible to have a symbol already to be known as a derived type yet have no components. */ @@ -8655,7 +8941,7 @@ gfc_match_derived_decl (void) { /* Use upper case to save the actual derived-type symbol. */ gfc_get_symbol (gfc_dt_upper_string (gensym->name), NULL, &sym); - sym->name = gfc_get_string (gensym->name); + sym->name = gfc_get_string ("%s", gensym->name); head = gensym->generic; intr = gfc_get_interface (); intr->sym = sym; @@ -9075,7 +9361,7 @@ match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc) if (m == MATCH_ERROR) goto error; if (m == MATCH_YES) - ba->pass_arg = gfc_get_string (arg); + ba->pass_arg = gfc_get_string ("%s", arg); gcc_assert ((m == MATCH_YES) == (ba->pass_arg != NULL)); found_passing = true; @@ -9336,6 +9622,8 @@ match_procedure_in_type (void) false)) return MATCH_ERROR; gfc_set_sym_referenced (stree->n.tb->u.specific->n.sym); + gfc_add_flavor(&stree->n.tb->u.specific->n.sym->attr, FL_PROCEDURE, + target, &stree->n.tb->u.specific->n.sym->declared_at); if (gfc_match_eos () == MATCH_YES) return MATCH_YES; @@ -9406,6 +9694,7 @@ gfc_match_generic (void) switch (op_type) { case INTERFACE_GENERIC: + case INTERFACE_DTIO: snprintf (bind_name, sizeof (bind_name), "%s", name); break; @@ -9441,6 +9730,7 @@ gfc_match_generic (void) switch (op_type) { + case INTERFACE_DTIO: case INTERFACE_USER_OP: case INTERFACE_GENERIC: { @@ -9448,14 +9738,7 @@ gfc_match_generic (void) gfc_symtree* st; st = gfc_find_symtree (is_op ? ns->tb_uop_root : ns->tb_sym_root, name); - if (st) - { - tb = st->n.tb; - gcc_assert (tb); - } - else - tb = NULL; - + tb = st ? st->n.tb : NULL; break; } @@ -9495,14 +9778,13 @@ gfc_match_generic (void) switch (op_type) { + case INTERFACE_DTIO: case INTERFACE_GENERIC: case INTERFACE_USER_OP: { const bool is_op = (op_type == INTERFACE_USER_OP); - gfc_symtree* st; - - st = gfc_new_symtree (is_op ? &ns->tb_uop_root : &ns->tb_sym_root, - name); + gfc_symtree* st = gfc_get_tbp_symtree (is_op ? &ns->tb_uop_root : + &ns->tb_sym_root, name); gcc_assert (st); st->n.tb = tb; |