+ m = gfc_match_formal_arglist (sym, 0, 0);
+ if (m == MATCH_NO)
+ {
+ gfc_error ("Expected formal argument list in function "
+ "definition at %C");
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+ else if (m == MATCH_ERROR)
+ goto cleanup;
+
+ result = NULL;
+
+ /* According to the draft, the bind(c) and result clause can
+ come in either order after the formal_arg_list (i.e., either
+ can be first, both can exist together or by themselves or neither
+ one). Therefore, the match_result can't match the end of the
+ string, and check for the bind(c) or result clause in either order. */
+ found_match = gfc_match_eos ();
+
+ /* Make sure that it isn't already declared as BIND(C). If it is, it
+ must have been marked BIND(C) with a BIND(C) attribute and that is
+ not allowed for procedures. */
+ if (sym->attr.is_bind_c == 1)
+ {
+ sym->attr.is_bind_c = 0;
+ if (sym->old_symbol != NULL)
+ gfc_error_now ("BIND(C) attribute at %L can only be used for "
+ "variables or common blocks",
+ &(sym->old_symbol->declared_at));
+ else
+ gfc_error_now ("BIND(C) attribute at %L can only be used for "
+ "variables or common blocks", &gfc_current_locus);
+ }
+
+ if (found_match != MATCH_YES)
+ {
+ /* If we haven't found the end-of-statement, look for a suffix. */
+ suffix_match = gfc_match_suffix (sym, &result);
+ if (suffix_match == MATCH_YES)
+ /* Need to get the eos now. */
+ found_match = gfc_match_eos ();
+ else
+ found_match = suffix_match;
+ }
+
+ if(found_match != MATCH_YES)
+ m = MATCH_ERROR;
+ else
+ {
+ /* Make changes to the symbol. */
+ m = MATCH_ERROR;
+
+ if (gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
+ goto cleanup;
+
+ if (gfc_missing_attr (&sym->attr, NULL) == FAILURE
+ || copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
+ goto cleanup;
+
+ /* Delay matching the function characteristics until after the
+ specification block by signalling kind=-1. */
+ sym->declared_at = old_loc;
+ if (current_ts.type != BT_UNKNOWN)
+ current_ts.kind = -1;
+ else
+ current_ts.kind = 0;
+
+ if (result == NULL)
+ {
+ if (current_ts.type != BT_UNKNOWN
+ && gfc_add_type (sym, ¤t_ts, &gfc_current_locus) == FAILURE)
+ goto cleanup;
+ sym->result = sym;
+ }
+ else
+ {
+ if (current_ts.type != BT_UNKNOWN
+ && gfc_add_type (result, ¤t_ts, &gfc_current_locus)
+ == FAILURE)
+ goto cleanup;
+ sym->result = result;
+ }
+
+ /* Warn if this procedure has the same name as an intrinsic. */
+ warn_intrinsic_shadow (sym, true);
+
+ return MATCH_YES;
+ }
+
+cleanup:
+ gfc_current_locus = old_loc;
+ 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;
+ enum gfc_symbol_type type;
+
+ s = gfc_get_gsymbol(name);
+ type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
+
+ if (s->defined
+ || (s->type != GSYM_UNKNOWN
+ && s->type != type))
+ gfc_global_used(s, NULL);
+ else
+ {
+ s->type = type;
+ s->where = gfc_current_locus;
+ s->defined = 1;
+ s->ns = gfc_current_ns;
+ return true;
+ }
+ return false;
+}
+
+
+/* Match an ENTRY statement. */
+
+match
+gfc_match_entry (void)
+{
+ gfc_symbol *proc;
+ gfc_symbol *result;
+ gfc_symbol *entry;
+ char name[GFC_MAX_SYMBOL_LEN + 1];
+ gfc_compile_state state;
+ match m;
+ gfc_entry_list *el;
+ locus old_loc;
+ bool module_procedure;
+ char peek_char;
+ match is_bind_c;
+
+ m = gfc_match_name (name);
+ if (m != MATCH_YES)
+ return m;
+
+ state = gfc_current_state ();
+ if (state != COMP_SUBROUTINE && state != COMP_FUNCTION)
+ {
+ 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;
+ }
+
+ module_procedure = gfc_current_ns->parent != NULL
+ && gfc_current_ns->parent->proc_name
+ && gfc_current_ns->parent->proc_name->attr.flavor
+ == FL_MODULE;
+
+ if (gfc_current_ns->parent != NULL
+ && gfc_current_ns->parent->proc_name
+ && !module_procedure)
+ {
+ gfc_error("ENTRY statement at %C cannot appear in a "
+ "contained procedure");
+ return MATCH_ERROR;
+ }
+
+ /* Module function entries need special care in get_proc_name
+ because previous references within the function will have
+ created symbols attached to the current namespace. */
+ if (get_proc_name (name, &entry,
+ gfc_current_ns->parent != NULL
+ && module_procedure))
+ return MATCH_ERROR;
+
+ proc = gfc_current_block ();
+
+ /* Make sure that it isn't already declared as BIND(C). If it is, it
+ must have been marked BIND(C) with a BIND(C) attribute and that is
+ not allowed for procedures. */
+ if (entry->attr.is_bind_c == 1)
+ {
+ entry->attr.is_bind_c = 0;
+ if (entry->old_symbol != NULL)
+ gfc_error_now ("BIND(C) attribute at %L can only be used for "
+ "variables or common blocks",
+ &(entry->old_symbol->declared_at));
+ else
+ gfc_error_now ("BIND(C) attribute at %L can only be used for "
+ "variables or common blocks", &gfc_current_locus);
+ }
+
+ /* Check what next non-whitespace character is so we can tell if there
+ is the required parens if we have a BIND(C). */
+ gfc_gobble_whitespace ();
+ peek_char = gfc_peek_ascii_char ();
+
+ if (state == COMP_SUBROUTINE)
+ {
+ /* An entry in a subroutine. */
+ if (!gfc_current_ns->parent && !add_global_entry (name, 1))
+ return MATCH_ERROR;
+
+ m = gfc_match_formal_arglist (entry, 0, 1);
+ if (m != MATCH_YES)
+ return MATCH_ERROR;
+
+ /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
+ never be an internal procedure. */
+ is_bind_c = gfc_match_bind_c (entry, true);
+ if (is_bind_c == MATCH_ERROR)
+ return MATCH_ERROR;
+ if (is_bind_c == MATCH_YES)
+ {
+ if (peek_char != '(')
+ {
+ gfc_error ("Missing required parentheses before BIND(C) at %C");
+ return MATCH_ERROR;
+ }
+ if (gfc_add_is_bind_c (&(entry->attr), entry->name, &(entry->declared_at), 1)
+ == FAILURE)
+ return MATCH_ERROR;
+ }
+
+ 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.
+ 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 (!gfc_current_ns->parent && !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;
+
+ result = NULL;
+
+ if (gfc_match_eos () == MATCH_YES)
+ {
+ if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
+ || gfc_add_function (&entry->attr, entry->name, NULL) == FAILURE)
+ return MATCH_ERROR;
+
+ entry->result = entry;
+ }
+ else
+ {
+ m = gfc_match_suffix (entry, &result);
+ if (m == MATCH_NO)
+ gfc_syntax_error (ST_ENTRY);
+ if (m != MATCH_YES)
+ return MATCH_ERROR;
+
+ if (result)
+ {
+ 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;
+ }
+ else
+ {
+ if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
+ || gfc_add_function (&entry->attr, entry->name, NULL) == FAILURE)
+ return MATCH_ERROR;
+ entry->result = entry;
+ }
+ }
+ }
+
+ if (gfc_match_eos () != MATCH_YES)
+ {
+ gfc_syntax_error (ST_ENTRY);
+ return MATCH_ERROR;
+ }
+
+ entry->attr.recursive = proc->attr.recursive;
+ entry->attr.elemental = proc->attr.elemental;
+ entry->attr.pure = proc->attr.pure;
+
+ el = gfc_get_entry_list ();
+ el->sym = entry;
+ el->next = gfc_current_ns->entries;
+ gfc_current_ns->entries = el;
+ if (el->next)
+ el->id = el->next->id + 1;
+ else
+ el->id = 1;
+
+ new_st.op = EXEC_ENTRY;
+ new_st.ext.entry = el;
+
+ return MATCH_YES;
+}
+
+
+/* Match a subroutine statement, including optional prefixes. */
+
+match
+gfc_match_subroutine (void)
+{
+ char name[GFC_MAX_SYMBOL_LEN + 1];
+ gfc_symbol *sym;
+ match m;
+ match is_bind_c;
+ char peek_char;
+ bool allow_binding_name;
+
+ if (gfc_current_state () != COMP_NONE
+ && gfc_current_state () != COMP_INTERFACE
+ && gfc_current_state () != COMP_CONTAINS)
+ return MATCH_NO;
+
+ m = gfc_match_prefix (NULL);
+ if (m != MATCH_YES)
+ return m;
+
+ m = gfc_match ("subroutine% %n", name);
+ if (m != MATCH_YES)
+ return m;
+
+ if (get_proc_name (name, &sym, false))
+ return MATCH_ERROR;
+
+ /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
+ the symbol existed before. */
+ sym->declared_at = gfc_current_locus;
+
+ if (add_hidden_procptr_result (sym) == SUCCESS)
+ sym = sym->result;
+
+ gfc_new_block = sym;
+
+ /* Check what next non-whitespace character is so we can tell if there
+ is the required parens if we have a BIND(C). */
+ gfc_gobble_whitespace ();
+ peek_char = gfc_peek_ascii_char ();
+
+ if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
+ return MATCH_ERROR;
+
+ if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES)
+ return MATCH_ERROR;
+
+ /* Make sure that it isn't already declared as BIND(C). If it is, it
+ must have been marked BIND(C) with a BIND(C) attribute and that is
+ not allowed for procedures. */
+ if (sym->attr.is_bind_c == 1)
+ {
+ sym->attr.is_bind_c = 0;
+ if (sym->old_symbol != NULL)
+ gfc_error_now ("BIND(C) attribute at %L can only be used for "
+ "variables or common blocks",
+ &(sym->old_symbol->declared_at));
+ else
+ gfc_error_now ("BIND(C) attribute at %L can only be used for "
+ "variables or common blocks", &gfc_current_locus);
+ }
+
+ /* C binding names are not allowed for internal procedures. */
+ if (gfc_current_state () == COMP_CONTAINS
+ && sym->ns->proc_name->attr.flavor != FL_MODULE)
+ allow_binding_name = false;
+ else
+ allow_binding_name = true;
+
+ /* Here, we are just checking if it has the bind(c) attribute, and if
+ so, then we need to make sure it's all correct. If it doesn't,
+ we still need to continue matching the rest of the subroutine line. */
+ is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
+ if (is_bind_c == MATCH_ERROR)
+ {
+ /* There was an attempt at the bind(c), but it was wrong. An
+ error message should have been printed w/in the gfc_match_bind_c
+ so here we'll just return the MATCH_ERROR. */
+ return MATCH_ERROR;
+ }
+
+ if (is_bind_c == MATCH_YES)
+ {
+ /* The following is allowed in the Fortran 2008 draft. */
+ if (gfc_current_state () == COMP_CONTAINS
+ && sym->ns->proc_name->attr.flavor != FL_MODULE
+ && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: BIND(C) attribute "
+ "at %L may not be specified for an internal "
+ "procedure", &gfc_current_locus)
+ == FAILURE)
+ return MATCH_ERROR;
+
+ if (peek_char != '(')
+ {
+ gfc_error ("Missing required parentheses before BIND(C) at %C");
+ return MATCH_ERROR;
+ }
+ if (gfc_add_is_bind_c (&(sym->attr), sym->name, &(sym->declared_at), 1)
+ == FAILURE)
+ return MATCH_ERROR;
+ }
+
+ if (gfc_match_eos () != MATCH_YES)
+ {
+ gfc_syntax_error (ST_SUBROUTINE);
+ return MATCH_ERROR;
+ }
+
+ if (copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
+ return MATCH_ERROR;
+
+ /* Warn if it has the same name as an intrinsic. */
+ warn_intrinsic_shadow (sym, false);
+
+ return MATCH_YES;
+}
+
+
+/* Match a BIND(C) specifier, with the optional 'name=' specifier if
+ given, and set the binding label in either the given symbol (if not
+ NULL), or in the current_ts. The symbol may be NULL because we may
+ encounter the BIND(C) before the declaration itself. Return
+ MATCH_NO if what we're looking at isn't a BIND(C) specifier,
+ MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
+ or MATCH_YES if the specifier was correct and the binding label and
+ bind(c) fields were set correctly for the given symbol or the
+ current_ts. If allow_binding_name is false, no binding name may be
+ given. */
+
+match
+gfc_match_bind_c (gfc_symbol *sym, bool allow_binding_name)
+{
+ /* binding label, if exists */
+ char binding_label[GFC_MAX_SYMBOL_LEN + 1];
+ match double_quote;
+ match single_quote;
+
+ /* Initialize the flag that specifies whether we encountered a 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)
+ return MATCH_NO;
+
+ /* Now see if there is a binding label, or if we've reached the
+ end of the bind(c) attribute without one. */
+ if (gfc_match_char (',') == MATCH_YES)
+ {
+ if (gfc_match (" name = ") != MATCH_YES)
+ {
+ gfc_error ("Syntax error in NAME= specifier for binding label "
+ "at %C");
+ /* should give an error message here */
+ return MATCH_ERROR;
+ }
+
+ has_name_equals = 1;
+
+ /* Get the opening quote. */
+ double_quote = MATCH_YES;
+ single_quote = MATCH_YES;
+ double_quote = gfc_match_char ('"');
+ if (double_quote != MATCH_YES)
+ single_quote = gfc_match_char ('\'');
+ if (double_quote != MATCH_YES && single_quote != MATCH_YES)
+ {
+ gfc_error ("Syntax error in NAME= specifier for binding label "
+ "at %C");
+ return MATCH_ERROR;
+ }
+
+ /* Grab the binding label, using functions that will not lower
+ case the names automatically. */
+ if (gfc_match_name_C (binding_label) != MATCH_YES)
+ return MATCH_ERROR;
+
+ /* Get the closing quotation. */
+ if (double_quote == MATCH_YES)
+ {
+ if (gfc_match_char ('"') != MATCH_YES)
+ {
+ gfc_error ("Missing closing quote '\"' for binding label at %C");
+ /* User started string with '"' so looked to match it. */
+ return MATCH_ERROR;
+ }
+ }
+ else
+ {
+ if (gfc_match_char ('\'') != MATCH_YES)
+ {
+ gfc_error ("Missing closing quote '\'' for binding label at %C");
+ /* User started string with "'" char. */
+ return MATCH_ERROR;
+ }
+ }
+ }
+
+ /* Get the required right paren. */
+ if (gfc_match_char (')') != MATCH_YES)
+ {
+ gfc_error ("Missing closing paren for binding label at %C");
+ return MATCH_ERROR;
+ }
+
+ if (has_name_equals && !allow_binding_name)
+ {
+ gfc_error ("No binding name is allowed in BIND(C) at %C");
+ return MATCH_ERROR;
+ }
+
+ if (has_name_equals && sym != NULL && sym->attr.dummy)
+ {
+ gfc_error ("For dummy procedure %s, no binding name is "
+ "allowed in BIND(C) at %C", sym->name);
+ return MATCH_ERROR;
+ }
+
+
+ /* 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 (sym != NULL)
+ {
+ strcpy (sym->binding_label, binding_label);
+ }
+ else
+ strcpy (curr_binding_label, binding_label);
+ }
+ else if (allow_binding_name)
+ {
+ /* No binding label, but if symbol isn't null, we
+ can set the label for it here.
+ 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);
+ }
+
+ if (has_name_equals && gfc_current_state () == COMP_INTERFACE
+ && current_interface.type == INTERFACE_ABSTRACT)
+ {
+ gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
+ return MATCH_ERROR;
+ }
+
+ return MATCH_YES;
+}
+
+
+/* Return nonzero if we're currently compiling a contained procedure. */
+
+static int
+contained_procedure (void)
+{
+ gfc_state_data *s = gfc_state_stack;
+
+ if ((s->state == COMP_SUBROUTINE || s->state == COMP_FUNCTION)
+ && s->previous != NULL && s->previous->state == COMP_CONTAINS)
+ return 1;
+
+ 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 (!flag_short_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, END SELECT
+ and END BLOCK statements cannot be replaced by a single END statement. */
+
+match
+gfc_match_end (gfc_statement *st)
+{
+ char name[GFC_MAX_SYMBOL_LEN + 1];
+ gfc_compile_state state;
+ locus old_loc;
+ const char *block_name;
+ const char *target;
+ int eos_ok;
+ match m;
+
+ old_loc = gfc_current_locus;
+ if (gfc_match ("end") != MATCH_YES)
+ return MATCH_NO;
+
+ state = gfc_current_state ();
+ block_name = gfc_current_block () == NULL
+ ? NULL : gfc_current_block ()->name;
+
+ if (state == COMP_BLOCK && !strcmp (block_name, "block@"))
+ block_name = NULL;
+
+ if (state == COMP_CONTAINS || state == COMP_DERIVED_CONTAINS)
+ {
+ state = gfc_state_stack->previous->state;
+ block_name = gfc_state_stack->previous->sym == NULL
+ ? NULL : gfc_state_stack->previous->sym->name;
+ }
+
+ switch (state)
+ {
+ case COMP_NONE:
+ case COMP_PROGRAM:
+ *st = ST_END_PROGRAM;
+ target = " program";
+ eos_ok = 1;
+ break;
+
+ case COMP_SUBROUTINE:
+ *st = ST_END_SUBROUTINE;
+ target = " subroutine";
+ eos_ok = !contained_procedure ();
+ break;
+
+ case COMP_FUNCTION:
+ *st = ST_END_FUNCTION;
+ target = " function";
+ eos_ok = !contained_procedure ();
+ break;
+
+ case COMP_BLOCK_DATA:
+ *st = ST_END_BLOCK_DATA;
+ target = " block data";
+ eos_ok = 1;
+ break;
+
+ case COMP_MODULE:
+ *st = ST_END_MODULE;
+ target = " module";
+ eos_ok = 1;
+ break;
+
+ case COMP_INTERFACE:
+ *st = ST_END_INTERFACE;
+ target = " interface";
+ eos_ok = 0;
+ break;
+
+ case COMP_DERIVED:
+ case COMP_DERIVED_CONTAINS:
+ *st = ST_END_TYPE;
+ target = " type";
+ eos_ok = 0;
+ break;
+
+ case COMP_BLOCK:
+ *st = ST_END_BLOCK;
+ target = " block";
+ eos_ok = 0;
+ break;
+
+ case COMP_IF:
+ *st = ST_ENDIF;
+ target = " if";
+ eos_ok = 0;
+ break;
+
+ case COMP_DO:
+ *st = ST_ENDDO;
+ target = " do";
+ eos_ok = 0;
+ break;
+
+ case COMP_SELECT:
+ case COMP_SELECT_TYPE:
+ *st = ST_END_SELECT;
+ target = " select";
+ eos_ok = 0;
+ break;
+
+ case COMP_FORALL:
+ *st = ST_END_FORALL;
+ target = " forall";
+ eos_ok = 0;
+ break;
+
+ case COMP_WHERE:
+ *st = ST_END_WHERE;
+ target = " where";
+ 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;
+ }
+
+ if (gfc_match_eos () == MATCH_YES)
+ {
+ if (!eos_ok)
+ {
+ /* We would have required END [something]. */
+ gfc_error ("%s statement expected at %L",
+ gfc_ascii_statement (*st), &old_loc);
+ goto cleanup;
+ }
+
+ return MATCH_YES;
+ }
+
+ /* Verify that we've got the sort of end-block that we're expecting. */
+ if (gfc_match (target) != MATCH_YES)
+ {
+ gfc_error ("Expecting %s statement at %C", gfc_ascii_statement (*st));
+ goto cleanup;
+ }
+
+ /* If we're at the end, make sure a block name wasn't required. */
+ if (gfc_match_eos () == MATCH_YES)
+ {
+
+ if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT
+ && *st != ST_END_FORALL && *st != ST_END_WHERE && *st != ST_END_BLOCK)
+ return MATCH_YES;
+
+ if (!block_name)
+ return MATCH_YES;
+
+ gfc_error ("Expected block name of '%s' in %s statement at %C",
+ block_name, gfc_ascii_statement (*st));
+
+ return MATCH_ERROR;
+ }
+
+ /* END INTERFACE has a special handler for its several possible endings. */
+ if (*st == ST_END_INTERFACE)
+ return gfc_match_end_interface ();
+
+ /* We haven't hit the end of statement, so what is left must be an
+ end-name. */
+ m = gfc_match_space ();
+ if (m == MATCH_YES)
+ m = gfc_match_name (name);
+
+ if (m == MATCH_NO)
+ gfc_error ("Expected terminating name at %C");
+ if (m != MATCH_YES)
+ goto cleanup;
+
+ if (block_name == NULL)
+ goto syntax;
+
+ if (strcmp (name, block_name) != 0 && strcmp (block_name, "ppr@") != 0)
+ {
+ gfc_error ("Expected label '%s' for %s statement at %C", block_name,
+ gfc_ascii_statement (*st));
+ goto cleanup;
+ }
+ /* Procedure pointer as function result. */
+ else if (strcmp (block_name, "ppr@") == 0
+ && strcmp (name, gfc_current_block ()->ns->proc_name->name) != 0)
+ {
+ gfc_error ("Expected label '%s' for %s statement at %C",
+ gfc_current_block ()->ns->proc_name->name,
+ gfc_ascii_statement (*st));
+ goto cleanup;
+ }
+
+ if (gfc_match_eos () == MATCH_YES)
+ return MATCH_YES;
+
+syntax:
+ gfc_syntax_error (*st);
+
+cleanup:
+ gfc_current_locus = old_loc;
+ return MATCH_ERROR;
+}
+
+
+
+/***************** Attribute declaration statements ****************/
+
+/* Set the attribute of a single variable. */
+
+static match
+attr_decl1 (void)
+{
+ char name[GFC_MAX_SYMBOL_LEN + 1];
+ gfc_array_spec *as;
+ gfc_symbol *sym;
+ locus var_locus;
+ match m;
+
+ as = NULL;
+
+ m = gfc_match_name (name);
+ if (m != MATCH_YES)
+ goto cleanup;
+
+ if (find_special (name, &sym, false))
+ return MATCH_ERROR;
+
+ var_locus = gfc_current_locus;
+
+ /* Deal with possible array specification for certain attributes. */
+ if (current_attr.dimension
+ || current_attr.allocatable
+ || current_attr.pointer
+ || current_attr.target)
+ {
+ m = gfc_match_array_spec (&as);
+ if (m == MATCH_ERROR)
+ goto cleanup;
+
+ if (current_attr.dimension && m == MATCH_NO)
+ {
+ gfc_error ("Missing array specification at %L in DIMENSION "
+ "statement", &var_locus);
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+
+ if (current_attr.dimension && sym->value)
+ {
+ gfc_error ("Dimensions specified for %s at %L after its "
+ "initialisation", sym->name, &var_locus);
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+
+ if ((current_attr.allocatable || current_attr.pointer)
+ && (m == MATCH_YES) && (as->type != AS_DEFERRED))
+ {
+ gfc_error ("Array specification must be deferred at %L", &var_locus);
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+ }
+
+ /* 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 && sym->ts.u.derived)
+ {
+ gfc_component *comp;
+ comp = gfc_find_component (sym->ts.u.derived, "$data", true, true);
+ if (comp == NULL || gfc_copy_attr (&comp->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
+ {
+ if (current_attr.dimension == 0
+ && gfc_copy_attr (&sym->attr, ¤t_attr, &var_locus) == FAILURE)
+ {
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+ }
+
+ if (gfc_set_array_spec (sym, as, &var_locus) == FAILURE)
+ {
+ 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) == 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, sym->name, NULL) == FAILURE)
+ {
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+
+ add_hidden_procptr_result (sym);
+
+ return MATCH_YES;
+
+cleanup:
+ gfc_free_array_spec (as);
+ return m;
+}
+
+
+/* Generic attribute declaration subroutine. Used for attributes that
+ just have a list of names. */
+
+static match
+attr_decl (void)
+{
+ match m;
+
+ /* Gobble the optional double colon, by simply ignoring the result
+ of gfc_match(). */
+ gfc_match (" ::");
+
+ for (;;)
+ {
+ m = attr_decl1 ();
+ if (m != MATCH_YES)
+ break;
+
+ if (gfc_match_eos () == MATCH_YES)
+ {
+ m = MATCH_YES;
+ break;
+ }
+
+ if (gfc_match_char (',') != MATCH_YES)
+ {
+ gfc_error ("Unexpected character in variable list at %C");
+ m = MATCH_ERROR;
+ break;
+ }
+ }
+
+ return m;
+}
+
+
+/* This routine matches Cray Pointer declarations of the form:
+ pointer ( <pointer>, <pointee> )
+ or
+ pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
+ 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) => ((<type> *) 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);
+ current_attr.external = 1;
+
+ return attr_decl ();
+}
+
+
+match
+gfc_match_intent (void)
+{
+ sym_intent intent;
+
+ /* This is not allowed within a BLOCK construct! */
+ if (gfc_current_state () == COMP_BLOCK)
+ {
+ gfc_error ("INTENT is not allowed inside of BLOCK at %C");
+ return MATCH_ERROR;
+ }
+
+ intent = match_intent_spec ();
+ if (intent == INTENT_UNKNOWN)
+ return MATCH_ERROR;
+
+ gfc_clear_attr (¤t_attr);
+ current_attr.intent = intent;
+
+ return attr_decl ();
+}
+
+
+match
+gfc_match_intrinsic (void)
+{
+
+ gfc_clear_attr (¤t_attr);
+ current_attr.intrinsic = 1;
+
+ return attr_decl ();
+}
+
+
+match
+gfc_match_optional (void)
+{
+ /* This is not allowed within a BLOCK construct! */
+ if (gfc_current_state () == COMP_BLOCK)
+ {
+ gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
+ return MATCH_ERROR;
+ }
+
+ gfc_clear_attr (¤t_attr);
+ current_attr.optional = 1;
+
+ return attr_decl ();
+}
+
+
+match
+gfc_match_pointer (void)
+{
+ gfc_gobble_whitespace ();
+ if (gfc_peek_ascii_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 ();
+ }
+}
+
+
+match
+gfc_match_allocatable (void)
+{
+ gfc_clear_attr (¤t_attr);
+ current_attr.allocatable = 1;
+
+ return attr_decl ();
+}
+
+
+match
+gfc_match_dimension (void)
+{
+ gfc_clear_attr (¤t_attr);
+ current_attr.dimension = 1;
+
+ return attr_decl ();
+}
+
+
+match
+gfc_match_target (void)
+{
+ gfc_clear_attr (¤t_attr);
+ current_attr.target = 1;
+
+ return attr_decl ();
+}
+
+
+/* Match the list of entities being specified in a PUBLIC or PRIVATE
+ statement. */
+
+static match
+access_attr_decl (gfc_statement st)
+{
+ char name[GFC_MAX_SYMBOL_LEN + 1];
+ interface_type type;
+ gfc_user_op *uop;
+ gfc_symbol *sym;
+ gfc_intrinsic_op op;
+ match m;
+
+ if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
+ goto done;
+
+ for (;;)
+ {
+ m = gfc_match_generic_spec (&type, name, &op);
+ if (m == MATCH_NO)
+ goto syntax;
+ if (m == MATCH_ERROR)
+ return MATCH_ERROR;
+
+ switch (type)
+ {
+ case INTERFACE_NAMELESS:
+ case INTERFACE_ABSTRACT:
+ goto syntax;
+
+ case INTERFACE_GENERIC:
+ if (gfc_get_symbol (name, NULL, &sym))
+ goto done;
+
+ if (gfc_add_access (&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_current_ns->operator_access[op] =
+ (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
+ }
+ else
+ {
+ gfc_error ("Access specification of the %s operator at %C has "
+ "already been specified", gfc_op2string (op));
+ goto done;
+ }
+
+ break;
+
+ case INTERFACE_USER_OP:
+ uop = gfc_get_uop (name);
+
+ if (uop->access == ACCESS_UNKNOWN)
+ {
+ uop->access = (st == ST_PUBLIC)
+ ? ACCESS_PUBLIC : ACCESS_PRIVATE;
+ }
+ else
+ {
+ gfc_error ("Access specification of the .%s. operator at %C "
+ "has already been specified", sym->name);
+ goto done;
+ }
+
+ break;
+ }
+
+ if (gfc_match_char (',') == MATCH_NO)
+ break;
+ }
+
+ if (gfc_match_eos () != MATCH_YES)
+ goto syntax;
+ return MATCH_YES;
+
+syntax:
+ gfc_syntax_error (st);
+
+done:
+ return MATCH_ERROR;
+}
+
+
+match
+gfc_match_protected (void)
+{
+ gfc_symbol *sym;
+ match m;
+
+ if (gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
+ {
+ gfc_error ("PROTECTED at %C only allowed in specification "
+ "part of a module");
+ return MATCH_ERROR;
+
+ }
+
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PROTECTED statement at %C")
+ == FAILURE)
+ return MATCH_ERROR;
+
+ if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
+ {
+ return MATCH_ERROR;
+ }
+
+ if (gfc_match_eos () == MATCH_YES)
+ goto syntax;
+
+ for(;;)
+ {
+ m = gfc_match_symbol (&sym, 0);
+ switch (m)
+ {
+ case MATCH_YES:
+ if (gfc_add_protected (&sym->attr, sym->name, &gfc_current_locus)
+ == FAILURE)
+ return MATCH_ERROR;
+ goto next_item;
OSDN Git Service
