X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Ffortran%2Fdecl.c;h=7a80f81b30a89118b6f56264019b836a411fd39a;hb=eb6e0f89020fbe1457af2af310cb6dd51f813f22;hp=4ab58399f3df50e3bb4b3e3ecb8610d9771e61c2;hpb=b8a891cb5d4cde1adc1ab977b39c3cbab2dc9c28;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 4ab58399f3d..7a80f81b30a 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -1,5 +1,5 @@ /* Declaration statement matcher - Copyright (C) 2002, 2004 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,23 +16,23 @@ 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" +#include "system.h" #include "gfortran.h" #include "match.h" #include "parse.h" -#include -/* 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,11 +43,429 @@ 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; +/********************* DATA statement subroutines *********************/ + +/* Free a gfc_data_variable structure and everything beneath it. */ + +static void +free_variable (gfc_data_variable * p) +{ + gfc_data_variable *q; + + for (; p; p = q) + { + q = p->next; + gfc_free_expr (p->expr); + gfc_free_iterator (&p->iter, 0); + free_variable (p->list); + + gfc_free (p); + } +} + + +/* Free a gfc_data_value structure and everything beneath it. */ + +static void +free_value (gfc_data_value * p) +{ + gfc_data_value *q; + + for (; p; p = q) + { + q = p->next; + gfc_free_expr (p->expr); + gfc_free (p); + } +} + + +/* Free a list of gfc_data structures. */ + +void +gfc_free_data (gfc_data * p) +{ + gfc_data *q; + + for (; p; p = q) + { + q = p->next; + + free_variable (p->var); + free_value (p->value); + + gfc_free (p); + } +} + + +static match var_element (gfc_data_variable *); + +/* Match a list of variables terminated by an iterator and a right + parenthesis. */ + +static match +var_list (gfc_data_variable * parent) +{ + gfc_data_variable *tail, var; + match m; + + m = var_element (&var); + if (m == MATCH_ERROR) + return MATCH_ERROR; + if (m == MATCH_NO) + goto syntax; + + tail = gfc_get_data_variable (); + *tail = var; + + parent->list = tail; + + for (;;) + { + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + + m = gfc_match_iterator (&parent->iter, 1); + if (m == MATCH_YES) + break; + if (m == MATCH_ERROR) + return MATCH_ERROR; + + m = var_element (&var); + if (m == MATCH_ERROR) + return MATCH_ERROR; + if (m == MATCH_NO) + goto syntax; + + tail->next = gfc_get_data_variable (); + tail = tail->next; + + *tail = var; + } + + if (gfc_match_char (')') != MATCH_YES) + goto syntax; + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_DATA); + return MATCH_ERROR; +} + + +/* Match a single element in a data variable list, which can be a + variable-iterator list. */ + +static match +var_element (gfc_data_variable * new) +{ + match m; + gfc_symbol *sym; + + memset (new, 0, sizeof (gfc_data_variable)); + + if (gfc_match_char ('(') == MATCH_YES) + return var_list (new); + + m = gfc_match_variable (&new->expr, 0); + if (m != MATCH_YES) + return m; + + sym = new->expr->symtree->n.sym; + + if (!sym->attr.function && gfc_current_ns->parent && gfc_current_ns->parent == sym->ns) + { + gfc_error ("Host associated variable '%s' may not be in the DATA " + "statement at %C.", sym->name); + return MATCH_ERROR; + } + + 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, sym->name, &new->expr->where) == FAILURE) + return MATCH_ERROR; + + return MATCH_YES; +} + + +/* Match the top-level list of data variables. */ + +static match +top_var_list (gfc_data * d) +{ + gfc_data_variable var, *tail, *new; + match m; + + tail = NULL; + + for (;;) + { + m = var_element (&var); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + return MATCH_ERROR; + + new = gfc_get_data_variable (); + *new = var; + + if (tail == NULL) + d->var = new; + else + tail->next = new; + + tail = new; + + if (gfc_match_char ('/') == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + } + + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_DATA); + return MATCH_ERROR; +} + + +static match +match_data_constant (gfc_expr ** result) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_symbol *sym; + gfc_expr *expr; + match m; + + m = gfc_match_literal_constant (&expr, 1); + if (m == MATCH_YES) + { + *result = expr; + return MATCH_YES; + } + + if (m == MATCH_ERROR) + return MATCH_ERROR; + + m = gfc_match_null (result); + if (m != MATCH_NO) + return m; + + m = gfc_match_name (name); + if (m != MATCH_YES) + return m; + + if (gfc_find_symbol (name, NULL, 1, &sym)) + return MATCH_ERROR; + + if (sym == NULL + || (sym->attr.flavor != FL_PARAMETER && 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); + + *result = gfc_copy_expr (sym->value); + return MATCH_YES; +} + + +/* Match a list of values in a DATA statement. The leading '/' has + already been seen at this point. */ + +static match +top_val_list (gfc_data * data) +{ + gfc_data_value *new, *tail; + gfc_expr *expr; + const char *msg; + match m; + + tail = NULL; + + for (;;) + { + m = match_data_constant (&expr); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + return MATCH_ERROR; + + new = gfc_get_data_value (); + + if (tail == NULL) + data->value = new; + else + tail->next = new; + + tail = new; + + if (expr->ts.type != BT_INTEGER || gfc_match_char ('*') != MATCH_YES) + { + tail->expr = expr; + tail->repeat = 1; + } + else + { + signed int tmp; + msg = gfc_extract_int (expr, &tmp); + gfc_free_expr (expr); + if (msg != NULL) + { + gfc_error (msg); + return MATCH_ERROR; + } + tail->repeat = tmp; + + m = match_data_constant (&tail->expr); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + return MATCH_ERROR; + } + + if (gfc_match_char ('/') == MATCH_YES) + break; + if (gfc_match_char (',') == MATCH_NO) + goto syntax; + } + + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_DATA); + return MATCH_ERROR; +} + + +/* Matches an old style initialization. */ + +static match +match_old_style_init (const char *name) +{ + match m; + gfc_symtree *st; + gfc_data *newdata; + + /* Set up data structure to hold initializers. */ + gfc_find_sym_tree (name, NULL, 0, &st); + + newdata = gfc_get_data (); + newdata->var = gfc_get_data_variable (); + newdata->var->expr = gfc_get_variable_expr (st); + + /* Match initial value list. This also eats the terminal + '/'. */ + m = top_val_list (newdata); + if (m != MATCH_YES) + { + gfc_free (newdata); + return m; + } + + if (gfc_pure (NULL)) + { + gfc_error ("Initialization at %C is not allowed in a PURE procedure"); + gfc_free (newdata); + return MATCH_ERROR; + } + + /* Chain in namespace list of DATA initializers. */ + newdata->next = gfc_current_ns->data; + gfc_current_ns->data = newdata; + + return m; +} + +/* 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 initialization expression of the form INTEGER I /2/. */ + +match +gfc_match_data (void) +{ + gfc_data *new; + match m; + + for (;;) + { + new = gfc_get_data (); + new->where = gfc_current_locus; + + m = top_var_list (new); + if (m != MATCH_YES) + goto cleanup; + + m = top_val_list (new); + if (m != MATCH_YES) + goto cleanup; + + new->next = gfc_current_ns->data; + gfc_current_ns->data = new; + + if (gfc_match_eos () == MATCH_YES) + break; + + gfc_match_char (','); /* Optional comma */ + } + + if (gfc_pure (NULL)) + { + gfc_error ("DATA statement at %C is not allowed in a PURE procedure"); + return MATCH_ERROR; + } + + return MATCH_YES; + +cleanup: + gfc_free_data (new); + return MATCH_ERROR; +} + + +/************************ Declaration statements *********************/ + /* Match an intent specification. Since this can only happen after an INTENT word, a legal intent-spec must follow. */ @@ -97,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; @@ -131,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) { @@ -161,8 +584,8 @@ find_special (const char *name, gfc_symbol ** result) return 0; } -normal: - return gfc_get_symbol (name, NULL, result); +end: + return i; } @@ -180,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++; @@ -199,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; @@ -216,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 @@ -246,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. */ @@ -305,11 +836,48 @@ add_init_expr_to_sym (const char *name, gfc_expr ** initp, return FAILURE; } - /* Checking a derived type parameter has to be put off until later. */ + /* Check if the assignment can happen. This has to be put off + until later for a derived type variable. */ if (sym->ts.type != BT_DERIVED && init->ts.type != BT_DERIVED && 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; @@ -318,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; } @@ -418,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 (); @@ -439,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 @@ -463,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; @@ -483,18 +1072,73 @@ 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: goto cleanup; } } - + + /* 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) @@ -524,6 +1168,24 @@ variable_decl (void) goto cleanup; } + /* We allow old-style initializations of the form + integer i /2/, j(4) /3*3, 1/ + (if no colon has been seen). These are different from data + statements in that initializers are only allowed to apply to the + variable immediately preceding, i.e. + integer i, j /1, 2/ + is not allowed. Therefore we have to do some work manually, that + could otherwise be left to the matchers for DATA statements. */ + + if (!colon_seen && gfc_match (" /") == MATCH_YES) + { + if (gfc_notify_std (GFC_STD_GNU, "Extension: Old-style " + "initialization at %C") == FAILURE) + return MATCH_ERROR; + + return match_old_style_init (name); + } + /* The double colon must be present in order to have initializers. Otherwise the statement is ambiguous with an assignment statement. */ if (colon_seen) @@ -589,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. */ @@ -596,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); } @@ -618,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; } @@ -888,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; @@ -927,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; @@ -951,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; @@ -1273,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; @@ -1292,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) @@ -1376,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: @@ -1383,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: @@ -1411,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: @@ -1419,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: @@ -1463,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) @@ -1494,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: @@ -1514,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) @@ -1662,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; @@ -1762,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; @@ -1810,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; @@ -1833,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 @@ -1865,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. */ @@ -1878,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; } @@ -1908,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; @@ -1928,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 { @@ -1943,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) @@ -2008,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) @@ -2027,7 +2889,7 @@ gfc_match_subroutine (void) } -/* Return nonzero if we're currenly compiling a contained procedure. */ +/* Return nonzero if we're currently compiling a contained procedure. */ static int contained_procedure (void) @@ -2043,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. */ @@ -2148,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; @@ -2158,8 +3063,8 @@ gfc_match_end (gfc_statement * st) if (!eos_ok) { /* We would have required END [something] */ - gfc_error ("%s statement expected at %C", - gfc_ascii_statement (*st)); + gfc_error ("%s statement expected at %L", + gfc_ascii_statement (*st), &old_loc); goto cleanup; } @@ -2292,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; @@ -2345,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 (); } @@ -2367,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 (); } @@ -2378,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 (); } @@ -2389,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 (); } @@ -2398,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 (); + } } @@ -2411,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 (); } @@ -2422,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 (); } @@ -2433,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 (); } @@ -2475,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; @@ -2618,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; @@ -2678,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; @@ -2690,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 (" ::"); @@ -2702,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; @@ -2741,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) @@ -2771,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) @@ -2818,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; } @@ -2831,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; } @@ -2874,9 +3971,9 @@ loop: components. The ways this can happen is via a function definition, an INTRINSIC statement or a subtype in another 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. */ + 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) @@ -2888,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; + +} +