X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Ffortran%2Fdecl.c;h=7a80f81b30a89118b6f56264019b836a411fd39a;hb=eb6e0f89020fbe1457af2af310cb6dd51f813f22;hp=92326e7066a2375671773e80b3dfdebc16c0d23d;hpb=0305ad9bd6e55a040f76d901f0cf31fcb245f19d;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 92326e7066a..7a80f81b30a 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -1,5 +1,5 @@ /* Declaration statement matcher - Copyright (C) 2002, 2004, 2005 Free Software Foundation, Inc. + Copyright (C) 2002, 2004, 2005, 2006 Free Software Foundation, Inc. Contributed by Andy Vaught This file is part of GCC. @@ -16,8 +16,8 @@ for more details. You should have received a copy of the GNU General Public License along with GCC; see the file COPYING. If not, write to the Free -Software Foundation, 59 Temple Place - Suite 330, Boston, MA -02111-1307, USA. */ +Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA +02110-1301, USA. */ #include "config.h" @@ -27,12 +27,12 @@ Software Foundation, 59 Temple Place - Suite 330, Boston, MA #include "parse.h" -/* This flag is set if a an old-style length selector is matched +/* This flag is set if an old-style length selector is matched during a type-declaration statement. */ static int old_char_selector; -/* When variables aquire types and attributes from a declaration +/* When variables acquire types and attributes from a declaration statement, they get them from the following static variables. The first part of a declaration sets these variables and the second part copies these into symbol structures. */ @@ -43,6 +43,30 @@ static symbol_attribute current_attr; static gfc_array_spec *current_as; static int colon_seen; +/* Initializer of the previous enumerator. */ + +static gfc_expr *last_initializer; + +/* History of all the enumerators is maintained, so that + kind values of all the enumerators could be updated depending + upon the maximum initialized value. */ + +typedef struct enumerator_history +{ + gfc_symbol *sym; + gfc_expr *initializer; + struct enumerator_history *next; +} +enumerator_history; + +/* Header of enum history chain. */ + +static enumerator_history *enum_history = NULL; + +/* Pointer of enum history node containing largest initializer. */ + +static enumerator_history *max_enum = NULL; + /* gfc_new_block points to the symbol of a newly matched block. */ gfc_symbol *gfc_new_block; @@ -179,26 +203,21 @@ var_element (gfc_data_variable * new) sym = new->expr->symtree->n.sym; - if(sym->value != NULL) + if (!sym->attr.function && gfc_current_ns->parent && gfc_current_ns->parent == sym->ns) { - gfc_error ("Variable '%s' at %C already has an initialization", - sym->name); + gfc_error ("Host associated variable '%s' may not be in the DATA " + "statement at %C.", sym->name); return MATCH_ERROR; } -#if 0 // TODO: Find out where to move this message - if (sym->attr.in_common) - /* See if sym is in the blank common block. */ - for (t = &sym->ns->blank_common; t; t = t->common_next) - if (sym == t->head) - { - gfc_error ("DATA statement at %C may not initialize variable " - "'%s' from blank COMMON", sym->name); - return MATCH_ERROR; - } -#endif + if (gfc_current_state () != COMP_BLOCK_DATA + && sym->attr.in_common + && gfc_notify_std (GFC_STD_GNU, "Extension: initialization of " + "common block variable '%s' in DATA statement at %C", + sym->name) == FAILURE) + return MATCH_ERROR; - if (gfc_add_data (&sym->attr, &new->expr->where) == FAILURE) + if (gfc_add_data (&sym->attr, sym->name, &new->expr->where) == FAILURE) return MATCH_ERROR; return MATCH_YES; @@ -401,7 +420,7 @@ match_old_style_init (const char *name) /* Match the stuff following a DATA statement. If ERROR_FLAG is set, we are matching a DATA statement and are therefore issuing an error if we encounter something unexpected, if not, we're trying to match - an old-style intialization expression of the form INTEGER I /2/. */ + an old-style initialization expression of the form INTEGER I /2/. */ match gfc_match_data (void) @@ -496,7 +515,7 @@ match_char_length (gfc_expr ** expr) if (m != MATCH_YES) return m; - m = gfc_match_small_literal_int (&length); + m = gfc_match_small_literal_int (&length, NULL); if (m == MATCH_ERROR) return m; @@ -530,29 +549,34 @@ syntax: } -/* Special subroutine for finding a symbol. If we're compiling a - function or subroutine and the parent compilation unit is an - interface, then check to see if the name we've been given is the - name of the interface (located in another namespace). If so, - return that symbol. If not, use gfc_get_symbol(). */ +/* Special subroutine for finding a symbol. Check if the name is found + in the current name space. If not, and we're compiling a function or + subroutine and the parent compilation unit is an interface, then check + to see if the name we've been given is the name of the interface + (located in another namespace). */ static int find_special (const char *name, gfc_symbol ** result) { gfc_state_data *s; + int i; + i = gfc_get_symbol (name, NULL, result); + if (i==0) + goto end; + if (gfc_current_state () != COMP_SUBROUTINE && gfc_current_state () != COMP_FUNCTION) - goto normal; + goto end; s = gfc_state_stack->previous; if (s == NULL) - goto normal; + goto end; if (s->state != COMP_INTERFACE) - goto normal; + goto end; if (s->sym == NULL) - goto normal; /* Nameless interface */ + goto end; /* Nameless interface */ if (strcmp (name, s->sym->name) == 0) { @@ -560,8 +584,8 @@ find_special (const char *name, gfc_symbol ** result) return 0; } -normal: - return gfc_get_symbol (name, NULL, result); +end: + return i; } @@ -579,17 +603,42 @@ get_proc_name (const char *name, gfc_symbol ** result) int rc; if (gfc_current_ns->parent == NULL) - return gfc_get_symbol (name, NULL, result); + rc = gfc_get_symbol (name, NULL, result); + else + rc = gfc_get_symbol (name, gfc_current_ns->parent, result); - rc = gfc_get_symbol (name, gfc_current_ns->parent, result); - if (*result == NULL) - return rc; + sym = *result; - /* ??? Deal with ENTRY problem */ + if (sym && !sym->new && gfc_current_state () != COMP_INTERFACE) + { + /* Trap another encompassed procedure with the same name. All + these conditions are necessary to avoid picking up an entry + whose name clashes with that of the encompassing procedure; + this is handled using gsymbols to register unique,globally + accessible names. */ + if (sym->attr.flavor != 0 + && sym->attr.proc != 0 + && sym->formal) + gfc_error_now ("Procedure '%s' at %C is already defined at %L", + name, &sym->declared_at); + + /* Trap declarations of attributes in encompassing scope. The + signature for this is that ts.kind is set. Legitimate + references only set ts.type. */ + if (sym->ts.kind != 0 + && sym->attr.proc == 0 + && gfc_current_ns->parent != NULL + && sym->attr.access == 0) + gfc_error_now ("Procedure '%s' at %C has an explicit interface" + " and must not have attributes declared at %L", + name, &sym->declared_at); + } + + if (gfc_current_ns->parent == NULL || *result == NULL) + return rc; st = gfc_new_symtree (&gfc_current_ns->sym_root, name); - sym = *result; st->n.sym = sym; sym->refs++; @@ -598,7 +647,8 @@ get_proc_name (const char *name, gfc_symbol ** result) if (sym->ns->proc_name != NULL && sym->ns->proc_name->attr.flavor == FL_MODULE && sym->attr.proc != PROC_MODULE - && gfc_add_procedure (&sym->attr, PROC_MODULE, NULL) == FAILURE) + && gfc_add_procedure (&sym->attr, PROC_MODULE, + sym->name, NULL) == FAILURE) rc = 2; return rc; @@ -615,7 +665,8 @@ build_sym (const char *name, gfc_charlen * cl, symbol_attribute attr; gfc_symbol *sym; - if (find_special (name, &sym)) + /* if (find_special (name, &sym)) */ + if (gfc_get_symbol (name, NULL, &sym)) return FAILURE; /* Start updating the symbol table. Add basic type attribute @@ -645,6 +696,87 @@ build_sym (const char *name, gfc_charlen * cl, return SUCCESS; } +/* Set character constant to the given length. The constant will be padded or + truncated. */ + +void +gfc_set_constant_character_len (int len, gfc_expr * expr) +{ + char * s; + int slen; + + gcc_assert (expr->expr_type == EXPR_CONSTANT); + gcc_assert (expr->ts.type == BT_CHARACTER && expr->ts.kind == 1); + + slen = expr->value.character.length; + if (len != slen) + { + s = gfc_getmem (len); + memcpy (s, expr->value.character.string, MIN (len, slen)); + if (len > slen) + memset (&s[slen], ' ', len - slen); + gfc_free (expr->value.character.string); + expr->value.character.string = s; + expr->value.character.length = len; + } +} + + +/* Function to create and update the enumerator history + using the information passed as arguments. + Pointer "max_enum" is also updated, to point to + enum history node containing largest initializer. + + SYM points to the symbol node of enumerator. + INIT points to its enumerator value. */ + +static void +create_enum_history(gfc_symbol *sym, gfc_expr *init) +{ + enumerator_history *new_enum_history; + gcc_assert (sym != NULL && init != NULL); + + new_enum_history = gfc_getmem (sizeof (enumerator_history)); + + new_enum_history->sym = sym; + new_enum_history->initializer = init; + new_enum_history->next = NULL; + + if (enum_history == NULL) + { + enum_history = new_enum_history; + max_enum = enum_history; + } + else + { + new_enum_history->next = enum_history; + enum_history = new_enum_history; + + if (mpz_cmp (max_enum->initializer->value.integer, + new_enum_history->initializer->value.integer) < 0) + max_enum = new_enum_history; + } +} + + +/* Function to free enum kind history. */ + +void +gfc_free_enum_history(void) +{ + enumerator_history *current = enum_history; + enumerator_history *next; + + while (current != NULL) + { + next = current->next; + gfc_free (current); + current = next; + } + max_enum = NULL; + enum_history = NULL; +} + /* Function called by variable_decl() that adds an initialization expression to a symbol. */ @@ -710,6 +842,42 @@ add_init_expr_to_sym (const char *name, gfc_expr ** initp, && gfc_check_assign_symbol (sym, init) == FAILURE) return FAILURE; + if (sym->ts.type == BT_CHARACTER && sym->ts.cl) + { + /* Update symbol character length according initializer. */ + if (sym->ts.cl->length == NULL) + { + /* If there are multiple CHARACTER variables declared on + the same line, we don't want them to share the same + length. */ + sym->ts.cl = gfc_get_charlen (); + sym->ts.cl->next = gfc_current_ns->cl_list; + gfc_current_ns->cl_list = sym->ts.cl; + + if (init->expr_type == EXPR_CONSTANT) + sym->ts.cl->length = + gfc_int_expr (init->value.character.length); + else if (init->expr_type == EXPR_ARRAY) + sym->ts.cl->length = gfc_copy_expr (init->ts.cl->length); + } + /* Update initializer character length according symbol. */ + else if (sym->ts.cl->length->expr_type == EXPR_CONSTANT) + { + int len = mpz_get_si (sym->ts.cl->length->value.integer); + gfc_constructor * p; + + if (init->expr_type == EXPR_CONSTANT) + gfc_set_constant_character_len (len, init); + else if (init->expr_type == EXPR_ARRAY) + { + gfc_free_expr (init->ts.cl->length); + init->ts.cl->length = gfc_copy_expr (sym->ts.cl->length); + for (p = init->value.constructor; p; p = p->next) + gfc_set_constant_character_len (len, p->expr); + } + } + } + /* Add initializer. Make sure we keep the ranks sane. */ if (sym->attr.dimension && init->rank == 0) init->rank = sym->as->rank; @@ -718,6 +886,10 @@ add_init_expr_to_sym (const char *name, gfc_expr ** initp, *initp = NULL; } + /* Maintain enumerator history. */ + if (gfc_current_state () == COMP_ENUM) + create_enum_history (sym, init); + return SUCCESS; } @@ -818,8 +990,9 @@ gfc_match_null (gfc_expr ** result) gfc_intrinsic_symbol (sym); if (sym->attr.proc != PROC_INTRINSIC - && (gfc_add_procedure (&sym->attr, PROC_INTRINSIC, NULL) == FAILURE - || gfc_add_function (&sym->attr, NULL) == FAILURE)) + && (gfc_add_procedure (&sym->attr, PROC_INTRINSIC, + sym->name, NULL) == FAILURE + || gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)) return MATCH_ERROR; e = gfc_get_expr (); @@ -839,18 +1012,23 @@ gfc_match_null (gfc_expr ** result) symbol table or the current interface. */ static match -variable_decl (void) +variable_decl (int elem) { char name[GFC_MAX_SYMBOL_LEN + 1]; gfc_expr *initializer, *char_len; gfc_array_spec *as; + gfc_array_spec *cp_as; /* Extra copy for Cray Pointees. */ gfc_charlen *cl; locus var_locus; match m; try t; + gfc_symbol *sym; + locus old_locus; initializer = NULL; as = NULL; + cp_as = NULL; + old_locus = gfc_current_locus; /* When we get here, we've just matched a list of attributes and maybe a type and a double colon. The next thing we expect to see @@ -863,10 +1041,21 @@ variable_decl (void) /* Now we could see the optional array spec. or character length. */ m = gfc_match_array_spec (&as); - if (m == MATCH_ERROR) + if (gfc_option.flag_cray_pointer && m == MATCH_YES) + cp_as = gfc_copy_array_spec (as); + else if (m == MATCH_ERROR) goto cleanup; + if (m == MATCH_NO) as = gfc_copy_array_spec (current_as); + else if (gfc_current_state () == COMP_ENUM) + { + gfc_error ("Enumerator cannot be array at %C"); + gfc_free_enum_history (); + m = MATCH_ERROR; + goto cleanup; + } + char_len = NULL; cl = NULL; @@ -883,8 +1072,20 @@ variable_decl (void) cl->length = char_len; break; + /* Non-constant lengths need to be copied after the first + element. */ case MATCH_NO: - cl = current_ts.cl; + if (elem > 1 && current_ts.cl->length + && current_ts.cl->length->expr_type != EXPR_CONSTANT) + { + cl = gfc_get_charlen (); + cl->next = gfc_current_ns->cl_list; + gfc_current_ns->cl_list = cl; + cl->length = gfc_copy_expr (current_ts.cl->length); + } + else + cl = current_ts.cl; + break; case MATCH_ERROR: @@ -892,9 +1093,52 @@ variable_decl (void) } } + /* If this symbol has already shown up in a Cray Pointer declaration, + then we want to set the type & bail out. */ + if (gfc_option.flag_cray_pointer) + { + gfc_find_symbol (name, gfc_current_ns, 1, &sym); + if (sym != NULL && sym->attr.cray_pointee) + { + sym->ts.type = current_ts.type; + sym->ts.kind = current_ts.kind; + sym->ts.cl = cl; + sym->ts.derived = current_ts.derived; + m = MATCH_YES; + + /* Check to see if we have an array specification. */ + if (cp_as != NULL) + { + if (sym->as != NULL) + { + gfc_error ("Duplicate array spec for Cray pointee at %C."); + gfc_free_array_spec (cp_as); + m = MATCH_ERROR; + goto cleanup; + } + else + { + if (gfc_set_array_spec (sym, cp_as, &var_locus) == FAILURE) + gfc_internal_error ("Couldn't set pointee array spec."); + + /* Fix the array spec. */ + m = gfc_mod_pointee_as (sym->as); + if (m == MATCH_ERROR) + goto cleanup; + } + } + goto cleanup; + } + else + { + gfc_free_array_spec (cp_as); + } + } + + /* OK, we've successfully matched the declaration. Now put the symbol in the current namespace, because it might be used in the - optional intialization expression for this symbol, e.g. this is + optional initialization expression for this symbol, e.g. this is perfectly legal: integer, parameter :: i = huge(i) @@ -1007,6 +1251,30 @@ variable_decl (void) } } + /* Check if we are parsing an enumeration and if the current enumerator + variable has an initializer or not. If it does not have an + initializer, the initialization value of the previous enumerator + (stored in last_initializer) is incremented by 1 and is used to + initialize the current enumerator. */ + if (gfc_current_state () == COMP_ENUM) + { + if (initializer == NULL) + initializer = gfc_enum_initializer (last_initializer, old_locus); + + if (initializer == NULL || initializer->ts.type != BT_INTEGER) + { + gfc_error("ENUMERATOR %L not initialized with integer expression", + &var_locus); + m = MATCH_ERROR; + gfc_free_enum_history (); + goto cleanup; + } + + /* Store this current initializer, for the next enumerator + variable to be parsed. */ + last_initializer = initializer; + } + /* Add the initializer. Note that it is fine if initializer is NULL here, because we sometimes also need to check if a declaration *must* have an initialization expression. */ @@ -1014,7 +1282,7 @@ variable_decl (void) t = add_init_expr_to_sym (name, &initializer, &var_locus); else { - if (current_ts.type == BT_DERIVED && !initializer) + if (current_ts.type == BT_DERIVED && !current_attr.pointer && !initializer) initializer = gfc_default_initializer (¤t_ts); t = build_struct (name, cl, &initializer, &as); } @@ -1036,28 +1304,40 @@ match gfc_match_old_kind_spec (gfc_typespec * ts) { match m; + int original_kind; if (gfc_match_char ('*') != MATCH_YES) return MATCH_NO; - m = gfc_match_small_literal_int (&ts->kind); + m = gfc_match_small_literal_int (&ts->kind, NULL); if (m != MATCH_YES) return MATCH_ERROR; + original_kind = ts->kind; + /* Massage the kind numbers for complex types. */ - if (ts->type == BT_COMPLEX && ts->kind == 8) - ts->kind = 4; - if (ts->type == BT_COMPLEX && ts->kind == 16) - ts->kind = 8; + if (ts->type == BT_COMPLEX) + { + if (ts->kind % 2) + { + gfc_error ("Old-style type declaration %s*%d not supported at %C", + gfc_basic_typename (ts->type), original_kind); + return MATCH_ERROR; + } + ts->kind /= 2; + } if (gfc_validate_kind (ts->type, ts->kind, true) < 0) { - gfc_error ("Old-style kind %d not supported for type %s at %C", - ts->kind, gfc_basic_typename (ts->type)); - + gfc_error ("Old-style type declaration %s*%d not supported at %C", + gfc_basic_typename (ts->type), original_kind); return MATCH_ERROR; } + if (gfc_notify_std (GFC_STD_GNU, "Nonstandard type declaration %s*%d at %C", + gfc_basic_typename (ts->type), original_kind) == FAILURE) + return MATCH_ERROR; + return MATCH_YES; } @@ -1306,6 +1586,24 @@ match_type_spec (gfc_typespec * ts, int implicit_flag) gfc_clear_ts (ts); + if (gfc_match (" byte") == MATCH_YES) + { + if (gfc_notify_std(GFC_STD_GNU, "Extension: BYTE type at %C") + == FAILURE) + return MATCH_ERROR; + + if (gfc_validate_kind (BT_INTEGER, 1, true) < 0) + { + gfc_error ("BYTE type used at %C " + "is not available on the target machine"); + return MATCH_ERROR; + } + + ts->type = BT_INTEGER; + ts->kind = 1; + return MATCH_YES; + } + if (gfc_match (" integer") == MATCH_YES) { ts->type = BT_INTEGER; @@ -1345,6 +1643,10 @@ match_type_spec (gfc_typespec * ts, int implicit_flag) if (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) + return MATCH_ERROR; + ts->type = BT_COMPLEX; ts->kind = gfc_default_double_kind; return MATCH_YES; @@ -1369,7 +1671,7 @@ match_type_spec (gfc_typespec * ts, int implicit_flag) } if (sym->attr.flavor != FL_DERIVED - && gfc_add_flavor (&sym->attr, FL_DERIVED, NULL) == FAILURE) + && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE) return MATCH_ERROR; ts->type = BT_DERIVED; @@ -1691,6 +1993,12 @@ match_attr_spec (void) d = (decl_types) gfc_match_strings (decls); if (d == DECL_NONE || d == DECL_COLON) break; + + if (gfc_current_state () == COMP_ENUM) + { + gfc_error ("Enumerator cannot have attributes %C"); + return MATCH_ERROR; + } seen[d]++; seen_at[d] = gfc_current_locus; @@ -1710,6 +2018,18 @@ match_attr_spec (void) } } + /* If we are parsing an enumeration and have ensured that no other + attributes are present we can now set the parameter attribute. */ + if (gfc_current_state () == COMP_ENUM) + { + t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, NULL); + if (t == FAILURE) + { + m = MATCH_ERROR; + goto cleanup; + } + } + /* No double colon, so assume that we've been looking at something else the whole time. */ if (d == DECL_NONE) @@ -1794,6 +2114,20 @@ match_attr_spec (void) goto cleanup; } + if ((d == DECL_PRIVATE || d == DECL_PUBLIC) + && gfc_current_state () != COMP_MODULE) + { + if (d == DECL_PRIVATE) + attr = "PRIVATE"; + else + attr = "PUBLIC"; + + gfc_error ("%s attribute at %L is not allowed outside of a MODULE", + attr, &seen_at[d]); + m = MATCH_ERROR; + goto cleanup; + } + switch (d) { case DECL_ALLOCATABLE: @@ -1801,7 +2135,7 @@ match_attr_spec (void) break; case DECL_DIMENSION: - t = gfc_add_dimension (¤t_attr, &seen_at[d]); + t = gfc_add_dimension (¤t_attr, NULL, &seen_at[d]); break; case DECL_EXTERNAL: @@ -1829,7 +2163,7 @@ match_attr_spec (void) break; case DECL_PARAMETER: - t = gfc_add_flavor (¤t_attr, FL_PARAMETER, &seen_at[d]); + t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, &seen_at[d]); break; case DECL_POINTER: @@ -1837,15 +2171,17 @@ match_attr_spec (void) break; case DECL_PRIVATE: - t = gfc_add_access (¤t_attr, ACCESS_PRIVATE, &seen_at[d]); + t = gfc_add_access (¤t_attr, ACCESS_PRIVATE, NULL, + &seen_at[d]); break; case DECL_PUBLIC: - t = gfc_add_access (¤t_attr, ACCESS_PUBLIC, &seen_at[d]); + t = gfc_add_access (¤t_attr, ACCESS_PUBLIC, NULL, + &seen_at[d]); break; case DECL_SAVE: - t = gfc_add_save (¤t_attr, &seen_at[d]); + t = gfc_add_save (¤t_attr, NULL, &seen_at[d]); break; case DECL_TARGET: @@ -1881,6 +2217,7 @@ gfc_match_data_decl (void) { gfc_symbol *sym; match m; + int elem; m = match_type_spec (¤t_ts, 0); if (m != MATCH_YES) @@ -1912,17 +2249,21 @@ gfc_match_data_decl (void) if (current_attr.pointer && gfc_current_state () == COMP_DERIVED) goto ok; - if (gfc_find_symbol (current_ts.derived->name, - current_ts.derived->ns->parent, 1, &sym) == 0) - goto ok; + gfc_find_symbol (current_ts.derived->name, + current_ts.derived->ns->parent, 1, &sym); - /* Hope that an ambiguous symbol is itself masked by a type definition. */ - if (sym != NULL && sym->attr.flavor == FL_DERIVED) + /* Any symbol that we find had better be a type definition + which has its components defined. */ + if (sym != NULL && sym->attr.flavor == FL_DERIVED + && current_ts.derived->components != NULL) goto ok; - gfc_error ("Derived type at %C has not been previously defined"); - m = MATCH_ERROR; - goto cleanup; + /* Now we have an error, which we signal, and then fix up + because the knock-on is plain and simple confusing. */ + gfc_error_now ("Derived type at %C has not been previously defined " + "and so cannot appear in a derived type definition."); + current_attr.pointer = 1; + goto ok; } ok: @@ -1932,10 +2273,12 @@ ok: if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector) gfc_match_char (','); - /* Give the types/attributes to symbols that follow. */ + /* Give the types/attributes to symbols that follow. Give the element + a number so that repeat character length expressions can be copied. */ + elem = 1; for (;;) { - m = variable_decl (); + m = variable_decl (elem++); if (m == MATCH_ERROR) goto cleanup; if (m == MATCH_NO) @@ -2080,7 +2423,7 @@ gfc_match_formal_arglist (gfc_symbol * progname, int st_flag, int null_flag) dummy procedure. We don't apply these attributes to formal arguments of statement functions. */ if (sym != NULL && !st_flag - && (gfc_add_dummy (&sym->attr, NULL) == FAILURE + && (gfc_add_dummy (&sym->attr, sym->name, NULL) == FAILURE || gfc_missing_attr (&sym->attr, NULL) == FAILURE)) { m = MATCH_ERROR; @@ -2180,8 +2523,8 @@ match_result (gfc_symbol * function, gfc_symbol ** result) if (gfc_get_symbol (name, NULL, &r)) return MATCH_ERROR; - if (gfc_add_flavor (&r->attr, FL_VARIABLE, NULL) == FAILURE - || gfc_add_result (&r->attr, NULL) == FAILURE) + if (gfc_add_flavor (&r->attr, FL_VARIABLE, r->name, NULL) == FAILURE + || gfc_add_result (&r->attr, r->name, NULL) == FAILURE) return MATCH_ERROR; *result = r; @@ -2228,7 +2571,12 @@ gfc_match_function_decl (void) m = gfc_match_formal_arglist (sym, 0, 0); if (m == MATCH_NO) - gfc_error ("Expected formal argument list in function definition at %C"); + { + gfc_error ("Expected formal argument list in function " + "definition at %C"); + m = MATCH_ERROR; + goto cleanup; + } else if (m == MATCH_ERROR) goto cleanup; @@ -2251,7 +2599,7 @@ gfc_match_function_decl (void) /* Make changes to the symbol. */ m = MATCH_ERROR; - if (gfc_add_function (&sym->attr, NULL) == FAILURE) + if (gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE) goto cleanup; if (gfc_missing_attr (&sym->attr, NULL) == FAILURE @@ -2283,6 +2631,29 @@ cleanup: return m; } +/* This is mostly a copy of parse.c(add_global_procedure) but modified to pass the + name of the entry, rather than the gfc_current_block name, and to return false + upon finding an existing global entry. */ + +static bool +add_global_entry (const char * name, int sub) +{ + gfc_gsymbol *s; + + s = gfc_get_gsymbol(name); + + if (s->defined + || (s->type != GSYM_UNKNOWN && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION))) + global_used(s, NULL); + else + { + s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION; + s->where = gfc_current_locus; + s->defined = 1; + return true; + } + return false; +} /* Match an ENTRY statement. */ @@ -2296,17 +2667,64 @@ gfc_match_entry (void) gfc_compile_state state; match m; gfc_entry_list *el; + locus old_loc; m = gfc_match_name (name); if (m != MATCH_YES) return m; state = gfc_current_state (); - if (state != COMP_SUBROUTINE - && state != COMP_FUNCTION) + if (state != COMP_SUBROUTINE && state != COMP_FUNCTION) { - gfc_error ("ENTRY statement at %C cannot appear within %s", - gfc_state_name (gfc_current_state ())); + switch (state) + { + case COMP_PROGRAM: + gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM"); + break; + case COMP_MODULE: + gfc_error ("ENTRY statement at %C cannot appear within a MODULE"); + break; + case COMP_BLOCK_DATA: + gfc_error + ("ENTRY statement at %C cannot appear within a BLOCK DATA"); + break; + case COMP_INTERFACE: + gfc_error + ("ENTRY statement at %C cannot appear within an INTERFACE"); + break; + case COMP_DERIVED: + gfc_error + ("ENTRY statement at %C cannot appear " + "within a DERIVED TYPE block"); + break; + case COMP_IF: + gfc_error + ("ENTRY statement at %C cannot appear within an IF-THEN block"); + break; + case COMP_DO: + gfc_error + ("ENTRY statement at %C cannot appear within a DO block"); + break; + case COMP_SELECT: + gfc_error + ("ENTRY statement at %C cannot appear within a SELECT block"); + break; + case COMP_FORALL: + gfc_error + ("ENTRY statement at %C cannot appear within a FORALL block"); + break; + case COMP_WHERE: + gfc_error + ("ENTRY statement at %C cannot appear within a WHERE block"); + break; + case COMP_CONTAINS: + gfc_error + ("ENTRY statement at %C cannot appear " + "within a contained subprogram"); + break; + default: + gfc_internal_error ("gfc_match_entry(): Bad state"); + } return MATCH_ERROR; } @@ -2326,19 +2744,43 @@ gfc_match_entry (void) if (state == COMP_SUBROUTINE) { - /* And entry in a subroutine. */ + /* An entry in a subroutine. */ + if (!add_global_entry (name, 1)) + return MATCH_ERROR; + m = gfc_match_formal_arglist (entry, 0, 1); if (m != MATCH_YES) return MATCH_ERROR; - if (gfc_add_entry (&entry->attr, NULL) == FAILURE - || gfc_add_subroutine (&entry->attr, NULL) == FAILURE) + if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE + || gfc_add_subroutine (&entry->attr, entry->name, NULL) == FAILURE) return MATCH_ERROR; } else { - /* An entry in a function. */ - m = gfc_match_formal_arglist (entry, 0, 0); + /* An entry in a function. + We need to take special care because writing + ENTRY f() + as + ENTRY f + is allowed, whereas + ENTRY f() RESULT (r) + can't be written as + ENTRY f RESULT (r). */ + if (!add_global_entry (name, 0)) + return MATCH_ERROR; + + old_loc = gfc_current_locus; + if (gfc_match_eos () == MATCH_YES) + { + gfc_current_locus = old_loc; + /* Match the empty argument list, and add the interface to + the symbol. */ + m = gfc_match_formal_arglist (entry, 0, 1); + } + else + m = gfc_match_formal_arglist (entry, 0, 0); + if (m != MATCH_YES) return MATCH_ERROR; @@ -2346,12 +2788,11 @@ gfc_match_entry (void) if (gfc_match_eos () == MATCH_YES) { - if (gfc_add_entry (&entry->attr, NULL) == FAILURE - || gfc_add_function (&entry->attr, NULL) == FAILURE) + if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE + || gfc_add_function (&entry->attr, entry->name, NULL) == FAILURE) return MATCH_ERROR; - entry->result = proc->result; - + entry->result = entry; } else { @@ -2361,10 +2802,13 @@ gfc_match_entry (void) if (m != MATCH_YES) return MATCH_ERROR; - if (gfc_add_result (&result->attr, NULL) == FAILURE - || gfc_add_entry (&entry->attr, NULL) == FAILURE - || gfc_add_function (&entry->attr, NULL) == FAILURE) + if (gfc_add_result (&result->attr, result->name, NULL) == FAILURE + || gfc_add_entry (&entry->attr, result->name, NULL) == FAILURE + || gfc_add_function (&entry->attr, result->name, + NULL) == FAILURE) return MATCH_ERROR; + + entry->result = result; } if (proc->attr.recursive && result == NULL) @@ -2426,7 +2870,7 @@ gfc_match_subroutine (void) return MATCH_ERROR; gfc_new_block = sym; - if (gfc_add_subroutine (&sym->attr, NULL) == FAILURE) + if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE) return MATCH_ERROR; if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES) @@ -2461,6 +2905,40 @@ contained_procedure (void) return 0; } +/* Set the kind of each enumerator. The kind is selected such that it is + interoperable with the corresponding C enumeration type, making + sure that -fshort-enums is honored. */ + +static void +set_enum_kind(void) +{ + enumerator_history *current_history = NULL; + int kind; + int i; + + if (max_enum == NULL || enum_history == NULL) + return; + + if (!gfc_option.fshort_enums) + return; + + i = 0; + do + { + kind = gfc_integer_kinds[i++].kind; + } + while (kind < gfc_c_int_kind + && gfc_check_integer_range (max_enum->initializer->value.integer, + kind) != ARITH_OK); + + current_history = enum_history; + while (current_history != NULL) + { + current_history->sym->ts.kind = kind; + current_history = current_history->next; + } +} + /* Match any of the various end-block statements. Returns the type of END to the caller. The END INTERFACE, END IF, END DO and END SELECT statements cannot be replaced by a single END statement. */ @@ -2566,6 +3044,15 @@ gfc_match_end (gfc_statement * st) eos_ok = 0; break; + case COMP_ENUM: + *st = ST_END_ENUM; + target = " enum"; + eos_ok = 0; + last_initializer = NULL; + set_enum_kind (); + gfc_free_enum_history (); + break; + default: gfc_error ("Unexpected END statement at %C"); goto cleanup; @@ -2710,10 +3197,24 @@ attr_decl1 (void) m = MATCH_ERROR; goto cleanup; } + + if (sym->attr.cray_pointee && sym->as != NULL) + { + /* Fix the array spec. */ + m = gfc_mod_pointee_as (sym->as); + if (m == MATCH_ERROR) + goto cleanup; + } + + if (gfc_add_attribute (&sym->attr, &var_locus, current_attr.intent) == FAILURE) + { + m = MATCH_ERROR; + goto cleanup; + } if ((current_attr.external || current_attr.intrinsic) && sym->attr.flavor != FL_PROCEDURE - && gfc_add_flavor (&sym->attr, FL_PROCEDURE, NULL) == FAILURE) + && gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL) == FAILURE) { m = MATCH_ERROR; goto cleanup; @@ -2763,12 +3264,162 @@ attr_decl (void) } +/* This routine matches Cray Pointer declarations of the form: + pointer ( , ) + or + pointer ( , ), ( , ), ... + The pointer, if already declared, should be an integer. Otherwise, we + set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may + be either a scalar, or an array declaration. No space is allocated for + the pointee. For the statement + pointer (ipt, ar(10)) + any subsequent uses of ar will be translated (in C-notation) as + ar(i) => (( *) ipt)(i) + After gimplification, pointee variable will disappear in the code. */ + +static match +cray_pointer_decl (void) +{ + match m; + gfc_array_spec *as; + gfc_symbol *cptr; /* Pointer symbol. */ + gfc_symbol *cpte; /* Pointee symbol. */ + locus var_locus; + bool done = false; + + while (!done) + { + if (gfc_match_char ('(') != MATCH_YES) + { + gfc_error ("Expected '(' at %C"); + return MATCH_ERROR; + } + + /* Match pointer. */ + var_locus = gfc_current_locus; + gfc_clear_attr (¤t_attr); + gfc_add_cray_pointer (¤t_attr, &var_locus); + current_ts.type = BT_INTEGER; + current_ts.kind = gfc_index_integer_kind; + + m = gfc_match_symbol (&cptr, 0); + if (m != MATCH_YES) + { + gfc_error ("Expected variable name at %C"); + return m; + } + + if (gfc_add_cray_pointer (&cptr->attr, &var_locus) == FAILURE) + return MATCH_ERROR; + + gfc_set_sym_referenced (cptr); + + if (cptr->ts.type == BT_UNKNOWN) /* Override the type, if necessary. */ + { + cptr->ts.type = BT_INTEGER; + cptr->ts.kind = gfc_index_integer_kind; + } + else if (cptr->ts.type != BT_INTEGER) + { + gfc_error ("Cray pointer at %C must be an integer."); + return MATCH_ERROR; + } + else if (cptr->ts.kind < gfc_index_integer_kind) + gfc_warning ("Cray pointer at %C has %d bytes of precision;" + " memory addresses require %d bytes.", + cptr->ts.kind, + gfc_index_integer_kind); + + if (gfc_match_char (',') != MATCH_YES) + { + gfc_error ("Expected \",\" at %C"); + return MATCH_ERROR; + } + + /* Match Pointee. */ + var_locus = gfc_current_locus; + gfc_clear_attr (¤t_attr); + gfc_add_cray_pointee (¤t_attr, &var_locus); + current_ts.type = BT_UNKNOWN; + current_ts.kind = 0; + + m = gfc_match_symbol (&cpte, 0); + if (m != MATCH_YES) + { + gfc_error ("Expected variable name at %C"); + return m; + } + + /* Check for an optional array spec. */ + m = gfc_match_array_spec (&as); + if (m == MATCH_ERROR) + { + gfc_free_array_spec (as); + return m; + } + else if (m == MATCH_NO) + { + gfc_free_array_spec (as); + as = NULL; + } + + if (gfc_add_cray_pointee (&cpte->attr, &var_locus) == FAILURE) + return MATCH_ERROR; + + gfc_set_sym_referenced (cpte); + + if (cpte->as == NULL) + { + if (gfc_set_array_spec (cpte, as, &var_locus) == FAILURE) + gfc_internal_error ("Couldn't set Cray pointee array spec."); + } + else if (as != NULL) + { + gfc_error ("Duplicate array spec for Cray pointee at %C."); + gfc_free_array_spec (as); + return MATCH_ERROR; + } + + as = NULL; + + if (cpte->as != NULL) + { + /* Fix array spec. */ + m = gfc_mod_pointee_as (cpte->as); + if (m == MATCH_ERROR) + return m; + } + + /* Point the Pointee at the Pointer. */ + cpte->cp_pointer = cptr; + + if (gfc_match_char (')') != MATCH_YES) + { + gfc_error ("Expected \")\" at %C"); + return MATCH_ERROR; + } + m = gfc_match_char (','); + if (m != MATCH_YES) + done = true; /* Stop searching for more declarations. */ + + } + + if (m == MATCH_ERROR /* Failed when trying to find ',' above. */ + || gfc_match_eos () != MATCH_YES) + { + gfc_error ("Expected \",\" or end of statement at %C"); + return MATCH_ERROR; + } + return MATCH_YES; +} + + match gfc_match_external (void) { gfc_clear_attr (¤t_attr); - gfc_add_external (¤t_attr, NULL); + current_attr.external = 1; return attr_decl (); } @@ -2785,7 +3436,7 @@ gfc_match_intent (void) return MATCH_ERROR; gfc_clear_attr (¤t_attr); - gfc_add_intent (¤t_attr, intent, NULL); /* Can't fail */ + current_attr.intent = intent; return attr_decl (); } @@ -2796,7 +3447,7 @@ gfc_match_intrinsic (void) { gfc_clear_attr (¤t_attr); - gfc_add_intrinsic (¤t_attr, NULL); + current_attr.intrinsic = 1; return attr_decl (); } @@ -2807,7 +3458,7 @@ gfc_match_optional (void) { gfc_clear_attr (¤t_attr); - gfc_add_optional (¤t_attr, NULL); + current_attr.optional = 1; return attr_decl (); } @@ -2816,11 +3467,24 @@ gfc_match_optional (void) match gfc_match_pointer (void) { - - gfc_clear_attr (¤t_attr); - gfc_add_pointer (¤t_attr, NULL); - - return attr_decl (); + gfc_gobble_whitespace (); + if (gfc_peek_char () == '(') + { + if (!gfc_option.flag_cray_pointer) + { + gfc_error ("Cray pointer declaration at %C requires -fcray-pointer" + " flag."); + return MATCH_ERROR; + } + return cray_pointer_decl (); + } + else + { + gfc_clear_attr (¤t_attr); + current_attr.pointer = 1; + + return attr_decl (); + } } @@ -2829,7 +3493,7 @@ gfc_match_allocatable (void) { gfc_clear_attr (¤t_attr); - gfc_add_allocatable (¤t_attr, NULL); + current_attr.allocatable = 1; return attr_decl (); } @@ -2840,7 +3504,7 @@ gfc_match_dimension (void) { gfc_clear_attr (¤t_attr); - gfc_add_dimension (¤t_attr, NULL); + current_attr.dimension = 1; return attr_decl (); } @@ -2851,7 +3515,7 @@ gfc_match_target (void) { gfc_clear_attr (¤t_attr); - gfc_add_target (¤t_attr, NULL); + current_attr.target = 1; return attr_decl (); } @@ -2893,7 +3557,7 @@ access_attr_decl (gfc_statement st) if (gfc_add_access (&sym->attr, (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE, - NULL) == FAILURE) + sym->name, NULL) == FAILURE) return MATCH_ERROR; break; @@ -3036,12 +3700,22 @@ do_parm (void) } if (gfc_check_assign_symbol (sym, init) == FAILURE - || gfc_add_flavor (&sym->attr, FL_PARAMETER, NULL) == FAILURE) + || gfc_add_flavor (&sym->attr, FL_PARAMETER, sym->name, NULL) == FAILURE) { m = MATCH_ERROR; goto cleanup; } + if (sym->ts.type == BT_CHARACTER + && sym->ts.cl != NULL + && sym->ts.cl->length != NULL + && sym->ts.cl->length->expr_type == EXPR_CONSTANT + && init->expr_type == EXPR_CONSTANT + && init->ts.type == BT_CHARACTER + && init->ts.kind == 1) + gfc_set_constant_character_len ( + mpz_get_si (sym->ts.cl->length->value.integer), init); + sym->value = init; return MATCH_YES; @@ -3096,10 +3770,11 @@ gfc_match_save (void) { if (gfc_current_ns->seen_save) { - gfc_error ("Blanket SAVE statement at %C follows previous " - "SAVE statement"); - - return MATCH_ERROR; + if (gfc_notify_std (GFC_STD_LEGACY, + "Blanket SAVE statement at %C follows previous " + "SAVE statement") + == FAILURE) + return MATCH_ERROR; } gfc_current_ns->save_all = gfc_current_ns->seen_save = 1; @@ -3108,8 +3783,10 @@ gfc_match_save (void) if (gfc_current_ns->save_all) { - gfc_error ("SAVE statement at %C follows blanket SAVE statement"); - return MATCH_ERROR; + if (gfc_notify_std (GFC_STD_LEGACY, + "SAVE statement at %C follows blanket SAVE statement") + == FAILURE) + return MATCH_ERROR; } gfc_match (" ::"); @@ -3120,7 +3797,8 @@ gfc_match_save (void) switch (m) { case MATCH_YES: - if (gfc_add_save (&sym->attr, &gfc_current_locus) == FAILURE) + if (gfc_add_save (&sym->attr, sym->name, + &gfc_current_locus) == FAILURE) return MATCH_ERROR; goto next_item; @@ -3159,7 +3837,7 @@ syntax: /* Match a module procedure statement. Note that we have to modify symbols in the parent's namespace because the current one was there - to receive symbols that are in a interface's formal argument list. */ + to receive symbols that are in an interface's formal argument list. */ match gfc_match_modproc (void) @@ -3189,7 +3867,8 @@ gfc_match_modproc (void) return MATCH_ERROR; if (sym->attr.proc != PROC_MODULE - && gfc_add_procedure (&sym->attr, PROC_MODULE, NULL) == FAILURE) + && gfc_add_procedure (&sym->attr, PROC_MODULE, + sym->name, NULL) == FAILURE) return MATCH_ERROR; if (gfc_add_interface (sym) == FAILURE) @@ -3236,7 +3915,7 @@ loop: return MATCH_ERROR; } - if (gfc_add_access (&attr, ACCESS_PRIVATE, NULL) == FAILURE) + if (gfc_add_access (&attr, ACCESS_PRIVATE, NULL, NULL) == FAILURE) return MATCH_ERROR; goto loop; } @@ -3249,7 +3928,7 @@ loop: return MATCH_ERROR; } - if (gfc_add_access (&attr, ACCESS_PUBLIC, NULL) == FAILURE) + if (gfc_add_access (&attr, ACCESS_PUBLIC, NULL, NULL) == FAILURE) return MATCH_ERROR; goto loop; } @@ -3294,7 +3973,7 @@ loop: derived type that is a pointer. The first part of the AND clause is true if a the symbol is not the return value of a function. */ if (sym->attr.flavor != FL_DERIVED - && gfc_add_flavor (&sym->attr, FL_DERIVED, NULL) == FAILURE) + && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE) return MATCH_ERROR; if (sym->components != NULL) @@ -3306,10 +3985,120 @@ loop: } if (attr.access != ACCESS_UNKNOWN - && gfc_add_access (&sym->attr, attr.access, NULL) == FAILURE) + && gfc_add_access (&sym->attr, attr.access, sym->name, NULL) == FAILURE) return MATCH_ERROR; gfc_new_block = sym; return MATCH_YES; } + + +/* Cray Pointees can be declared as: + pointer (ipt, a (n,m,...,*)) + By default, this is treated as an AS_ASSUMED_SIZE array. We'll + cheat and set a constant bound of 1 for the last dimension, if this + is the case. Since there is no bounds-checking for Cray Pointees, + this will be okay. */ + +try +gfc_mod_pointee_as (gfc_array_spec *as) +{ + as->cray_pointee = true; /* This will be useful to know later. */ + if (as->type == AS_ASSUMED_SIZE) + { + as->type = AS_EXPLICIT; + as->upper[as->rank - 1] = gfc_int_expr (1); + as->cp_was_assumed = true; + } + else if (as->type == AS_ASSUMED_SHAPE) + { + gfc_error ("Cray Pointee at %C cannot be assumed shape array"); + return MATCH_ERROR; + } + return MATCH_YES; +} + + +/* Match the enum definition statement, here we are trying to match + the first line of enum definition statement. + Returns MATCH_YES if match is found. */ + +match +gfc_match_enum (void) +{ + match m; + + m = gfc_match_eos (); + if (m != MATCH_YES) + return m; + + if (gfc_notify_std (GFC_STD_F2003, + "New in Fortran 2003: ENUM AND ENUMERATOR at %C") + == FAILURE) + return MATCH_ERROR; + + return MATCH_YES; +} + + +/* Match the enumerator definition statement. */ + +match +gfc_match_enumerator_def (void) +{ + match m; + int elem; + + gfc_clear_ts (¤t_ts); + + m = gfc_match (" enumerator"); + if (m != MATCH_YES) + return m; + + if (gfc_current_state () != COMP_ENUM) + { + gfc_error ("ENUM definition statement expected before %C"); + gfc_free_enum_history (); + return MATCH_ERROR; + } + + (¤t_ts)->type = BT_INTEGER; + (¤t_ts)->kind = gfc_c_int_kind; + + m = match_attr_spec (); + if (m == MATCH_ERROR) + { + m = MATCH_NO; + goto cleanup; + } + + elem = 1; + for (;;) + { + m = variable_decl (elem++); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + break; + + if (gfc_match_eos () == MATCH_YES) + goto cleanup; + if (gfc_match_char (',') != MATCH_YES) + break; + } + + if (gfc_current_state () == COMP_ENUM) + { + gfc_free_enum_history (); + gfc_error ("Syntax error in ENUMERATOR definition at %C"); + m = MATCH_ERROR; + } + +cleanup: + gfc_free_array_spec (current_as); + current_as = NULL; + return m; + +} +