X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Ffortran%2Fdecl.c;h=3e7c6e618aa944615d13f8dbe29d0d7dd4863026;hb=4bf2d4f454c1294884468427b9865736c66686b0;hp=f7f48002d3f09473e942931897a69275bf0ae2a2;hpb=b3c3927c05d8ad190b76c56ae6020e1650b85a97;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index f7f48002d3f..3e7c6e618aa 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -1,5 +1,5 @@ /* Declaration statement matcher - Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008, 2009, 2010 + Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. Contributed by Andy Vaught @@ -26,6 +26,7 @@ along with GCC; see the file COPYING3. If not see #include "parse.h" #include "flags.h" #include "constructor.h" +#include "tree.h" /* Macros to access allocate memory for gfc_data_variable, gfc_data_value and gfc_data. */ @@ -34,6 +35,9 @@ along with GCC; see the file COPYING3. If not see #define gfc_get_data() XCNEW (gfc_data) +static gfc_try set_binding_label (const char **, const char *, int); + + /* This flag is set if an old-style length selector is matched during a type-declaration statement. */ @@ -51,7 +55,7 @@ static gfc_array_spec *current_as; static int colon_seen; /* The current binding label (if any). */ -static char curr_binding_label[GFC_MAX_BINDING_LABEL_LEN + 1]; +static const char* curr_binding_label; /* Need to know how many identifiers are on the current data declaration line in case we're given the BIND(C) attribute with a NAME= specifier. */ static int num_idents_on_line; @@ -119,7 +123,7 @@ free_variable (gfc_data_variable *p) gfc_free_expr (p->expr); gfc_free_iterator (&p->iter, 0); free_variable (p->list); - gfc_free (p); + free (p); } } @@ -134,8 +138,9 @@ free_value (gfc_data_value *p) for (; p; p = q) { q = p->next; + mpz_clear (p->repeat); gfc_free_expr (p->expr); - gfc_free (p); + free (p); } } @@ -152,7 +157,7 @@ gfc_free_data (gfc_data *p) q = p->next; free_variable (p->var); free_value (p->value); - gfc_free (p); + free (p); } } @@ -167,7 +172,7 @@ gfc_free_data_all (gfc_namespace *ns) for (;ns->data;) { d = ns->data->next; - gfc_free (ns->data); + free (ns->data); ns->data = d; } } @@ -322,7 +327,7 @@ static match match_data_constant (gfc_expr **result) { char name[GFC_MAX_SYMBOL_LEN + 1]; - gfc_symbol *sym; + gfc_symbol *sym, *dt_sym = NULL; gfc_expr *expr; match m; locus old_loc; @@ -365,15 +370,19 @@ match_data_constant (gfc_expr **result) if (gfc_find_symbol (name, NULL, 1, &sym)) return MATCH_ERROR; + if (sym && sym->attr.generic) + dt_sym = gfc_find_dt_in_generic (sym); + if (sym == NULL - || (sym->attr.flavor != FL_PARAMETER && sym->attr.flavor != FL_DERIVED)) + || (sym->attr.flavor != FL_PARAMETER + && (!dt_sym || dt_sym->attr.flavor != FL_DERIVED))) { gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C", name); return MATCH_ERROR; } - else if (sym->attr.flavor == FL_DERIVED) - return gfc_match_structure_constructor (sym, result, false); + else if (dt_sym && dt_sym->attr.flavor == FL_DERIVED) + return gfc_match_structure_constructor (dt_sym, result); /* Check to see if the value is an initialization array expression. */ if (sym->value->expr_type == EXPR_ARRAY) @@ -490,21 +499,24 @@ match_old_style_init (const char *name) m = top_val_list (newdata); if (m != MATCH_YES) { - gfc_free (newdata); + free (newdata); return m; } if (gfc_pure (NULL)) { gfc_error ("Initialization at %C is not allowed in a PURE procedure"); - gfc_free (newdata); + free (newdata); return MATCH_ERROR; } + if (gfc_implicit_pure (NULL)) + gfc_current_ns->proc_name->attr.implicit_pure = 0; + /* Mark the variable as having appeared in a data statement. */ if (gfc_add_data (&sym->attr, sym->name, &sym->declared_at) == FAILURE) { - gfc_free (newdata); + free (newdata); return MATCH_ERROR; } @@ -559,6 +571,9 @@ gfc_match_data (void) return MATCH_ERROR; } + if (gfc_implicit_pure (NULL)) + gfc_current_ns->proc_name->attr.implicit_pure = 0; + return MATCH_YES; cleanup: @@ -646,16 +661,27 @@ match_intent_spec (void) /* Matches a character length specification, which is either a - specification expression or a '*'. */ + specification expression, '*', or ':'. */ static match -char_len_param_value (gfc_expr **expr) +char_len_param_value (gfc_expr **expr, bool *deferred) { match m; + *expr = NULL; + *deferred = false; + if (gfc_match_char ('*') == MATCH_YES) + return MATCH_YES; + + if (gfc_match_char (':') == MATCH_YES) { - *expr = NULL; + if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: deferred type " + "parameter at %C") == FAILURE) + return MATCH_ERROR; + + *deferred = true; + return MATCH_YES; } @@ -696,11 +722,12 @@ syntax: char_len_param_value in parenthesis. */ static match -match_char_length (gfc_expr **expr) +match_char_length (gfc_expr **expr, bool *deferred) { int length; match m; + *deferred = false; m = gfc_match_char ('*'); if (m != MATCH_YES) return m; @@ -721,7 +748,7 @@ match_char_length (gfc_expr **expr) if (gfc_match_char ('(') == MATCH_NO) goto syntax; - m = char_len_param_value (expr); + m = char_len_param_value (expr, deferred); if (m != MATCH_YES && gfc_matching_function) { gfc_undo_symbols (); @@ -942,7 +969,7 @@ get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry) across platforms. */ gfc_try -verify_c_interop_param (gfc_symbol *sym) +gfc_verify_c_interop_param (gfc_symbol *sym) { int is_c_interop = 0; gfc_try retval = SUCCESS; @@ -981,20 +1008,24 @@ verify_c_interop_param (gfc_symbol *sym) { if (sym->ns->proc_name->attr.is_bind_c == 1) { - is_c_interop = - (verify_c_interop (&(sym->ts)) - == SUCCESS ? 1 : 0); + is_c_interop = (gfc_verify_c_interop (&(sym->ts)) == SUCCESS ? 1 : 0); if (is_c_interop != 1) { /* Make personalized messages to give better feedback. */ if (sym->ts.type == BT_DERIVED) - gfc_error ("Type '%s' at %L is a parameter to the BIND(C) " - " procedure '%s' but is not C interoperable " + gfc_error ("Variable '%s' at %L is a dummy argument to the " + "BIND(C) procedure '%s' but is not C interoperable " "because derived type '%s' is not C interoperable", sym->name, &(sym->declared_at), sym->ns->proc_name->name, sym->ts.u.derived->name); + else if (sym->ts.type == BT_CLASS) + gfc_error ("Variable '%s' at %L is a dummy argument to the " + "BIND(C) procedure '%s' but is not C interoperable " + "because it is polymorphic", + sym->name, &(sym->declared_at), + sym->ns->proc_name->name); else gfc_warning ("Variable '%s' at %L is a parameter to the " "BIND(C) procedure '%s' but may not be C " @@ -1041,14 +1072,22 @@ verify_c_interop_param (gfc_symbol *sym) retval = FAILURE; } - if (sym->attr.optional == 1) + if (sym->attr.optional == 1 && sym->attr.value) { - gfc_error ("Variable '%s' at %L cannot have the " - "OPTIONAL attribute because procedure '%s'" - " is BIND(C)", sym->name, &(sym->declared_at), + gfc_error ("Variable '%s' at %L cannot have both the OPTIONAL " + "and the VALUE attribute because procedure '%s' " + "is BIND(C)", sym->name, &(sym->declared_at), sym->ns->proc_name->name); retval = FAILURE; } + else if (sym->attr.optional == 1 + && gfc_notify_std (GFC_STD_F2008_TS, "TS29113: Variable '%s' " + "at %L with OPTIONAL attribute in " + "procedure '%s' which is BIND(C)", + sym->name, &(sym->declared_at), + sym->ns->proc_name->name) + == FAILURE) + retval = FAILURE; /* Make sure that if it has the dimension attribute, that it is either assumed size or explicit shape. */ @@ -1085,7 +1124,7 @@ verify_c_interop_param (gfc_symbol *sym) /* Function called by variable_decl() that adds a name to the symbol table. */ static gfc_try -build_sym (const char *name, gfc_charlen *cl, +build_sym (const char *name, gfc_charlen *cl, bool cl_deferred, gfc_array_spec **as, locus *var_locus) { symbol_attribute attr; @@ -1102,7 +1141,10 @@ build_sym (const char *name, gfc_charlen *cl, return FAILURE; if (sym->ts.type == BT_CHARACTER) - sym->ts.u.cl = cl; + { + sym->ts.u.cl = cl; + sym->ts.deferred = cl_deferred; + } /* Add dimension attribute if present. */ if (gfc_set_array_spec (sym, *as, var_locus) == FAILURE) @@ -1126,11 +1168,11 @@ build_sym (const char *name, gfc_charlen *cl, with a bind(c) and make sure the binding label is set correctly. */ if (sym->attr.is_bind_c == 1) { - if (sym->binding_label[0] == '\0') + if (!sym->binding_label) { /* Set the binding label and verify that if a NAME= was specified then only one identifier was in the entity-decl-list. */ - if (set_binding_label (sym->binding_label, sym->name, + if (set_binding_label (&sym->binding_label, sym->name, num_idents_on_line) == FAILURE) return FAILURE; } @@ -1156,12 +1198,7 @@ build_sym (const char *name, gfc_charlen *cl, sym->attr.implied_index = 0; if (sym->ts.type == BT_CLASS) - { - sym->attr.class_ok = (sym->attr.dummy - || sym->attr.pointer - || sym->attr.allocatable) ? 1 : 0; - gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as, false); - } + return gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as, false); return SUCCESS; } @@ -1203,7 +1240,7 @@ gfc_set_constant_character_len (int len, gfc_expr *expr, int check_len) &expr->where, slen, check_len); s[len] = '\0'; - gfc_free (expr->value.character.string); + free (expr->value.character.string); expr->value.character.string = s; expr->value.character.length = len; } @@ -1258,7 +1295,7 @@ gfc_free_enum_history (void) while (current != NULL) { next = current->next; - gfc_free (current); + free (current); current = next; } max_enum = NULL; @@ -1314,9 +1351,10 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus) } /* Check if the assignment can happen. This has to be put off - until later for a derived type variable. */ + until later for derived type variables and procedure pointers. */ if (sym->ts.type != BT_DERIVED && init->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS && init->ts.type != BT_CLASS + && !sym->attr.proc_pointer && gfc_check_assign_symbol (sym, init) == FAILURE) return FAILURE; @@ -1380,6 +1418,51 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus) } } + /* If sym is implied-shape, set its upper bounds from init. */ + if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension + && sym->as->type == AS_IMPLIED_SHAPE) + { + int dim; + + if (init->rank == 0) + { + gfc_error ("Can't initialize implied-shape array at %L" + " with scalar", &sym->declared_at); + return FAILURE; + } + gcc_assert (sym->as->rank == init->rank); + + /* Shape should be present, we get an initialization expression. */ + gcc_assert (init->shape); + + for (dim = 0; dim < sym->as->rank; ++dim) + { + int k; + gfc_expr* lower; + gfc_expr* e; + + lower = sym->as->lower[dim]; + if (lower->expr_type != EXPR_CONSTANT) + { + gfc_error ("Non-constant lower bound in implied-shape" + " declaration at %L", &lower->where); + return FAILURE; + } + + /* All dimensions must be without upper bound. */ + gcc_assert (!sym->as->upper[dim]); + + k = lower->ts.kind; + e = gfc_get_constant_expr (BT_INTEGER, k, &sym->declared_at); + mpz_add (e->value.integer, + lower->value.integer, init->shape[dim]); + mpz_sub_ui (e->value.integer, e->value.integer, 1); + sym->as->upper[dim] = e; + } + + sym->as->type = AS_EXPLICIT; + } + /* Need to check if the expression we initialized this to was one of the iso_c_binding named constants. If so, and we're a parameter (constant), let it be iso_c. @@ -1493,7 +1576,8 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init, /* 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 + 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; @@ -1570,7 +1654,12 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init, scalar: if (c->ts.type == BT_CLASS) - gfc_build_class_symbol (&c->ts, &c->attr, &c->as, true); + { + bool delayed = (gfc_state_stack->sym == c->ts.u.derived) + || (!c->ts.u.derived->components + && !c->ts.u.derived->attr.zero_comp); + return gfc_build_class_symbol (&c->ts, &c->attr, &c->as, delayed); + } return t; } @@ -1609,6 +1698,74 @@ gfc_match_null (gfc_expr **result) } +/* Match the initialization expr for a data pointer or procedure pointer. */ + +static match +match_pointer_init (gfc_expr **init, int procptr) +{ + match m; + + if (gfc_pure (NULL) && gfc_state_stack->state != COMP_DERIVED) + { + gfc_error ("Initialization of pointer at %C is not allowed in " + "a PURE procedure"); + return MATCH_ERROR; + } + + /* Match NULL() initilization. */ + m = gfc_match_null (init); + if (m != MATCH_NO) + return m; + + /* Match non-NULL initialization. */ + gfc_matching_ptr_assignment = !procptr; + gfc_matching_procptr_assignment = procptr; + m = gfc_match_rvalue (init); + gfc_matching_ptr_assignment = 0; + gfc_matching_procptr_assignment = 0; + if (m == MATCH_ERROR) + return MATCH_ERROR; + else if (m == MATCH_NO) + { + gfc_error ("Error in pointer initialization at %C"); + return MATCH_ERROR; + } + + if (!procptr) + gfc_resolve_expr (*init); + + if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: non-NULL pointer " + "initialization at %C") == FAILURE) + return MATCH_ERROR; + + return MATCH_YES; +} + + +static gfc_try +check_function_name (char *name) +{ + /* In functions that have a RESULT variable defined, the function name always + refers to function calls. Therefore, the name is not allowed to appear in + specification statements. When checking this, be careful about + 'hidden' procedure pointer results ('ppr@'). */ + + if (gfc_current_state () == COMP_FUNCTION) + { + gfc_symbol *block = gfc_current_block (); + if (block && block->result && block->result != block + && strcmp (block->result->name, "ppr@") != 0 + && strcmp (block->name, name) == 0) + { + gfc_error ("Function name '%s' not allowed at %C", name); + return FAILURE; + } + } + + return SUCCESS; +} + + /* Match a variable name with an optional initializer. When this subroutine is called, a variable is expected to be parsed next. Depending on what is happening at the moment, updates either the @@ -1622,6 +1779,7 @@ variable_decl (int elem) gfc_array_spec *as; gfc_array_spec *cp_as; /* Extra copy for Cray Pointees. */ gfc_charlen *cl; + bool cl_deferred; locus var_locus; match m; gfc_try t; @@ -1642,9 +1800,7 @@ variable_decl (int elem) /* Now we could see the optional array spec. or character length. */ m = gfc_match_array_spec (&as, true, true); - if (gfc_option.flag_cray_pointer && m == MATCH_YES) - cp_as = gfc_copy_array_spec (as); - else if (m == MATCH_ERROR) + if (m == MATCH_ERROR) goto cleanup; if (m == MATCH_NO) @@ -1652,12 +1808,44 @@ variable_decl (int elem) else if (current_as) merge_array_spec (current_as, as, true); + if (gfc_option.flag_cray_pointer) + cp_as = gfc_copy_array_spec (as); + + /* At this point, we know for sure if the symbol is PARAMETER and can thus + determine (and check) whether it can be implied-shape. If it + was parsed as assumed-size, change it because PARAMETERs can not + be assumed-size. */ + if (as) + { + if (as->type == AS_IMPLIED_SHAPE && current_attr.flavor != FL_PARAMETER) + { + m = MATCH_ERROR; + gfc_error ("Non-PARAMETER symbol '%s' at %L can't be implied-shape", + name, &var_locus); + goto cleanup; + } + + if (as->type == AS_ASSUMED_SIZE && as->rank == 1 + && current_attr.flavor == FL_PARAMETER) + as->type = AS_IMPLIED_SHAPE; + + if (as->type == AS_IMPLIED_SHAPE + && gfc_notify_std (GFC_STD_F2008, + "Fortran 2008: Implied-shape array at %L", + &var_locus) == FAILURE) + { + m = MATCH_ERROR; + goto cleanup; + } + } + char_len = NULL; cl = NULL; + cl_deferred = false; if (current_ts.type == BT_CHARACTER) { - switch (match_char_length (&char_len)) + switch (match_char_length (&char_len, &cl_deferred)) { case MATCH_YES: cl = gfc_new_charlen (gfc_current_ns, NULL); @@ -1678,6 +1866,8 @@ variable_decl (int elem) else cl = current_ts.u.cl; + cl_deferred = current_ts.deferred; + break; case MATCH_ERROR: @@ -1753,46 +1943,14 @@ variable_decl (int elem) create a symbol for those yet. If we fail to create the symbol, bail out. */ if (gfc_current_state () != COMP_DERIVED - && build_sym (name, cl, &as, &var_locus) == FAILURE) + && build_sym (name, cl, cl_deferred, &as, &var_locus) == FAILURE) { m = MATCH_ERROR; goto cleanup; } - /* An interface body specifies all of the procedure's - characteristics and these shall be consistent with those - specified in the procedure definition, except that the interface - may specify a procedure that is not pure if the procedure is - defined to be pure(12.3.2). */ - if (current_ts.type == BT_DERIVED - && gfc_current_ns->proc_name - && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY - && current_ts.u.derived->ns != gfc_current_ns) - { - gfc_symtree *st; - st = gfc_find_symtree (gfc_current_ns->sym_root, current_ts.u.derived->name); - if (!(current_ts.u.derived->attr.imported - && st != NULL - && st->n.sym == current_ts.u.derived) - && !gfc_current_ns->has_import_set) - { - gfc_error ("the type of '%s' at %C has not been declared within the " - "interface", name); - m = MATCH_ERROR; - goto cleanup; - } - } - - /* In functions that have a RESULT variable defined, the function - name always refers to function calls. Therefore, the name is - not allowed to appear in specification statements. */ - if (gfc_current_state () == COMP_FUNCTION - && gfc_current_block () != NULL - && gfc_current_block ()->result != NULL - && gfc_current_block ()->result != gfc_current_block () - && strcmp (gfc_current_block ()->name, name) == 0) + if (check_function_name (name) == FAILURE) { - gfc_error ("Function name '%s' not allowed at %C", name); m = MATCH_ERROR; goto cleanup; } @@ -1828,23 +1986,9 @@ variable_decl (int elem) goto cleanup; } - m = gfc_match_null (&initializer); - if (m == MATCH_NO) - { - gfc_error ("Pointer initialization requires a NULL() at %C"); - m = MATCH_ERROR; - } - - if (gfc_pure (NULL) && gfc_state_stack->state != COMP_DERIVED) - { - gfc_error ("Initialization of pointer at %C is not allowed in " - "a PURE procedure"); - m = MATCH_ERROR; - } - + m = match_pointer_init (&initializer, 0); if (m != MATCH_YES) goto cleanup; - } else if (gfc_match_char ('=') == MATCH_YES) { @@ -1938,6 +2082,33 @@ gfc_match_old_kind_spec (gfc_typespec *ts) return MATCH_ERROR; } ts->kind /= 2; + + } + + if (ts->type == BT_INTEGER && ts->kind == 4 && gfc_option.flag_integer4_kind == 8) + ts->kind = 8; + + if (ts->type == BT_REAL || ts->type == BT_COMPLEX) + { + if (ts->kind == 4) + { + if (gfc_option.flag_real4_kind == 8) + ts->kind = 8; + if (gfc_option.flag_real4_kind == 10) + ts->kind = 10; + if (gfc_option.flag_real4_kind == 16) + ts->kind = 16; + } + + if (ts->kind == 8) + { + if (gfc_option.flag_real8_kind == 4) + ts->kind = 4; + if (gfc_option.flag_real8_kind == 10) + ts->kind = 10; + if (gfc_option.flag_real8_kind == 16) + ts->kind = 16; + } } if (gfc_validate_kind (ts->type, ts->kind, true) < 0) @@ -2083,7 +2254,33 @@ kind_expr: if(m == MATCH_ERROR) gfc_current_locus = where; - + + if (ts->type == BT_INTEGER && ts->kind == 4 && gfc_option.flag_integer4_kind == 8) + ts->kind = 8; + + if (ts->type == BT_REAL || ts->type == BT_COMPLEX) + { + if (ts->kind == 4) + { + if (gfc_option.flag_real4_kind == 8) + ts->kind = 8; + if (gfc_option.flag_real4_kind == 10) + ts->kind = 10; + if (gfc_option.flag_real4_kind == 16) + ts->kind = 16; + } + + if (ts->kind == 8) + { + if (gfc_option.flag_real8_kind == 4) + ts->kind = 4; + if (gfc_option.flag_real8_kind == 10) + ts->kind = 10; + if (gfc_option.flag_real8_kind == 16) + ts->kind = 16; + } + } + /* Return what we know from the test(s). */ return m; @@ -2175,16 +2372,18 @@ gfc_match_char_spec (gfc_typespec *ts) gfc_charlen *cl; gfc_expr *len; match m; + bool deferred; len = NULL; seen_length = 0; kind = 0; is_iso_c = 0; + deferred = false; /* Try the old-style specification first. */ old_char_selector = 0; - m = match_char_length (&len); + m = match_char_length (&len, &deferred); if (m != MATCH_NO) { if (m == MATCH_YES) @@ -2213,7 +2412,7 @@ gfc_match_char_spec (gfc_typespec *ts) if (gfc_match (" , len =") == MATCH_NO) goto rparen; - m = char_len_param_value (&len); + m = char_len_param_value (&len, &deferred); if (m == MATCH_NO) goto syntax; if (m == MATCH_ERROR) @@ -2226,7 +2425,7 @@ gfc_match_char_spec (gfc_typespec *ts) /* Try to match "LEN = " or "LEN = , KIND = ". */ if (gfc_match (" len =") == MATCH_YES) { - m = char_len_param_value (&len); + m = char_len_param_value (&len, &deferred); if (m == MATCH_NO) goto syntax; if (m == MATCH_ERROR) @@ -2246,7 +2445,7 @@ gfc_match_char_spec (gfc_typespec *ts) } /* Try to match ( ) or ( , [ KIND = ] ). */ - m = char_len_param_value (&len); + m = char_len_param_value (&len, &deferred); if (m == MATCH_NO) goto syntax; if (m == MATCH_ERROR) @@ -2305,6 +2504,7 @@ done: ts->u.cl = cl; ts->kind = kind == 0 ? gfc_default_character_kind : kind; + ts->deferred = deferred; /* We have to know if it was a c interoperable kind so we can do accurate type checking of bind(c) procs, etc. */ @@ -2339,10 +2539,11 @@ match gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) { char name[GFC_MAX_SYMBOL_LEN + 1]; - gfc_symbol *sym; + gfc_symbol *sym, *dt_sym; match m; char c; - bool seen_deferred_kind; + bool seen_deferred_kind, matched_type; + const char *dt_name; /* A belt and braces check that the typespec is correctly being treated as a deferred characteristic association. */ @@ -2354,7 +2555,7 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) ts->kind = -1; /* Clear the current binding label, in case one is given. */ - curr_binding_label[0] = '\0'; + curr_binding_label = NULL; if (gfc_match (" byte") == MATCH_YES) { @@ -2374,47 +2575,88 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) return MATCH_YES; } - if (gfc_match (" integer") == MATCH_YES) + + m = gfc_match (" type ( %n", name); + matched_type = (m == MATCH_YES); + + if ((matched_type && strcmp ("integer", name) == 0) + || (!matched_type && gfc_match (" integer") == MATCH_YES)) { ts->type = BT_INTEGER; ts->kind = gfc_default_integer_kind; goto get_kind; } - if (gfc_match (" character") == MATCH_YES) + if ((matched_type && strcmp ("character", name) == 0) + || (!matched_type && gfc_match (" character") == MATCH_YES)) { + if (matched_type + && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: TYPE with " + "intrinsic-type-spec at %C") == FAILURE) + return MATCH_ERROR; + ts->type = BT_CHARACTER; if (implicit_flag == 0) - return gfc_match_char_spec (ts); + m = gfc_match_char_spec (ts); else - return MATCH_YES; + m = MATCH_YES; + + if (matched_type && m == MATCH_YES && gfc_match_char (')') != MATCH_YES) + m = MATCH_ERROR; + + return m; } - if (gfc_match (" real") == MATCH_YES) + if ((matched_type && strcmp ("real", name) == 0) + || (!matched_type && gfc_match (" real") == MATCH_YES)) { ts->type = BT_REAL; ts->kind = gfc_default_real_kind; goto get_kind; } - if (gfc_match (" double precision") == MATCH_YES) + if ((matched_type + && (strcmp ("doubleprecision", name) == 0 + || (strcmp ("double", name) == 0 + && gfc_match (" precision") == MATCH_YES))) + || (!matched_type && gfc_match (" double precision") == MATCH_YES)) { + if (matched_type + && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: TYPE with " + "intrinsic-type-spec at %C") == FAILURE) + return MATCH_ERROR; + if (matched_type && gfc_match_char (')') != MATCH_YES) + return MATCH_ERROR; + ts->type = BT_REAL; ts->kind = gfc_default_double_kind; return MATCH_YES; } - if (gfc_match (" complex") == MATCH_YES) + if ((matched_type && strcmp ("complex", name) == 0) + || (!matched_type && gfc_match (" complex") == MATCH_YES)) { ts->type = BT_COMPLEX; ts->kind = gfc_default_complex_kind; goto get_kind; } - if (gfc_match (" double complex") == MATCH_YES) + if ((matched_type + && (strcmp ("doublecomplex", name) == 0 + || (strcmp ("double", name) == 0 + && gfc_match (" complex") == MATCH_YES))) + || (!matched_type && gfc_match (" double complex") == MATCH_YES)) { - if (gfc_notify_std (GFC_STD_GNU, "DOUBLE COMPLEX at %C does not " - "conform to the Fortran 95 standard") == FAILURE) + if (gfc_notify_std (GFC_STD_GNU, "Extension: DOUBLE COMPLEX at %C") + == FAILURE) + return MATCH_ERROR; + + if (matched_type + && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: TYPE with " + "intrinsic-type-spec at %C") == FAILURE) + return MATCH_ERROR; + + if (matched_type && gfc_match_char (')') != MATCH_YES) return MATCH_ERROR; ts->type = BT_COMPLEX; @@ -2422,18 +2664,31 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) return MATCH_YES; } - if (gfc_match (" logical") == MATCH_YES) + if ((matched_type && strcmp ("logical", name) == 0) + || (!matched_type && gfc_match (" logical") == MATCH_YES)) { ts->type = BT_LOGICAL; ts->kind = gfc_default_logical_kind; goto get_kind; } - m = gfc_match (" type ( %n )", name); + if (matched_type) + m = gfc_match_char (')'); + if (m == MATCH_YES) ts->type = BT_DERIVED; else { + /* Match CLASS declarations. */ + m = gfc_match (" class ( * )"); + if (m == MATCH_ERROR) + return MATCH_ERROR; + else if (m == MATCH_YES) + { + gfc_fatal_error ("Unlimited polymorphism at %C not yet supported"); + return MATCH_ERROR; + } + m = gfc_match (" class ( %n )", name); if (m != MATCH_YES) return m; @@ -2452,61 +2707,137 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) ts->u.derived = NULL; if (gfc_current_state () != COMP_INTERFACE && !gfc_find_symbol (name, NULL, 1, &sym) && sym) - ts->u.derived = sym; + { + sym = gfc_find_dt_in_generic (sym); + ts->u.derived = sym; + } return MATCH_YES; } /* Search for the name but allow the components to be defined later. If type = -1, this typespec has been seen in a function declaration but - the type could not be accessed at that point. */ + the type could not be accessed at that point. The actual derived type is + stored in a symtree with the first letter of the name captialized; the + symtree with the all lower-case name contains the associated + generic function. */ + dt_name = gfc_get_string ("%c%s", + (char) TOUPPER ((unsigned char) name[0]), + (const char*)&name[1]); sym = NULL; - if (ts->kind != -1 && gfc_get_ha_symbol (name, &sym)) + dt_sym = NULL; + if (ts->kind != -1) { - gfc_error ("Type name '%s' at %C is ambiguous", name); - return MATCH_ERROR; + gfc_get_ha_symbol (name, &sym); + if (sym->generic && gfc_find_symbol (dt_name, NULL, 0, &dt_sym)) + { + gfc_error ("Type name '%s' at %C is ambiguous", name); + return MATCH_ERROR; + } + if (sym->generic && !dt_sym) + dt_sym = gfc_find_dt_in_generic (sym); } else if (ts->kind == -1) { int iface = gfc_state_stack->previous->state != COMP_INTERFACE || gfc_current_ns->has_import_set; - if (gfc_find_symbol (name, NULL, iface, &sym)) + gfc_find_symbol (name, NULL, iface, &sym); + if (sym && sym->generic && gfc_find_symbol (dt_name, NULL, 1, &dt_sym)) { gfc_error ("Type name '%s' at %C is ambiguous", name); return MATCH_ERROR; } + if (sym && sym->generic && !dt_sym) + dt_sym = gfc_find_dt_in_generic (sym); ts->kind = 0; if (sym == NULL) return MATCH_NO; } - if (sym->attr.flavor != FL_DERIVED - && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE) - return MATCH_ERROR; + if ((sym->attr.flavor != FL_UNKNOWN + && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.generic)) + || sym->attr.subroutine) + { + gfc_error ("Type name '%s' at %C conflicts with previously declared " + "entity at %L, which has the same name", name, + &sym->declared_at); + return MATCH_ERROR; + } gfc_set_sym_referenced (sym); - ts->u.derived = sym; + if (!sym->attr.generic + && gfc_add_generic (&sym->attr, sym->name, NULL) == FAILURE) + return MATCH_ERROR; + + if (!sym->attr.function + && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE) + return MATCH_ERROR; + + if (!dt_sym) + { + gfc_interface *intr, *head; + + /* 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); + head = sym->generic; + intr = gfc_get_interface (); + intr->sym = dt_sym; + intr->where = gfc_current_locus; + intr->next = head; + sym->generic = intr; + sym->attr.if_source = IFSRC_DECL; + } + + gfc_set_sym_referenced (dt_sym); + + if (dt_sym->attr.flavor != FL_DERIVED + && gfc_add_flavor (&dt_sym->attr, FL_DERIVED, sym->name, NULL) + == FAILURE) + return MATCH_ERROR; + + ts->u.derived = dt_sym; return MATCH_YES; get_kind: + if (matched_type + && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: TYPE with " + "intrinsic-type-spec at %C") == FAILURE) + return MATCH_ERROR; + /* For all types except double, derived and character, look for an optional kind specifier. MATCH_NO is actually OK at this point. */ if (implicit_flag == 1) - return MATCH_YES; + { + if (matched_type && gfc_match_char (')') != MATCH_YES) + return MATCH_ERROR; + + return MATCH_YES; + } if (gfc_current_form == FORM_FREE) { c = gfc_peek_ascii_char (); if (!gfc_is_whitespace (c) && c != '*' && c != '(' && c != ':' && c != ',') - return MATCH_NO; + { + if (matched_type && c == ')') + { + gfc_next_ascii_char (); + return MATCH_YES; + } + return MATCH_NO; + } } m = gfc_match_kind_spec (ts, false); if (m == MATCH_NO && ts->type != BT_CHARACTER) m = gfc_match_old_kind_spec (ts); + if (matched_type && gfc_match_char (')') != MATCH_YES) + return MATCH_ERROR; + /* Defer association of the KIND expression of function results until after USE and IMPORT statements. */ if ((gfc_current_state () == COMP_NONE && gfc_error_flag_test ()) @@ -2778,6 +3109,7 @@ gfc_match_import (void) for(;;) { + sym = NULL; m = gfc_match (" %n", name); switch (m) { @@ -2788,7 +3120,7 @@ gfc_match_import (void) gfc_error ("Type name '%s' at %C is ambiguous", name); return MATCH_ERROR; } - else if (gfc_current_ns->proc_name->ns->parent != NULL + else if (!sym && gfc_current_ns->proc_name->ns->parent != NULL && gfc_find_symbol (name, gfc_current_ns->proc_name->ns->parent, 1, &sym)) @@ -2804,18 +3136,32 @@ gfc_match_import (void) return MATCH_ERROR; } - if (gfc_find_symtree (gfc_current_ns->sym_root,name)) + if (gfc_find_symtree (gfc_current_ns->sym_root, name)) { gfc_warning ("'%s' is already IMPORTed from host scoping unit " "at %C.", name); goto next_item; } - st = gfc_new_symtree (&gfc_current_ns->sym_root, sym->name); + st = gfc_new_symtree (&gfc_current_ns->sym_root, name); st->n.sym = sym; sym->refs++; sym->attr.imported = 1; + if (sym->attr.generic && (sym = gfc_find_dt_in_generic (sym))) + { + /* The actual derived type is stored in a symtree with the first + letter of the name captialized; the symtree with the all + lower-case name contains the associated generic function. */ + st = gfc_new_symtree (&gfc_current_ns->sym_root, + gfc_get_string ("%c%s", + (char) TOUPPER ((unsigned char) name[0]), + &name[1])); + st->n.sym = sym; + sym->refs++; + sym->attr.imported = 1; + } + goto next_item; case MATCH_NO: @@ -3128,7 +3474,7 @@ match_attr_spec (void) else if (m == MATCH_YES) { merge_array_spec (as, current_as, false); - gfc_free (as); + free (as); } if (m == MATCH_NO) @@ -3376,7 +3722,7 @@ match_attr_spec (void) break; case DECL_SAVE: - t = gfc_add_save (¤t_attr, NULL, &seen_at[d]); + t = gfc_add_save (¤t_attr, SAVE_EXPLICIT, NULL, &seen_at[d]); break; case DECL_TARGET: @@ -3416,6 +3762,11 @@ match_attr_spec (void) } } + /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */ + if (gfc_current_state () == COMP_MODULE && !current_attr.save + && (gfc_option.allow_std & GFC_STD_F2008) != 0) + current_attr.save = SAVE_IMPLICIT; + colon_seen = 1; return MATCH_YES; @@ -3433,8 +3784,9 @@ cleanup: (J3/04-007, section 15.4.1). If a binding label was given and there is more than one argument (num_idents), it is an error. */ -gfc_try -set_binding_label (char *dest_label, const char *sym_name, int num_idents) +static gfc_try +set_binding_label (const char **dest_label, const char *sym_name, + int num_idents) { if (num_idents > 1 && has_name_equals) { @@ -3443,17 +3795,15 @@ set_binding_label (char *dest_label, const char *sym_name, int num_idents) return FAILURE; } - if (curr_binding_label[0] != '\0') - { - /* Binding label given; store in temp holder til have sym. */ - strcpy (dest_label, curr_binding_label); - } + if (curr_binding_label) + /* Binding label given; store in temp holder til have sym. */ + *dest_label = curr_binding_label; else { /* No binding label given, and the NAME= specifier did not exist, which means there was no NAME="". */ if (sym_name != NULL && has_name_equals == 0) - strcpy (dest_label, sym_name); + *dest_label = IDENTIFIER_POINTER (get_identifier (sym_name)); } return SUCCESS; @@ -3474,10 +3824,13 @@ set_com_block_bind_c (gfc_common_head *com_block, int is_bind_c) /* Verify that the given gfc_typespec is for a C interoperable type. */ gfc_try -verify_c_interop (gfc_typespec *ts) +gfc_verify_c_interop (gfc_typespec *ts) { if (ts->type == BT_DERIVED && ts->u.derived != NULL) - return (ts->u.derived->ts.is_c_interop ? SUCCESS : FAILURE); + return (ts->u.derived->ts.is_c_interop || ts->u.derived->attr.is_bind_c) + ? SUCCESS : FAILURE; + else if (ts->type == BT_CLASS) + return FAILURE; else if (ts->is_c_interop != 1) return FAILURE; @@ -3550,7 +3903,7 @@ verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts, the given ts (current_ts), so look in both. */ if (tmp_sym->ts.type != BT_UNKNOWN || ts->type != BT_UNKNOWN) { - if (verify_c_interop (&(tmp_sym->ts)) != SUCCESS) + if (gfc_verify_c_interop (&(tmp_sym->ts)) != SUCCESS) { /* See if we're dealing with a sym in a common block or not. */ if (is_in_common == 1) @@ -3630,7 +3983,7 @@ verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts, /* See if the symbol has been marked as private. If it has, make sure there is no binding label and warn the user if there is one. */ if (tmp_sym->attr.access == ACCESS_PRIVATE - && tmp_sym->binding_label[0] != '\0') + && tmp_sym->binding_label) /* Use gfc_warning_now because we won't say that the symbol fails just because of this. */ gfc_warning_now ("Symbol '%s' at %L is marked PRIVATE but has been " @@ -3656,7 +4009,7 @@ set_verify_bind_c_sym (gfc_symbol *tmp_sym, int num_idents) /* Set the is_bind_c bit in symbol_attribute. */ gfc_add_is_bind_c (&(tmp_sym->attr), tmp_sym->name, &gfc_current_locus, 0); - if (set_binding_label (tmp_sym->binding_label, tmp_sym->name, + if (set_binding_label (&tmp_sym->binding_label, tmp_sym->name, num_idents) != SUCCESS) return FAILURE; @@ -3673,7 +4026,8 @@ set_verify_bind_c_com_block (gfc_common_head *com_block, int num_idents) gfc_try retval = SUCCESS; /* destLabel, common name, typespec (which may have binding label). */ - if (set_binding_label (com_block->binding_label, com_block->name, num_idents) + if (set_binding_label (&com_block->binding_label, com_block->name, + num_idents) != SUCCESS) return FAILURE; @@ -3784,7 +4138,7 @@ gfc_match_bind_c_stmt (void) /* This may not be necessary. */ gfc_clear_ts (ts); /* Clear the temporary binding label holder. */ - curr_binding_label[0] = '\0'; + curr_binding_label = NULL; /* Look for the bind(c). */ found_match = gfc_match_bind_c (NULL, true); @@ -3853,7 +4207,7 @@ gfc_match_data_decl (void) goto ok; gfc_find_symbol (current_ts.u.derived->name, - current_ts.u.derived->ns->parent, 1, &sym); + current_ts.u.derived->ns, 1, &sym); /* Any symbol that we find had better be a type definition which has its components defined. */ @@ -3917,45 +4271,81 @@ match gfc_match_prefix (gfc_typespec *ts) { bool seen_type; + bool seen_impure; + bool found_prefix; gfc_clear_attr (¤t_attr); - seen_type = 0; + seen_type = false; + seen_impure = false; gcc_assert (!gfc_matching_prefix); gfc_matching_prefix = true; -loop: - if (!seen_type && ts != NULL - && gfc_match_decl_type_spec (ts, 0) == MATCH_YES - && gfc_match_space () == MATCH_YES) + do { + found_prefix = false; - seen_type = 1; - goto loop; - } + if (!seen_type && ts != NULL + && gfc_match_decl_type_spec (ts, 0) == MATCH_YES + && gfc_match_space () == MATCH_YES) + { - if (gfc_match ("elemental% ") == MATCH_YES) - { - if (gfc_add_elemental (¤t_attr, NULL) == FAILURE) - goto error; + seen_type = true; + found_prefix = true; + } + + if (gfc_match ("elemental% ") == MATCH_YES) + { + if (gfc_add_elemental (¤t_attr, NULL) == FAILURE) + goto error; - goto loop; + found_prefix = true; + } + + if (gfc_match ("pure% ") == MATCH_YES) + { + if (gfc_add_pure (¤t_attr, NULL) == FAILURE) + goto error; + + found_prefix = true; + } + + if (gfc_match ("recursive% ") == MATCH_YES) + { + if (gfc_add_recursive (¤t_attr, NULL) == FAILURE) + goto error; + + found_prefix = true; + } + + /* IMPURE is a somewhat special case, as it needs not set an actual + attribute but rather only prevents ELEMENTAL routines from being + automatically PURE. */ + if (gfc_match ("impure% ") == MATCH_YES) + { + if (gfc_notify_std (GFC_STD_F2008, + "Fortran 2008: IMPURE procedure at %C") + == FAILURE) + goto error; + + seen_impure = true; + found_prefix = true; + } } + while (found_prefix); - if (gfc_match ("pure% ") == MATCH_YES) + /* IMPURE and PURE must not both appear, of course. */ + if (seen_impure && current_attr.pure) { - if (gfc_add_pure (¤t_attr, NULL) == FAILURE) - goto error; - - goto loop; + gfc_error ("PURE and IMPURE must not appear both at %C"); + goto error; } - if (gfc_match ("recursive% ") == MATCH_YES) + /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */ + if (!seen_impure && current_attr.elemental && !current_attr.pure) { - if (gfc_add_recursive (¤t_attr, NULL) == FAILURE) + if (gfc_add_pure (¤t_attr, NULL) == FAILURE) goto error; - - goto loop; } /* At this point, the next item is not a prefix. */ @@ -4456,7 +4846,8 @@ match_procedure_decl (void) return MATCH_ERROR; } /* Set binding label for BIND(C). */ - if (set_binding_label (sym->binding_label, sym->name, num) != SUCCESS) + if (set_binding_label (&sym->binding_label, sym->name, num) + != SUCCESS) return MATCH_ERROR; } @@ -4489,8 +4880,9 @@ match_procedure_decl (void) return MATCH_ERROR; sym->ts.interface = gfc_new_symbol ("", gfc_current_ns); sym->ts.interface->ts = current_ts; + sym->ts.interface->attr.flavor = FL_PROCEDURE; sym->ts.interface->attr.function = 1; - sym->attr.function = sym->ts.interface->attr.function; + sym->attr.function = 1; sym->attr.if_source = IFSRC_UNKNOWN; } @@ -4503,20 +4895,7 @@ match_procedure_decl (void) goto cleanup; } - m = gfc_match_null (&initializer); - if (m == MATCH_NO) - { - gfc_error ("Pointer initialization requires a NULL() at %C"); - m = MATCH_ERROR; - } - - if (gfc_pure (NULL)) - { - gfc_error ("Initialization of pointer at %C is not allowed in " - "a PURE procedure"); - m = MATCH_ERROR; - } - + m = match_pointer_init (&initializer, 1); if (m != MATCH_YES) goto cleanup; @@ -4636,25 +5015,15 @@ match_ppc_decl (void) c->ts = ts; c->ts.interface = gfc_new_symbol ("", gfc_current_ns); c->ts.interface->ts = ts; + c->ts.interface->attr.flavor = FL_PROCEDURE; c->ts.interface->attr.function = 1; - c->attr.function = c->ts.interface->attr.function; + c->attr.function = 1; c->attr.if_source = IFSRC_UNKNOWN; } if (gfc_match (" =>") == MATCH_YES) { - m = gfc_match_null (&initializer); - if (m == MATCH_NO) - { - gfc_error ("Pointer initialization requires a NULL() at %C"); - m = MATCH_ERROR; - } - if (gfc_pure (NULL)) - { - gfc_error ("Initialization of pointer at %C is not allowed in " - "a PURE procedure"); - m = MATCH_ERROR; - } + m = match_pointer_init (&initializer, 1); if (m != MATCH_YES) { gfc_free_expr (initializer); @@ -4734,6 +5103,7 @@ gfc_match_procedure (void) case COMP_MODULE: case COMP_SUBROUTINE: case COMP_FUNCTION: + case COMP_BLOCK: m = match_procedure_decl (); break; case COMP_INTERFACE: @@ -4963,6 +5333,10 @@ gfc_match_entry (void) if (m != MATCH_YES) return m; + if (gfc_notify_std (GFC_STD_F2008_OBS, "Fortran 2008 obsolescent feature: " + "ENTRY statement at %C") == FAILURE) + return MATCH_ERROR; + state = gfc_current_state (); if (state != COMP_SUBROUTINE && state != COMP_FUNCTION) { @@ -4991,6 +5365,7 @@ gfc_match_entry (void) "an IF-THEN block"); break; case COMP_DO: + case COMP_DO_CONCURRENT: gfc_error ("ENTRY statement at %C cannot appear within " "a DO block"); break; @@ -5316,7 +5691,7 @@ match gfc_match_bind_c (gfc_symbol *sym, bool allow_binding_name) { /* binding label, if exists */ - char binding_label[GFC_MAX_SYMBOL_LEN + 1]; + const char* binding_label = NULL; match double_quote; match single_quote; @@ -5324,10 +5699,6 @@ gfc_match_bind_c (gfc_symbol *sym, bool allow_binding_name) specifier or not. */ has_name_equals = 0; - /* Init the first char to nil so we can catch if we don't have - the label (name attr) or the symbol name yet. */ - binding_label[0] = '\0'; - /* This much we have to be able to match, in this order, if there is a bind(c) label. */ if (gfc_match (" bind ( c ") != MATCH_YES) @@ -5362,7 +5733,7 @@ gfc_match_bind_c (gfc_symbol *sym, bool allow_binding_name) /* Grab the binding label, using functions that will not lower case the names automatically. */ - if (gfc_match_name_C (binding_label) != MATCH_YES) + if (gfc_match_name_C (&binding_label) != MATCH_YES) return MATCH_ERROR; /* Get the closing quotation. */ @@ -5410,14 +5781,12 @@ gfc_match_bind_c (gfc_symbol *sym, bool allow_binding_name) /* Save the binding label to the symbol. If sym is null, we're probably matching the typespec attributes of a declaration and haven't gotten the name yet, and therefore, no symbol yet. */ - if (binding_label[0] != '\0') + if (binding_label) { if (sym != NULL) - { - strcpy (sym->binding_label, binding_label); - } + sym->binding_label = binding_label; else - strcpy (curr_binding_label, binding_label); + curr_binding_label = binding_label; } else if (allow_binding_name) { @@ -5426,7 +5795,7 @@ gfc_match_bind_c (gfc_symbol *sym, bool allow_binding_name) If name="" or allow_binding_name is false, no C binding name is created. */ if (sym != NULL && sym->name != NULL && has_name_equals == 0) - strncpy (sym->binding_label, sym->name, strlen (sym->name) + 1); + sym->binding_label = IDENTIFIER_POINTER (get_identifier (sym->name)); } if (has_name_equals && gfc_current_state () == COMP_INTERFACE @@ -5503,6 +5872,8 @@ gfc_match_end (gfc_statement *st) const char *target; int eos_ok; match m; + gfc_namespace *parent_ns, *ns, *prev_ns; + gfc_namespace **nsp; old_loc = gfc_current_locus; if (gfc_match ("end") != MATCH_YES) @@ -5516,7 +5887,7 @@ gfc_match_end (gfc_statement *st) { case COMP_ASSOCIATE: case COMP_BLOCK: - if (!strcmp (block_name, "block@")) + if (!strncmp (block_name, "block@", strlen("block@"))) block_name = NULL; break; @@ -5596,6 +5967,7 @@ gfc_match_end (gfc_statement *st) break; case COMP_DO: + case COMP_DO_CONCURRENT: *st = ST_ENDDO; target = " do"; eos_ok = 0; @@ -5642,7 +6014,14 @@ gfc_match_end (gfc_statement *st) if (gfc_match_eos () == MATCH_YES) { - if (!eos_ok) + if (!eos_ok && (*st == ST_END_SUBROUTINE || *st == ST_END_FUNCTION)) + { + if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: END statement " + "instead of %s statement at %L", + gfc_ascii_statement (*st), &old_loc) == FAILURE) + goto cleanup; + } + else if (!eos_ok) { /* We would have required END [something]. */ gfc_error ("%s statement expected at %L", @@ -5720,6 +6099,35 @@ syntax: cleanup: gfc_current_locus = old_loc; + + /* If we are missing an END BLOCK, we created a half-ready namespace. + Remove it from the parent namespace's sibling list. */ + + if (state == COMP_BLOCK) + { + parent_ns = gfc_current_ns->parent; + + nsp = &(gfc_state_stack->previous->tail->ext.block.ns); + + prev_ns = NULL; + ns = *nsp; + while (ns) + { + if (ns == gfc_current_ns) + { + if (prev_ns == NULL) + *nsp = NULL; + else + prev_ns->sibling = ns->sibling; + } + prev_ns = ns; + ns = ns->sibling; + } + + gfc_free_namespace (gfc_current_ns); + gfc_current_ns = parent_ns; + } + return MATCH_ERROR; } @@ -5747,6 +6155,12 @@ attr_decl1 (void) if (find_special (name, &sym, false)) return MATCH_ERROR; + if (check_function_name (name) == FAILURE) + { + m = MATCH_ERROR; + goto cleanup; + } + var_locus = gfc_current_locus; /* Deal with possible array specification for certain attributes. */ @@ -5798,17 +6212,15 @@ attr_decl1 (void) /* Update symbol table. DIMENSION attribute is set in gfc_set_array_spec(). For CLASS variables, this must be applied - to the first component, or '$data' field. */ - if (sym->ts.type == BT_CLASS) + to the first component, or '_data' field. */ + if (sym->ts.type == BT_CLASS && sym->ts.u.derived->attr.is_class) { - if (gfc_copy_attr (&CLASS_DATA (sym)->attr, ¤t_attr,&var_locus) + if (gfc_copy_attr (&CLASS_DATA (sym)->attr, ¤t_attr, &var_locus) == FAILURE) { m = MATCH_ERROR; goto cleanup; } - sym->attr.class_ok = (sym->attr.class_ok || current_attr.allocatable - || current_attr.pointer); } else { @@ -5819,6 +6231,13 @@ attr_decl1 (void) goto cleanup; } } + + if (sym->ts.type == BT_CLASS + && gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as, false) == FAILURE) + { + m = MATCH_ERROR; + goto cleanup; + } if (gfc_set_array_spec (sym, as, &var_locus) == FAILURE) { @@ -6192,7 +6611,7 @@ access_attr_decl (gfc_statement st) char name[GFC_MAX_SYMBOL_LEN + 1]; interface_type type; gfc_user_op *uop; - gfc_symbol *sym; + gfc_symbol *sym, *dt_sym; gfc_intrinsic_op op; match m; @@ -6222,13 +6641,31 @@ access_attr_decl (gfc_statement st) sym->name, NULL) == FAILURE) return MATCH_ERROR; + if (sym->attr.generic && (dt_sym = gfc_find_dt_in_generic (sym)) + && gfc_add_access (&dt_sym->attr, + (st == ST_PUBLIC) ? ACCESS_PUBLIC + : ACCESS_PRIVATE, + sym->name, NULL) == FAILURE) + return MATCH_ERROR; + break; case INTERFACE_INTRINSIC_OP: if (gfc_current_ns->operator_access[op] == ACCESS_UNKNOWN) { + gfc_intrinsic_op other_op; + gfc_current_ns->operator_access[op] = (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE; + + /* Handle the case if there is another op with the same + function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */ + other_op = gfc_equivalent_op (op); + + if (other_op != INTRINSIC_NONE) + gfc_current_ns->operator_access[other_op] = + (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE; + } else { @@ -6534,8 +6971,8 @@ gfc_match_save (void) switch (m) { case MATCH_YES: - if (gfc_add_save (&sym->attr, sym->name, &gfc_current_locus) - == FAILURE) + if (gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name, + &gfc_current_locus) == FAILURE) return MATCH_ERROR; goto next_item; @@ -6754,6 +7191,7 @@ gfc_match_modproc (void) char name[GFC_MAX_SYMBOL_LEN + 1]; gfc_symbol *sym; match m; + locus old_locus; gfc_namespace *module_ns; gfc_interface *old_interface_head, *interface; @@ -6782,10 +7220,23 @@ gfc_match_modproc (void) end up with a syntax error and need to recover. */ old_interface_head = gfc_current_interface_head (); + /* Check if the F2008 optional double colon appears. */ + gfc_gobble_whitespace (); + old_locus = gfc_current_locus; + if (gfc_match ("::") == MATCH_YES) + { + if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: double colon in " + "MODULE PROCEDURE statement at %L", &old_locus) + == FAILURE) + return MATCH_ERROR; + } + else + gfc_current_locus = old_locus; + for (;;) { - locus old_locus = gfc_current_locus; bool last = false; + old_locus = gfc_current_locus; m = gfc_match_name (name); if (m == MATCH_NO) @@ -6797,6 +7248,7 @@ gfc_match_modproc (void) current namespace. */ if (gfc_match_eos () == MATCH_YES) last = true; + if (!last && gfc_match_char (',') != MATCH_YES) goto syntax; @@ -6838,7 +7290,7 @@ syntax: while (interface != old_interface_head) { gfc_interface *i = interface->next; - gfc_free (interface); + free (interface); interface = i; } @@ -6849,6 +7301,7 @@ syntax: /* Check a derived type that is being extended. */ + static gfc_symbol* check_extended_derived_type (char *name) { @@ -6860,9 +7313,12 @@ check_extended_derived_type (char *name) return NULL; } + extended = gfc_find_dt_in_generic (extended); + + /* F08:C428. */ if (!extended) { - gfc_error ("No such symbol in TYPE definition at %C"); + gfc_error ("Symbol '%s' at %C has not been previously defined", name); return NULL; } @@ -6958,46 +7414,6 @@ gfc_get_type_attr_spec (symbol_attribute *attr, char *name) } -/* Assign a hash value for a derived type. The algorithm is that of - SDBM. The hashed string is '[module_name #] derived_name'. */ -static unsigned int -hash_value (gfc_symbol *sym) -{ - unsigned int hash = 0; - const char *c; - int i, len; - - /* Hash of the module or procedure name. */ - if (sym->module != NULL) - c = sym->module; - else if (sym->ns && sym->ns->proc_name - && sym->ns->proc_name->attr.flavor == FL_MODULE) - c = sym->ns->proc_name->name; - else - c = NULL; - - if (c) - { - len = strlen (c); - for (i = 0; i < len; i++, c++) - hash = (hash << 6) + (hash << 16) - hash + (*c); - - /* Disambiguate between 'a' in 'aa' and 'aa' in 'a'. */ - hash = (hash << 6) + (hash << 16) - hash + '#'; - } - - /* Hash of the derived type name. */ - len = strlen (sym->name); - c = sym->name; - for (i = 0; i < len; i++, c++) - hash = (hash << 6) + (hash << 16) - hash + (*c); - - /* Return the hash but take the modulus for the sake of module read, - even though this slightly increases the chance of collision. */ - return (hash % 100000000); -} - - /* 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. */ @@ -7008,11 +7424,12 @@ gfc_match_derived_decl (void) char name[GFC_MAX_SYMBOL_LEN + 1]; char parent[GFC_MAX_SYMBOL_LEN + 1]; symbol_attribute attr; - gfc_symbol *sym; + gfc_symbol *sym, *gensym; gfc_symbol *extended; match m; match is_type_attr_spec = MATCH_NO; bool seen_attr = false; + gfc_interface *intr = NULL, *head; if (gfc_current_state () == COMP_DERIVED) return MATCH_NO; @@ -7058,16 +7475,50 @@ gfc_match_derived_decl (void) return MATCH_ERROR; } - if (gfc_get_symbol (name, NULL, &sym)) + if (gfc_get_symbol (name, NULL, &gensym)) return MATCH_ERROR; - if (sym->ts.type != BT_UNKNOWN) + if (!gensym->attr.generic && gensym->ts.type != BT_UNKNOWN) { gfc_error ("Derived type name '%s' at %C already has a basic type " - "of %s", sym->name, gfc_typename (&sym->ts)); + "of %s", gensym->name, gfc_typename (&gensym->ts)); return MATCH_ERROR; } + if (!gensym->attr.generic + && gfc_add_generic (&gensym->attr, gensym->name, NULL) == FAILURE) + return MATCH_ERROR; + + if (!gensym->attr.function + && gfc_add_function (&gensym->attr, gensym->name, NULL) == FAILURE) + return MATCH_ERROR; + + sym = gfc_find_dt_in_generic (gensym); + + if (sym && (sym->components != NULL || sym->attr.zero_comp)) + { + gfc_error ("Derived type definition of '%s' at %C has already been " + "defined", sym->name); + return MATCH_ERROR; + } + + if (!sym) + { + /* Use upper case to save the actual derived-type symbol. */ + gfc_get_symbol (gfc_get_string ("%c%s", + (char) TOUPPER ((unsigned char) gensym->name[0]), + &gensym->name[1]), NULL, &sym); + sym->name = gfc_get_string (gensym->name); + head = gensym->generic; + intr = gfc_get_interface (); + intr->sym = sym; + intr->where = gfc_current_locus; + intr->sym->declared_at = gfc_current_locus; + intr->next = head; + gensym->generic = intr; + gensym->attr.if_source = IFSRC_DECL; + } + /* The symbol may already have the derived attribute without the components. The ways this can happen is via a function definition, an INTRINSIC statement or a subtype in another @@ -7077,16 +7528,18 @@ gfc_match_derived_decl (void) && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE) return MATCH_ERROR; - if (sym->components != NULL || sym->attr.zero_comp) - { - gfc_error ("Derived type definition of '%s' at %C has already been " - "defined", sym->name); - return MATCH_ERROR; - } - if (attr.access != ACCESS_UNKNOWN && gfc_add_access (&sym->attr, attr.access, sym->name, NULL) == FAILURE) return MATCH_ERROR; + else if (sym->attr.access == ACCESS_UNKNOWN + && gensym->attr.access != ACCESS_UNKNOWN + && gfc_add_access (&sym->attr, gensym->attr.access, sym->name, NULL) + == FAILURE) + return MATCH_ERROR; + + if (sym->attr.access != ACCESS_UNKNOWN + && gensym->attr.access == ACCESS_UNKNOWN) + gensym->attr.access = sym->attr.access; /* See if the derived type was labeled as bind(c). */ if (attr.is_bind_c != 0) @@ -7130,7 +7583,7 @@ gfc_match_derived_decl (void) if (!sym->hash_value) /* Set the hash for the compound name for this type. */ - sym->hash_value = hash_value (sym); + sym->hash_value = gfc_hash_value (sym); /* Take over the ABSTRACT attribute. */ sym->attr.abstract = attr.abstract; @@ -7252,7 +7705,7 @@ enumerator_decl (void) /* OK, we've successfully matched the declaration. Now put the symbol in the current namespace. If we fail to create the symbol, bail out. */ - if (build_sym (name, NULL, &as, &var_locus) == FAILURE) + if (build_sym (name, NULL, false, &as, &var_locus) == FAILURE) { m = MATCH_ERROR; goto cleanup; @@ -7622,8 +8075,8 @@ match_procedure_in_type (void) } /* Construct the data structure. */ + memset (&tb, 0, sizeof (tb)); tb.where = gfc_current_locus; - tb.is_generic = 0; /* Match binding attributes. */ m = match_binding_attributes (&tb, false, false); @@ -7781,6 +8234,9 @@ gfc_match_generic (void) ns = block->f2k_derived; gcc_assert (block && ns); + memset (&tbattr, 0, sizeof (tbattr)); + tbattr.where = gfc_current_locus; + /* See if we get an access-specifier. */ m = match_binding_attributes (&tbattr, true, false); if (m == MATCH_ERROR) @@ -7945,6 +8401,8 @@ gfc_match_generic (void) target->specific_st = target_st; target->specific = NULL; target->next = tb->u.generic; + target->is_operator = ((op_type == INTERFACE_USER_OP) + || (op_type == INTERFACE_INTRINSIC_OP)); tb->u.generic = target; } while (gfc_match (" ,") == MATCH_YES);