/* Declaration statement matcher
- Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012
- Free Software Foundation, Inc.
+ Copyright (C) 2002-2015 Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
#include "config.h"
#include "system.h"
+#include "coretypes.h"
#include "gfortran.h"
#include "match.h"
#include "parse.h"
#include "flags.h"
#include "constructor.h"
+#include "hash-set.h"
+#include "machmode.h"
+#include "vec.h"
+#include "double-int.h"
+#include "input.h"
+#include "alias.h"
+#include "symtab.h"
+#include "wide-int.h"
+#include "inchash.h"
#include "tree.h"
+#include "stringpool.h"
/* Macros to access allocate memory for gfc_data_variable,
gfc_data_value and gfc_data. */
#define gfc_get_data() XCNEW (gfc_data)
-static gfc_try set_binding_label (const char **, const char *, int);
+static bool set_binding_label (const char **, const char *, int);
/* This flag is set if an old-style length selector is matched
}
}
+/* Reject data parsed since the last restore point was marked. */
+
+void
+gfc_reject_data (gfc_namespace *ns)
+{
+ gfc_data *d;
+
+ while (ns->data && ns->data != ns->old_data)
+ {
+ d = ns->data->next;
+ free (ns->data);
+ ns->data = d;
+ }
+}
static match var_element (gfc_data_variable *);
sym = new_var->expr->symtree->n.sym;
/* Symbol should already have an associated type. */
- if (gfc_check_symbol_typed (sym, gfc_current_ns,
- false, gfc_current_locus) == FAILURE)
+ if (!gfc_check_symbol_typed (sym, gfc_current_ns, false, gfc_current_locus))
return MATCH_ERROR;
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 "
+ gfc_error ("Host associated variable %qs 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)
+ && !gfc_notify_std (GFC_STD_GNU, "initialization of "
+ "common block variable %qs in DATA statement at %C",
+ sym->name))
return MATCH_ERROR;
- if (gfc_add_data (&sym->attr, sym->name, &new_var->expr->where) == FAILURE)
+ if (!gfc_add_data (&sym->attr, sym->name, &new_var->expr->where))
return MATCH_ERROR;
return MATCH_YES;
if (m == MATCH_YES && (*result)->expr_type == EXPR_STRUCTURE)
{
- if (gfc_simplify_expr (*result, 0) == FAILURE)
+ if (!gfc_simplify_expr (*result, 0))
m = MATCH_ERROR;
return m;
}
+ else if (m == MATCH_YES)
+ gfc_free_expr (*result);
gfc_current_locus = old_loc;
|| (sym->attr.flavor != FL_PARAMETER
&& (!dt_sym || dt_sym->attr.flavor != FL_DERIVED)))
{
- gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C",
+ gfc_error ("Symbol %qs must be a PARAMETER in DATA statement at %C",
name);
return MATCH_ERROR;
}
if (m == MATCH_YES)
{
- if (gfc_simplify_expr (*result, 0) == FAILURE)
+ if (!gfc_simplify_expr (*result, 0))
m = MATCH_ERROR;
if ((*result)->expr_type == EXPR_CONSTANT)
}
else
{
- if (expr->ts.type == BT_INTEGER)
- mpz_set (tail->repeat, expr->value.integer);
+ mpz_set (tail->repeat, expr->value.integer);
gfc_free_expr (expr);
m = match_data_constant (&tail->expr);
free (newdata);
return MATCH_ERROR;
}
-
- if (gfc_implicit_pure (NULL))
- gfc_current_ns->proc_name->attr.implicit_pure = 0;
+ gfc_unset_implicit_pure (gfc_current_ns->proc_name);
/* Mark the variable as having appeared in a data statement. */
- if (gfc_add_data (&sym->attr, sym->name, &sym->declared_at) == FAILURE)
+ if (!gfc_add_data (&sym->attr, sym->name, &sym->declared_at))
{
free (newdata);
return MATCH_ERROR;
gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
return MATCH_ERROR;
}
-
- if (gfc_implicit_pure (NULL))
- gfc_current_ns->proc_name->attr.implicit_pure = 0;
+ gfc_unset_implicit_pure (gfc_current_ns->proc_name);
return MATCH_YES;
/* Auxiliary function to merge DIMENSION and CODIMENSION array specs. */
-static void
+static bool
merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy)
{
int i;
+ if ((from->type == AS_ASSUMED_RANK && to->corank)
+ || (to->type == AS_ASSUMED_RANK && from->corank))
+ {
+ gfc_error ("The assumed-rank array at %C shall not have a codimension");
+ return false;
+ }
+
if (to->rank == 0 && from->rank > 0)
{
to->rank = from->rank;
}
}
}
+
+ return true;
}
if (gfc_match_char (':') == MATCH_YES)
{
- if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: deferred type "
- "parameter at %C") == FAILURE)
+ if (!gfc_notify_std (GFC_STD_F2003, "deferred type "
+ "parameter at %C"))
return MATCH_ERROR;
*deferred = true;
m = gfc_match_expr (expr);
if (m == MATCH_YES
- && gfc_expr_check_typed (*expr, gfc_current_ns, false) == FAILURE)
+ && !gfc_expr_check_typed (*expr, gfc_current_ns, false))
return MATCH_ERROR;
if (m == MATCH_YES && (*expr)->expr_type == EXPR_FUNCTION)
char_len_param_value in parenthesis. */
static match
-match_char_length (gfc_expr **expr, bool *deferred)
+match_char_length (gfc_expr **expr, bool *deferred, bool obsolescent_check)
{
int length;
match m;
- *deferred = false;
+ *deferred = false;
m = gfc_match_char ('*');
if (m != MATCH_YES)
return m;
if (m == MATCH_YES)
{
- if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
- "Old-style character length at %C") == FAILURE)
+ if (obsolescent_check
+ && !gfc_notify_std (GFC_STD_F95_OBS, "Old-style character length at %C"))
return MATCH_ERROR;
*expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, length);
return m;
return rc;
sym = *result;
- gfc_current_ns->refs++;
if (sym && !sym->gfc_new && gfc_current_state () != COMP_INTERFACE)
{
&& sym->attr.proc != 0
&& (sym->attr.subroutine || sym->attr.function)
&& sym->attr.if_source != IFSRC_UNKNOWN)
- gfc_error_now ("Procedure '%s' at %C is already defined at %L",
- name, &sym->declared_at);
+ gfc_error_now_1 ("Procedure '%s' at %C is already defined at %L",
+ name, &sym->declared_at);
/* Trap a procedure with a name the same as interface in the
encompassing scope. */
if (sym->attr.generic != 0
&& (sym->attr.subroutine || sym->attr.function)
&& !sym->attr.mod_proc)
- gfc_error_now ("Name '%s' at %C is already defined"
- " as a generic interface at %L",
- name, &sym->declared_at);
+ gfc_error_now_1 ("Name '%s' at %C is already defined"
+ " as a generic interface at %L",
+ name, &sym->declared_at);
/* Trap declarations of attributes in encompassing scope. The
signature for this is that ts.kind is set. Legitimate
&& gfc_current_ns->parent != NULL
&& sym->attr.access == 0
&& !module_fcn_entry)
- gfc_error_now ("Procedure '%s' at %C has an explicit interface "
- "and must not have attributes declared at %L",
- name, &sym->declared_at);
+ gfc_error_now_1 ("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)
&& sym->ns->proc_name->attr.flavor == FL_MODULE
&& sym->attr.proc != PROC_MODULE)
|| (module_fcn_entry && sym->attr.proc != PROC_MODULE))
- && gfc_add_procedure (&sym->attr, PROC_MODULE,
- sym->name, NULL) == FAILURE)
+ && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL))
rc = 2;
return rc;
the compiler could have automatically handled the varying sizes
across platforms. */
-gfc_try
+bool
gfc_verify_c_interop_param (gfc_symbol *sym)
{
int is_c_interop = 0;
- gfc_try retval = SUCCESS;
+ bool retval = true;
/* We check implicitly typed variables in symbol.c:gfc_set_default_type().
Don't repeat the checks here. */
if (sym->attr.implicit_type)
- return SUCCESS;
-
+ return true;
+
/* For subroutines or functions that are passed to a BIND(C) procedure,
they're interoperable if they're BIND(C) and their params are all
interoperable. */
{
if (sym->attr.is_bind_c == 0)
{
- gfc_error_now ("Procedure '%s' at %L must have the BIND(C) "
- "attribute to be C interoperable", sym->name,
- &(sym->declared_at));
-
- return FAILURE;
+ gfc_error_now ("Procedure %qs at %L must have the BIND(C) "
+ "attribute to be C interoperable", sym->name,
+ &(sym->declared_at));
+ return false;
}
else
{
if (sym->attr.is_c_interop == 1)
/* We've already checked this procedure; don't check it again. */
- return SUCCESS;
+ return true;
else
return verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
sym->common_block);
}
}
-
+
/* See if we've stored a reference to a procedure that owns sym. */
if (sym->ns != NULL && sym->ns->proc_name != NULL)
{
if (sym->ns->proc_name->attr.is_bind_c == 1)
{
- is_c_interop = (gfc_verify_c_interop (&(sym->ts)) == SUCCESS ? 1 : 0);
+ is_c_interop = (gfc_verify_c_interop(&(sym->ts)) ? 1 : 0);
if (is_c_interop != 1)
{
/* Make personalized messages to give better feedback. */
if (sym->ts.type == BT_DERIVED)
- gfc_error ("Variable '%s' at %L is a dummy argument to the "
- "BIND(C) procedure '%s' but is not C interoperable "
- "because derived type '%s' is not C interoperable",
+ gfc_error ("Variable %qs at %L is a dummy argument to the "
+ "BIND(C) procedure %qs but is not C interoperable "
+ "because derived type %qs is not C interoperable",
sym->name, &(sym->declared_at),
- sym->ns->proc_name->name,
+ sym->ns->proc_name->name,
sym->ts.u.derived->name);
else if (sym->ts.type == BT_CLASS)
- gfc_error ("Variable '%s' at %L is a dummy argument to the "
- "BIND(C) procedure '%s' but is not C interoperable "
+ gfc_error ("Variable %qs at %L is a dummy argument to the "
+ "BIND(C) procedure %qs but is not C interoperable "
"because it is polymorphic",
sym->name, &(sym->declared_at),
sym->ns->proc_name->name);
- else
- gfc_warning ("Variable '%s' at %L is a parameter to the "
- "BIND(C) procedure '%s' but may not be C "
+ else if (warn_c_binding_type)
+ gfc_warning (OPT_Wc_binding_type,
+ "Variable %qs at %L is a dummy argument of the "
+ "BIND(C) procedure %qs but may not be C "
"interoperable",
sym->name, &(sym->declared_at),
sym->ns->proc_name->name);
if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT
|| mpz_cmp_si (cl->length->value.integer, 1) != 0)
{
- gfc_error ("Character argument '%s' at %L "
+ gfc_error ("Character argument %qs at %L "
"must be length 1 because "
- "procedure '%s' is BIND(C)",
+ "procedure %qs is BIND(C)",
sym->name, &sym->declared_at,
sym->ns->proc_name->name);
- retval = FAILURE;
+ retval = false;
}
}
/* We have to make sure that any param to a bind(c) routine does
not have the allocatable, pointer, or optional attributes,
according to J3/04-007, section 5.1. */
- if (sym->attr.allocatable == 1)
+ if (sym->attr.allocatable == 1
+ && !gfc_notify_std (GFC_STD_F2008_TS, "Variable %qs at %L with "
+ "ALLOCATABLE attribute in procedure %qs "
+ "with BIND(C)", sym->name,
+ &(sym->declared_at),
+ sym->ns->proc_name->name))
+ retval = false;
+
+ if (sym->attr.pointer == 1
+ && !gfc_notify_std (GFC_STD_F2008_TS, "Variable %qs at %L with "
+ "POINTER attribute in procedure %qs "
+ "with BIND(C)", sym->name,
+ &(sym->declared_at),
+ sym->ns->proc_name->name))
+ retval = false;
+
+ if ((sym->attr.allocatable || sym->attr.pointer) && !sym->as)
{
- gfc_error ("Variable '%s' at %L cannot have the "
- "ALLOCATABLE attribute because procedure '%s'"
- " is BIND(C)", sym->name, &(sym->declared_at),
+ gfc_error ("Scalar variable %qs at %L with POINTER or "
+ "ALLOCATABLE in procedure %qs with BIND(C) is not yet"
+ " supported", sym->name, &(sym->declared_at),
sym->ns->proc_name->name);
- retval = FAILURE;
- }
-
- if (sym->attr.pointer == 1)
- {
- gfc_error ("Variable '%s' at %L cannot have the "
- "POINTER attribute because procedure '%s'"
- " is BIND(C)", sym->name, &(sym->declared_at),
- sym->ns->proc_name->name);
- retval = FAILURE;
+ retval = false;
}
if (sym->attr.optional == 1 && sym->attr.value)
{
- gfc_error ("Variable '%s' at %L cannot have both the OPTIONAL "
- "and the VALUE attribute because procedure '%s' "
+ gfc_error ("Variable %qs at %L cannot have both the OPTIONAL "
+ "and the VALUE attribute because procedure %qs "
"is BIND(C)", sym->name, &(sym->declared_at),
sym->ns->proc_name->name);
- retval = FAILURE;
+ retval = false;
}
else if (sym->attr.optional == 1
- && gfc_notify_std (GFC_STD_F2008_TS, "TS29113: Variable '%s' "
- "at %L with OPTIONAL attribute in "
- "procedure '%s' which is BIND(C)",
- sym->name, &(sym->declared_at),
- sym->ns->proc_name->name)
- == FAILURE)
- retval = FAILURE;
+ && !gfc_notify_std (GFC_STD_F2008_TS, "Variable %qs "
+ "at %L with OPTIONAL attribute in "
+ "procedure %qs which is BIND(C)",
+ sym->name, &(sym->declared_at),
+ sym->ns->proc_name->name))
+ retval = false;
/* Make sure that if it has the dimension attribute, that it is
- either assumed size or explicit shape. */
- if (sym->as != NULL)
- {
- if (sym->as->type == AS_ASSUMED_SHAPE)
- {
- gfc_error ("Assumed-shape array '%s' at %L cannot be an "
- "argument to the procedure '%s' at %L because "
- "the procedure is BIND(C)", sym->name,
- &(sym->declared_at), sym->ns->proc_name->name,
- &(sym->ns->proc_name->declared_at));
- retval = FAILURE;
- }
-
- if (sym->as->type == AS_DEFERRED)
- {
- gfc_error ("Deferred-shape array '%s' at %L cannot be an "
- "argument to the procedure '%s' at %L because "
- "the procedure is BIND(C)", sym->name,
- &(sym->declared_at), sym->ns->proc_name->name,
- &(sym->ns->proc_name->declared_at));
- retval = FAILURE;
- }
- }
+ either assumed size or explicit shape. Deferred shape is already
+ covered by the pointer/allocatable attribute. */
+ if (sym->as != NULL && sym->as->type == AS_ASSUMED_SHAPE
+ && !gfc_notify_std_1 (GFC_STD_F2008_TS, "Assumed-shape array '%s' "
+ "at %L as dummy argument to the BIND(C) "
+ "procedure '%s' at %L", sym->name,
+ &(sym->declared_at),
+ sym->ns->proc_name->name,
+ &(sym->ns->proc_name->declared_at)))
+ retval = false;
}
}
/* Function called by variable_decl() that adds a name to the symbol table. */
-static gfc_try
+static bool
build_sym (const char *name, gfc_charlen *cl, bool cl_deferred,
gfc_array_spec **as, locus *var_locus)
{
gfc_symbol *sym;
if (gfc_get_symbol (name, NULL, &sym))
- return FAILURE;
+ return false;
/* Start updating the symbol table. Add basic type attribute if present. */
if (current_ts.type != BT_UNKNOWN
&& (sym->attr.implicit_type == 0
|| !gfc_compare_types (&sym->ts, ¤t_ts))
- && gfc_add_type (sym, ¤t_ts, var_locus) == FAILURE)
- return FAILURE;
+ && !gfc_add_type (sym, ¤t_ts, var_locus))
+ return false;
if (sym->ts.type == BT_CHARACTER)
{
}
/* Add dimension attribute if present. */
- if (gfc_set_array_spec (sym, *as, var_locus) == FAILURE)
- return FAILURE;
+ if (!gfc_set_array_spec (sym, *as, var_locus))
+ return false;
*as = NULL;
/* Add attribute to symbol. The copy is so that we can reset the
attr.dimension = 0;
attr.codimension = 0;
- if (gfc_copy_attr (&sym->attr, &attr, var_locus) == FAILURE)
- return FAILURE;
+ if (!gfc_copy_attr (&sym->attr, &attr, var_locus))
+ return false;
/* Finish any work that may need to be done for the binding label,
if it's a bind(c). The bind(c) attr is found before the symbol
{
/* Set the binding label and verify that if a NAME= was specified
then only one identifier was in the entity-decl-list. */
- if (set_binding_label (&sym->binding_label, sym->name,
- num_idents_on_line) == FAILURE)
- return FAILURE;
+ if (!set_binding_label (&sym->binding_label, sym->name,
+ num_idents_on_line))
+ return false;
}
}
if (sym->common_block != NULL && sym->common_block->is_bind_c == 1
&& sym->ts.is_c_interop != 1)
{
- gfc_error_now ("Variable '%s' in common block '%s' at %C "
+ gfc_error_now ("Variable %qs in common block %qs at %C "
"must be declared with a C interoperable "
- "kind since common block '%s' is BIND(C)",
+ "kind since common block %qs is BIND(C)",
sym->name, sym->common_block->name,
sym->common_block->name);
gfc_clear_error ();
sym->attr.implied_index = 0;
if (sym->ts.type == BT_CLASS)
- return gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as, false);
+ return gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as);
- return SUCCESS;
+ return true;
}
if (len > slen)
gfc_wide_memset (&s[slen], ' ', len - slen);
- if (gfc_option.warn_character_truncation && slen > len)
- gfc_warning_now ("CHARACTER expression at %L is being truncated "
+ if (warn_character_truncation && slen > len)
+ gfc_warning_now (OPT_Wcharacter_truncation,
+ "CHARACTER expression at %L is being truncated "
"(%d/%d)", &expr->where, slen, len);
/* Apply the standard by 'hand' otherwise it gets cleared for
/* Function called by variable_decl() that adds an initialization
expression to a symbol. */
-static gfc_try
+static bool
add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus)
{
symbol_attribute attr;
init = *initp;
if (find_special (name, &sym, false))
- return FAILURE;
+ return false;
attr = sym->attr;
&& sym->value != NULL
&& *initp != NULL)
{
- gfc_error ("Initializer not allowed for PARAMETER '%s' at %C",
+ gfc_error ("Initializer not allowed for PARAMETER %qs at %C",
sym->name);
- return FAILURE;
+ return false;
}
if (init == NULL)
if (attr.flavor == FL_PARAMETER)
{
gfc_error ("PARAMETER at %L is missing an initializer", var_locus);
- return FAILURE;
+ return false;
}
}
else
initializer. */
if (sym->attr.data)
{
- gfc_error ("Variable '%s' at %C with an initializer already "
+ gfc_error ("Variable %qs at %C with an initializer already "
"appears in a DATA statement", sym->name);
- return FAILURE;
+ return false;
}
/* Check if the assignment can happen. This has to be put off
until later for derived type variables and procedure pointers. */
if (sym->ts.type != BT_DERIVED && init->ts.type != BT_DERIVED
&& sym->ts.type != BT_CLASS && init->ts.type != BT_CLASS
- && !sym->attr.proc_pointer
- && gfc_check_assign_symbol (sym, init) == FAILURE)
- return FAILURE;
+ && !sym->attr.proc_pointer
+ && !gfc_check_assign_symbol (sym, NULL, init))
+ return false;
if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl
&& init->ts.type == BT_CHARACTER)
{
/* Update symbol character length according initializer. */
- if (gfc_check_assign_symbol (sym, init) == FAILURE)
- return FAILURE;
+ if (!gfc_check_assign_symbol (sym, NULL, init))
+ return false;
if (sym->ts.u.cl->length == NULL)
{
{
gfc_error ("Can't initialize implied-shape array at %L"
" with scalar", &sym->declared_at);
- return FAILURE;
+ return false;
}
gcc_assert (sym->as->rank == init->rank);
int k;
gfc_expr* lower;
gfc_expr* e;
-
+
lower = sym->as->lower[dim];
if (lower->expr_type != EXPR_CONSTANT)
{
gfc_error ("Non-constant lower bound in implied-shape"
" declaration at %L", &lower->where);
- return FAILURE;
+ return false;
}
/* All dimensions must be without upper bound. */
int n;
if (sym->attr.flavor == FL_PARAMETER
&& init->expr_type == EXPR_CONSTANT
- && spec_size (sym->as, &size) == SUCCESS
+ && spec_size (sym->as, &size)
&& mpz_cmp_si (size, 0) > 0)
{
array = gfc_get_array_expr (init->ts.type, init->ts.kind,
? init
: gfc_copy_expr (init),
&init->where);
-
+
array->shape = gfc_get_shape (sym->as->rank);
for (n = 0; n < sym->as->rank; n++)
spec_dimen_size (sym->as, n, &array->shape[n]);
*initp = NULL;
}
- return SUCCESS;
+ return true;
}
/* Function called by variable_decl() that adds a name to a structure
being built. */
-static gfc_try
+static bool
build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
gfc_array_spec **as)
{
gfc_component *c;
- gfc_try t = SUCCESS;
+ bool t = true;
/* F03:C438/C439. If the current symbol is of the same derived type that we're
constructing, it must have the pointer attribute. */
&& current_attr.pointer == 0)
{
gfc_error ("Component at %C must have the POINTER attribute");
- return FAILURE;
+ return false;
}
if (gfc_current_block ()->attr.pointer && (*as)->rank != 0)
{
gfc_error ("Array component of structure at %C must have explicit "
"or deferred shape");
- return FAILURE;
+ return false;
}
}
- if (gfc_add_component (gfc_current_block (), name, &c) == FAILURE)
- return FAILURE;
+ if (!gfc_add_component (gfc_current_block(), name, &c))
+ return false;
c->ts = current_ts;
if (c->ts.type == BT_CHARACTER)
{
gfc_error ("Pointer array component of structure at %C must have a "
"deferred shape");
- t = FAILURE;
+ t = false;
}
}
else if (c->attr.allocatable)
{
gfc_error ("Allocatable component of structure at %C must have a "
"deferred shape");
- t = FAILURE;
+ t = false;
}
}
else
{
gfc_error ("Array component of structure at %C must have an "
"explicit shape");
- t = FAILURE;
+ t = false;
}
}
scalar:
if (c->ts.type == BT_CLASS)
{
- bool delayed = (gfc_state_stack->sym == c->ts.u.derived)
- || (!c->ts.u.derived->components
- && !c->ts.u.derived->attr.zero_comp);
- gfc_try t2 = gfc_build_class_symbol (&c->ts, &c->attr, &c->as, delayed);
+ bool t2 = gfc_build_class_symbol (&c->ts, &c->attr, &c->as);
- if (t != FAILURE)
+ if (t)
t = t2;
}
gfc_match_null (gfc_expr **result)
{
gfc_symbol *sym;
- match m;
+ match m, m2 = MATCH_NO;
- m = gfc_match (" null ( )");
- if (m != MATCH_YES)
- return m;
+ if ((m = gfc_match (" null ( )")) == MATCH_ERROR)
+ return MATCH_ERROR;
+
+ if (m == MATCH_NO)
+ {
+ locus old_loc;
+ char name[GFC_MAX_SYMBOL_LEN + 1];
+
+ if ((m2 = gfc_match (" null (")) != MATCH_YES)
+ return m2;
+
+ old_loc = gfc_current_locus;
+ if ((m2 = gfc_match (" %n ) ", name)) == MATCH_ERROR)
+ return MATCH_ERROR;
+ if (m2 != MATCH_YES
+ && ((m2 = gfc_match (" mold = %n )", name)) == MATCH_ERROR))
+ return MATCH_ERROR;
+ if (m2 == MATCH_NO)
+ {
+ gfc_current_locus = old_loc;
+ return MATCH_NO;
+ }
+ }
/* The NULL symbol now has to be/become an intrinsic function. */
if (gfc_get_symbol ("null", NULL, &sym))
gfc_intrinsic_symbol (sym);
if (sym->attr.proc != PROC_INTRINSIC
- && (gfc_add_procedure (&sym->attr, PROC_INTRINSIC,
- sym->name, NULL) == FAILURE
- || gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE))
+ && !(sym->attr.use_assoc && sym->attr.intrinsic)
+ && (!gfc_add_procedure(&sym->attr, PROC_INTRINSIC, sym->name, NULL)
+ || !gfc_add_function (&sym->attr, sym->name, NULL)))
return MATCH_ERROR;
*result = gfc_get_null_expr (&gfc_current_locus);
+ /* Invalid per F2008, C512. */
+ if (m2 == MATCH_YES)
+ {
+ gfc_error ("NULL() initialization at %C may not have MOLD");
+ return MATCH_ERROR;
+ }
+
return MATCH_YES;
}
"a PURE procedure");
return MATCH_ERROR;
}
+ gfc_unset_implicit_pure (gfc_current_ns->proc_name);
/* Match NULL() initialization. */
m = gfc_match_null (init);
return MATCH_ERROR;
}
- if (!procptr)
- gfc_resolve_expr (*init);
-
- if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: non-NULL pointer "
- "initialization at %C") == FAILURE)
+ if (!procptr && !gfc_resolve_expr (*init))
+ return MATCH_ERROR;
+
+ if (!gfc_notify_std (GFC_STD_F2008, "non-NULL pointer "
+ "initialization at %C"))
return MATCH_ERROR;
return MATCH_YES;
}
-static gfc_try
+static bool
check_function_name (char *name)
{
/* In functions that have a RESULT variable defined, the function name always
&& strcmp (block->result->name, "ppr@") != 0
&& strcmp (block->name, name) == 0)
{
- gfc_error ("Function name '%s' not allowed at %C", name);
- return FAILURE;
+ gfc_error ("Function name %qs not allowed at %C", name);
+ return false;
}
}
- return SUCCESS;
+ return true;
}
bool cl_deferred;
locus var_locus;
match m;
- gfc_try t;
+ bool t;
gfc_symbol *sym;
initializer = NULL;
if (m == MATCH_NO)
as = gfc_copy_array_spec (current_as);
- else if (current_as)
- merge_array_spec (current_as, as, true);
+ else if (current_as
+ && !merge_array_spec (current_as, as, true))
+ {
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
- if (gfc_option.flag_cray_pointer)
+ if (flag_cray_pointer)
cp_as = gfc_copy_array_spec (as);
/* At this point, we know for sure if the symbol is PARAMETER and can thus
if (as->type == AS_IMPLIED_SHAPE && current_attr.flavor != FL_PARAMETER)
{
m = MATCH_ERROR;
- gfc_error ("Non-PARAMETER symbol '%s' at %L can't be implied-shape",
+ gfc_error ("Non-PARAMETER symbol %qs at %L can't be implied-shape",
name, &var_locus);
goto cleanup;
}
as->type = AS_IMPLIED_SHAPE;
if (as->type == AS_IMPLIED_SHAPE
- && gfc_notify_std (GFC_STD_F2008,
- "Fortran 2008: Implied-shape array at %L",
- &var_locus) == FAILURE)
+ && !gfc_notify_std (GFC_STD_F2008, "Implied-shape array at %L",
+ &var_locus))
{
m = MATCH_ERROR;
goto cleanup;
if (current_ts.type == BT_CHARACTER)
{
- switch (match_char_length (&char_len, &cl_deferred))
+ switch (match_char_length (&char_len, &cl_deferred, false))
{
case MATCH_YES:
cl = gfc_new_charlen (gfc_current_ns, NULL);
}
/* If this symbol has already shown up in a Cray Pointer declaration,
+ and this is not a component declaration,
then we want to set the type & bail out. */
- if (gfc_option.flag_cray_pointer)
+ if (flag_cray_pointer && gfc_current_state () != COMP_DERIVED)
{
gfc_find_symbol (name, gfc_current_ns, 1, &sym);
if (sym != NULL && sym->attr.cray_pointee)
sym->ts.is_c_interop = current_ts.is_c_interop;
sym->ts.is_iso_c = current_ts.is_iso_c;
m = MATCH_YES;
-
+
/* Check to see if we have an array specification. */
if (cp_as != NULL)
{
}
else
{
- if (gfc_set_array_spec (sym, cp_as, &var_locus) == FAILURE)
+ if (!gfc_set_array_spec (sym, cp_as, &var_locus))
gfc_internal_error ("Couldn't set pointee array spec.");
/* Fix the array spec. */
create a symbol for those yet. If we fail to create the symbol,
bail out. */
if (gfc_current_state () != COMP_DERIVED
- && build_sym (name, cl, cl_deferred, &as, &var_locus) == FAILURE)
+ && !build_sym (name, cl, cl_deferred, &as, &var_locus))
{
m = MATCH_ERROR;
goto cleanup;
}
- /* An interface body specifies all of the procedure's
- characteristics and these shall be consistent with those
- specified in the procedure definition, except that the interface
- may specify a procedure that is not pure if the procedure is
- defined to be pure(12.3.2). */
- if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
- && gfc_current_ns->proc_name
- && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
- && current_ts.u.derived->ns != gfc_current_ns)
- {
- gfc_symtree *st;
- st = gfc_find_symtree (gfc_current_ns->sym_root, current_ts.u.derived->name);
- if (!(current_ts.u.derived->attr.imported
- && st != NULL
- && gfc_find_dt_in_generic (st->n.sym) == current_ts.u.derived)
- && !gfc_current_ns->has_import_set)
- {
- gfc_error ("The type of '%s' at %C has not been declared within the "
- "interface", name);
- m = MATCH_ERROR;
- goto cleanup;
- }
- }
-
- if (check_function_name (name) == FAILURE)
+ if (!check_function_name (name))
{
m = MATCH_ERROR;
goto cleanup;
if (!colon_seen && gfc_match (" /") == MATCH_YES)
{
- if (gfc_notify_std (GFC_STD_GNU, "Extension: Old-style "
- "initialization at %C") == FAILURE)
+ if (!gfc_notify_std (GFC_STD_GNU, "Old-style "
+ "initialization at %C"))
return MATCH_ERROR;
-
+ else if (gfc_current_state () == COMP_DERIVED)
+ {
+ gfc_error ("Invalid old style initialization for derived type "
+ "component at %C");
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+
return match_old_style_init (name);
}
{
if (current_attr.pointer)
{
- gfc_error ("Pointer initialization at %C requires '=>', "
- "not '='");
+ gfc_error ("Pointer initialization at %C requires %<=>%>, "
+ "not %<=%>");
m = MATCH_ERROR;
goto cleanup;
}
m = MATCH_ERROR;
}
+ if (current_attr.flavor != FL_PARAMETER
+ && gfc_state_stack->state != COMP_DERIVED)
+ gfc_unset_implicit_pure (gfc_current_ns->proc_name);
+
if (m != MATCH_YES)
goto cleanup;
}
t = build_struct (name, cl, &initializer, &as);
}
- m = (t == SUCCESS) ? MATCH_YES : MATCH_ERROR;
+ m = (t) ? MATCH_YES : MATCH_ERROR;
cleanup:
/* Free stuff up and return. */
}
- if (ts->type == BT_INTEGER && ts->kind == 4 && gfc_option.flag_integer4_kind == 8)
+ if (ts->type == BT_INTEGER && ts->kind == 4 && flag_integer4_kind == 8)
ts->kind = 8;
if (ts->type == BT_REAL || ts->type == BT_COMPLEX)
{
if (ts->kind == 4)
{
- if (gfc_option.flag_real4_kind == 8)
+ if (flag_real4_kind == 8)
ts->kind = 8;
- if (gfc_option.flag_real4_kind == 10)
+ if (flag_real4_kind == 10)
ts->kind = 10;
- if (gfc_option.flag_real4_kind == 16)
+ if (flag_real4_kind == 16)
ts->kind = 16;
}
if (ts->kind == 8)
{
- if (gfc_option.flag_real8_kind == 4)
+ if (flag_real8_kind == 4)
ts->kind = 4;
- if (gfc_option.flag_real8_kind == 10)
+ if (flag_real8_kind == 10)
ts->kind = 10;
- if (gfc_option.flag_real8_kind == 16)
+ if (flag_real8_kind == 16)
ts->kind = 16;
}
}
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)
+ if (!gfc_notify_std (GFC_STD_GNU,
+ "Nonstandard type declaration %s*%d at %C",
+ gfc_basic_typename(ts->type), original_kind))
return MATCH_ERROR;
return MATCH_YES;
{
if (gfc_matching_function)
{
- /* The function kind expression might include use associated or
+ /* The function kind expression might include use associated or
imported parameters and try again after the specification
expressions..... */
if (gfc_match_char (')') != MATCH_YES)
ts->is_c_interop = e->ts.is_iso_c;
ts->f90_type = e->ts.f90_type;
}
-
+
gfc_free_expr (e);
e = NULL;
if(m == MATCH_ERROR)
gfc_current_locus = where;
- if (ts->type == BT_INTEGER && ts->kind == 4 && gfc_option.flag_integer4_kind == 8)
+ if (ts->type == BT_INTEGER && ts->kind == 4 && flag_integer4_kind == 8)
ts->kind = 8;
if (ts->type == BT_REAL || ts->type == BT_COMPLEX)
{
if (ts->kind == 4)
{
- if (gfc_option.flag_real4_kind == 8)
+ if (flag_real4_kind == 8)
ts->kind = 8;
- if (gfc_option.flag_real4_kind == 10)
+ if (flag_real4_kind == 10)
ts->kind = 10;
- if (gfc_option.flag_real4_kind == 16)
+ if (flag_real4_kind == 16)
ts->kind = 16;
}
if (ts->kind == 8)
{
- if (gfc_option.flag_real8_kind == 4)
+ if (flag_real8_kind == 4)
ts->kind = 4;
- if (gfc_option.flag_real8_kind == 10)
+ if (flag_real8_kind == 10)
ts->kind = 10;
- if (gfc_option.flag_real8_kind == 16)
+ if (flag_real8_kind == 16)
ts->kind = 16;
}
}
if (n != MATCH_YES && gfc_matching_function)
{
/* The expression might include use-associated or imported
- parameters and try again after the specification
+ parameters and try again after the specification
expressions. */
gfc_free_expr (e);
gfc_undo_symbols ();
if (m == MATCH_ERROR)
gfc_current_locus = where;
-
+
/* Return what we know from the test(s). */
return m;
/* Try the old-style specification first. */
old_char_selector = 0;
- m = match_char_length (&len, &deferred);
+ m = match_char_length (&len, &deferred, true);
if (m != MATCH_NO)
{
if (m == MATCH_YES)
if (gfc_match (" kind =") == MATCH_YES)
{
m = match_char_kind (&kind, &is_iso_c);
-
+
if (m == MATCH_ERROR)
goto done;
if (m == MATCH_NO)
looking for the length (line 1690, roughly). it's the last
testcase for parsing the kind params of a character variable.
However, it's not actually the length. this seems like it
- could be an error.
+ could be an error.
To see if the user used a C interop kind, test the expr
of the so called length, and see if it's C interoperable. */
ts->is_c_interop = len->ts.is_iso_c;
-
+
return MATCH_YES;
}
if (gfc_match (" byte") == MATCH_YES)
{
- if (gfc_notify_std (GFC_STD_GNU, "Extension: BYTE type at %C")
- == FAILURE)
+ if (!gfc_notify_std (GFC_STD_GNU, "BYTE type at %C"))
return MATCH_ERROR;
if (gfc_validate_kind (BT_INTEGER, 1, true) < 0)
gfc_error ("Assumed type at %C is not allowed for components");
return MATCH_ERROR;
}
- if (gfc_notify_std (GFC_STD_F2008_TS, "TS 29113: Assumed type "
- "at %C") == FAILURE)
+ if (!gfc_notify_std (GFC_STD_F2008_TS, "Assumed type "
+ "at %C"))
return MATCH_ERROR;
ts->type = BT_ASSUMED;
return MATCH_YES;
|| (!matched_type && gfc_match (" character") == MATCH_YES))
{
if (matched_type
- && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: TYPE with "
- "intrinsic-type-spec at %C") == FAILURE)
+ && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
+ "intrinsic-type-spec at %C"))
return MATCH_ERROR;
ts->type = BT_CHARACTER;
|| (!matched_type && gfc_match (" double precision") == MATCH_YES))
{
if (matched_type
- && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: TYPE with "
- "intrinsic-type-spec at %C") == FAILURE)
+ && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
+ "intrinsic-type-spec at %C"))
return MATCH_ERROR;
if (matched_type && gfc_match_char (')') != MATCH_YES)
return MATCH_ERROR;
&& gfc_match (" complex") == MATCH_YES)))
|| (!matched_type && gfc_match (" double complex") == MATCH_YES))
{
- if (gfc_notify_std (GFC_STD_GNU, "Extension: DOUBLE COMPLEX at %C")
- == FAILURE)
+ if (!gfc_notify_std (GFC_STD_GNU, "DOUBLE COMPLEX at %C"))
return MATCH_ERROR;
if (matched_type
- && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: TYPE with "
- "intrinsic-type-spec at %C") == FAILURE)
+ && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
+ "intrinsic-type-spec at %C"))
return MATCH_ERROR;
if (matched_type && gfc_match_char (')') != MATCH_YES)
return MATCH_ERROR;
else if (m == MATCH_YES)
{
- gfc_fatal_error ("Unlimited polymorphism at %C not yet supported");
+ gfc_symbol *upe;
+ gfc_symtree *st;
+ ts->type = BT_CLASS;
+ gfc_find_symbol ("STAR", gfc_current_ns, 1, &upe);
+ if (upe == NULL)
+ {
+ upe = gfc_new_symbol ("STAR", gfc_current_ns);
+ st = gfc_new_symtree (&gfc_current_ns->sym_root, "STAR");
+ st->n.sym = upe;
+ gfc_set_sym_referenced (upe);
+ upe->refs++;
+ upe->ts.type = BT_VOID;
+ upe->attr.unlimited_polymorphic = 1;
+ /* This is essential to force the construction of
+ unlimited polymorphic component class containers. */
+ upe->attr.zero_comp = 1;
+ if (!gfc_add_flavor (&upe->attr, FL_DERIVED, NULL,
+ &gfc_current_locus))
return MATCH_ERROR;
}
+ else
+ {
+ st = gfc_find_symtree (gfc_current_ns->sym_root, "STAR");
+ if (st == NULL)
+ st = gfc_new_symtree (&gfc_current_ns->sym_root, "STAR");
+ st->n.sym = upe;
+ upe->refs++;
+ }
+ ts->u.derived = upe;
+ return m;
+ }
m = gfc_match (" class ( %n )", name);
if (m != MATCH_YES)
return m;
ts->type = BT_CLASS;
- if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: CLASS statement at %C")
- == FAILURE)
+ if (!gfc_notify_std (GFC_STD_F2003, "CLASS statement at %C"))
return MATCH_ERROR;
}
/* Defer association of the derived type until the end of the
specification block. However, if the derived type can be
- found, add it to the typespec. */
+ found, add it to the typespec. */
if (gfc_matching_function)
{
ts->u.derived = NULL;
gfc_get_ha_symbol (name, &sym);
if (sym->generic && gfc_find_symbol (dt_name, NULL, 0, &dt_sym))
{
- gfc_error ("Type name '%s' at %C is ambiguous", name);
+ gfc_error ("Type name %qs at %C is ambiguous", name);
return MATCH_ERROR;
}
if (sym->generic && !dt_sym)
|| gfc_current_ns->has_import_set;
gfc_find_symbol (name, NULL, iface, &sym);
if (sym && sym->generic && gfc_find_symbol (dt_name, NULL, 1, &dt_sym))
- {
- gfc_error ("Type name '%s' at %C is ambiguous", name);
+ {
+ gfc_error ("Type name %qs at %C is ambiguous", name);
return MATCH_ERROR;
}
if (sym && sym->generic && !dt_sym)
&& !(sym->attr.flavor == FL_PROCEDURE && sym->attr.generic))
|| sym->attr.subroutine)
{
- gfc_error ("Type name '%s' at %C conflicts with previously declared "
- "entity at %L, which has the same name", name,
- &sym->declared_at);
+ gfc_error_1 ("Type name '%s' at %C conflicts with previously declared "
+ "entity at %L, which has the same name", name,
+ &sym->declared_at);
return MATCH_ERROR;
}
gfc_set_sym_referenced (sym);
if (!sym->attr.generic
- && gfc_add_generic (&sym->attr, sym->name, NULL) == FAILURE)
+ && !gfc_add_generic (&sym->attr, sym->name, NULL))
return MATCH_ERROR;
if (!sym->attr.function
- && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
+ && !gfc_add_function (&sym->attr, sym->name, NULL))
return MATCH_ERROR;
if (!dt_sym)
gfc_set_sym_referenced (dt_sym);
if (dt_sym->attr.flavor != FL_DERIVED
- && gfc_add_flavor (&dt_sym->attr, FL_DERIVED, sym->name, NULL)
- == FAILURE)
+ && !gfc_add_flavor (&dt_sym->attr, FL_DERIVED, sym->name, NULL))
return MATCH_ERROR;
ts->u.derived = dt_sym;
get_kind:
if (matched_type
- && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: TYPE with "
- "intrinsic-type-spec at %C") == FAILURE)
+ && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
+ "intrinsic-type-spec at %C"))
return MATCH_ERROR;
/* For all types except double, derived and character, look for an
match
gfc_match_implicit_none (void)
{
- return (gfc_match_eos () == MATCH_YES) ? MATCH_YES : MATCH_NO;
+ char c;
+ match m;
+ char name[GFC_MAX_SYMBOL_LEN + 1];
+ bool type = false;
+ bool external = false;
+ locus cur_loc = gfc_current_locus;
+
+ if (gfc_current_ns->seen_implicit_none
+ || gfc_current_ns->has_implicit_none_export)
+ {
+ gfc_error ("Duplicate IMPLICIT NONE statement at %C");
+ return MATCH_ERROR;
+ }
+
+ gfc_gobble_whitespace ();
+ c = gfc_peek_ascii_char ();
+ if (c == '(')
+ {
+ (void) gfc_next_ascii_char ();
+ if (!gfc_notify_std (GFC_STD_F2015, "IMPORT NONE with spec list at %C"))
+ return MATCH_ERROR;
+
+ gfc_gobble_whitespace ();
+ if (gfc_peek_ascii_char () == ')')
+ {
+ (void) gfc_next_ascii_char ();
+ type = true;
+ }
+ else
+ for(;;)
+ {
+ m = gfc_match (" %n", name);
+ if (m != MATCH_YES)
+ return MATCH_ERROR;
+
+ if (strcmp (name, "type") == 0)
+ type = true;
+ else if (strcmp (name, "external") == 0)
+ external = true;
+ else
+ return MATCH_ERROR;
+
+ gfc_gobble_whitespace ();
+ c = gfc_next_ascii_char ();
+ if (c == ',')
+ continue;
+ if (c == ')')
+ break;
+ return MATCH_ERROR;
+ }
+ }
+ else
+ type = true;
+
+ if (gfc_match_eos () != MATCH_YES)
+ return MATCH_ERROR;
+
+ gfc_set_implicit_none (type, external, &cur_loc);
+
+ return MATCH_YES;
}
conflicts with whatever earlier IMPLICIT statements may have
set. This is done when we've successfully finished matching
the current one. */
- if (gfc_add_new_implicit_range (c1, c2) != SUCCESS)
+ if (!gfc_add_new_implicit_range (c1, c2))
goto bad;
}
char c;
match m;
+ if (gfc_current_ns->seen_implicit_none)
+ {
+ gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) "
+ "statement");
+ return MATCH_ERROR;
+ }
+
gfc_clear_ts (&ts);
/* We don't allow empty implicit statements. */
{
/* We may have <TYPE> (<RANGE>). */
gfc_gobble_whitespace ();
- c = gfc_next_ascii_char ();
- if ((c == '\n') || (c == ','))
+ c = gfc_peek_ascii_char ();
+ if (c == ',' || c == '\n' || c == ';' || c == '!')
{
/* Check for CHARACTER with no length parameter. */
if (ts.type == BT_CHARACTER && !ts.u.cl)
}
/* Record the Successful match. */
- if (gfc_merge_new_implicit (&ts) != SUCCESS)
+ if (!gfc_merge_new_implicit (&ts))
return MATCH_ERROR;
+ if (c == ',')
+ c = gfc_next_ascii_char ();
+ else if (gfc_match_eos () == MATCH_ERROR)
+ goto error;
continue;
}
gfc_gobble_whitespace ();
c = gfc_next_ascii_char ();
- if ((c != '\n') && (c != ','))
+ if (c != ',' && gfc_match_eos () != MATCH_YES)
goto syntax;
- if (gfc_merge_new_implicit (&ts) != SUCCESS)
+ if (!gfc_merge_new_implicit (&ts))
return MATCH_ERROR;
}
while (c == ',');
return MATCH_ERROR;
}
- if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: IMPORT statement at %C")
- == FAILURE)
+ if (!gfc_notify_std (GFC_STD_F2003, "IMPORT statement at %C"))
return MATCH_ERROR;
if (gfc_match_eos () == MATCH_YES)
if (gfc_current_ns->parent != NULL
&& gfc_find_symbol (name, gfc_current_ns->parent, 1, &sym))
{
- gfc_error ("Type name '%s' at %C is ambiguous", name);
+ gfc_error ("Type name %qs at %C is ambiguous", name);
return MATCH_ERROR;
}
else if (!sym && gfc_current_ns->proc_name->ns->parent != NULL
gfc_current_ns->proc_name->ns->parent,
1, &sym))
{
- gfc_error ("Type name '%s' at %C is ambiguous", name);
+ gfc_error ("Type name %qs at %C is ambiguous", name);
return MATCH_ERROR;
}
if (sym == NULL)
{
- gfc_error ("Cannot IMPORT '%s' from host scoping unit "
+ gfc_error ("Cannot IMPORT %qs from host scoping unit "
"at %C - does not exist.", name);
return MATCH_ERROR;
}
- if (gfc_find_symtree (gfc_current_ns->sym_root,name))
+ if (gfc_find_symtree (gfc_current_ns->sym_root, name))
{
- gfc_warning ("'%s' is already IMPORTed from host scoping unit "
- "at %C.", name);
+ gfc_warning ("%qs is already IMPORTed from host scoping unit "
+ "at %C", name);
goto next_item;
}
- st = gfc_new_symtree (&gfc_current_ns->sym_root, sym->name);
+ st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
st->n.sym = sym;
sym->refs++;
sym->attr.imported = 1;
{
/* The actual derived type is stored in a symtree with the first
letter of the name capitalized; the symtree with the all
- lower-case name contains the associated generic function. */
+ lower-case name contains the associated generic function. */
st = gfc_new_symtree (&gfc_current_ns->sym_root,
gfc_get_string ("%c%s",
- (char) TOUPPER ((unsigned char) sym->name[0]),
- &sym->name[1]));
+ (char) TOUPPER ((unsigned char) name[0]),
+ &name[1]));
st->n.sym = sym;
sym->refs++;
sym->attr.imported = 1;
unsigned int d;
const char *attr;
match m;
- gfc_try t;
+ bool t;
gfc_clear_attr (¤t_attr);
start = gfc_current_locus;
current_as = as;
else if (m == MATCH_YES)
{
- merge_array_spec (as, current_as, false);
+ if (!merge_array_spec (as, current_as, false))
+ m = MATCH_ERROR;
free (as);
}
{
if (d == DECL_ALLOCATABLE)
{
- if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ALLOCATABLE "
- "attribute at %C in a TYPE definition")
- == FAILURE)
+ if (!gfc_notify_std (GFC_STD_F2003, "ALLOCATABLE "
+ "attribute at %C in a TYPE definition"))
{
m = MATCH_ERROR;
goto cleanup;
&& gfc_state_stack->previous
&& gfc_state_stack->previous->state == COMP_MODULE)
{
- if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Attribute %s "
- "at %L in a TYPE definition", attr,
- &seen_at[d])
- == FAILURE)
+ if (!gfc_notify_std (GFC_STD_F2003, "Attribute %s "
+ "at %L in a TYPE definition", attr,
+ &seen_at[d]))
{
m = MATCH_ERROR;
goto cleanup;
break;
case DECL_ASYNCHRONOUS:
- if (gfc_notify_std (GFC_STD_F2003,
- "Fortran 2003: ASYNCHRONOUS attribute at %C")
- == FAILURE)
- t = FAILURE;
+ if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS attribute at %C"))
+ t = false;
else
t = gfc_add_asynchronous (¤t_attr, NULL, &seen_at[d]);
break;
break;
case DECL_CONTIGUOUS:
- if (gfc_notify_std (GFC_STD_F2008,
- "Fortran 2008: CONTIGUOUS attribute at %C")
- == FAILURE)
- t = FAILURE;
+ if (!gfc_notify_std (GFC_STD_F2008, "CONTIGUOUS attribute at %C"))
+ t = false;
else
t = gfc_add_contiguous (¤t_attr, NULL, &seen_at[d]);
break;
{
gfc_error ("PROTECTED at %C only allowed in specification "
"part of a module");
- t = FAILURE;
+ t = false;
break;
}
- if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PROTECTED "
- "attribute at %C")
- == FAILURE)
- t = FAILURE;
+ if (!gfc_notify_std (GFC_STD_F2003, "PROTECTED attribute at %C"))
+ t = false;
else
t = gfc_add_protected (¤t_attr, NULL, &seen_at[d]);
break;
case DECL_IS_BIND_C:
t = gfc_add_is_bind_c(¤t_attr, NULL, &seen_at[d], 0);
break;
-
+
case DECL_VALUE:
- if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VALUE attribute "
- "at %C")
- == FAILURE)
- t = FAILURE;
+ if (!gfc_notify_std (GFC_STD_F2003, "VALUE attribute at %C"))
+ t = false;
else
t = gfc_add_value (¤t_attr, NULL, &seen_at[d]);
break;
case DECL_VOLATILE:
- if (gfc_notify_std (GFC_STD_F2003,
- "Fortran 2003: VOLATILE attribute at %C")
- == FAILURE)
- t = FAILURE;
+ if (!gfc_notify_std (GFC_STD_F2003, "VOLATILE attribute at %C"))
+ t = false;
else
t = gfc_add_volatile (¤t_attr, NULL, &seen_at[d]);
break;
gfc_internal_error ("match_attr_spec(): Bad attribute");
}
- if (t == FAILURE)
+ if (!t)
{
m = MATCH_ERROR;
goto cleanup;
(J3/04-007, section 15.4.1). If a binding label was given and
there is more than one argument (num_idents), it is an error. */
-static gfc_try
-set_binding_label (const char **dest_label, const char *sym_name,
+static bool
+set_binding_label (const char **dest_label, const char *sym_name,
int num_idents)
{
if (num_idents > 1 && has_name_equals)
{
gfc_error ("Multiple identifiers provided with "
"single NAME= specifier at %C");
- return FAILURE;
+ return false;
}
if (curr_binding_label)
if (sym_name != NULL && has_name_equals == 0)
*dest_label = IDENTIFIER_POINTER (get_identifier (sym_name));
}
-
- return SUCCESS;
+
+ return true;
}
/* Verify that the given gfc_typespec is for a C interoperable type. */
-gfc_try
+bool
gfc_verify_c_interop (gfc_typespec *ts)
{
if (ts->type == BT_DERIVED && ts->u.derived != NULL)
return (ts->u.derived->ts.is_c_interop || ts->u.derived->attr.is_bind_c)
- ? SUCCESS : FAILURE;
+ ? true : false;
else if (ts->type == BT_CLASS)
- return FAILURE;
+ return false;
else if (ts->is_c_interop != 1 && ts->type != BT_ASSUMED)
- return FAILURE;
+ return false;
- return SUCCESS;
+ return true;
}
interoperable type. Errors will be reported here, if
encountered. */
-gfc_try
+bool
verify_com_block_vars_c_interop (gfc_common_head *com_block)
{
gfc_symbol *curr_sym = NULL;
- gfc_try retval = SUCCESS;
+ bool retval = true;
curr_sym = com_block->head;
-
+
/* Make sure we have at least one symbol. */
if (curr_sym == NULL)
return retval;
/* The second to last param, 1, says this is in a common block. */
retval = verify_bind_c_sym (curr_sym, &(curr_sym->ts), 1, com_block);
curr_sym = curr_sym->common_next;
- } while (curr_sym != NULL);
+ } while (curr_sym != NULL);
return retval;
}
/* Verify that a given BIND(C) symbol is C interoperable. If it is not,
an appropriate error message is reported. */
-gfc_try
+bool
verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts,
int is_in_common, gfc_common_head *com_block)
{
bool bind_c_function = false;
- gfc_try retval = SUCCESS;
+ bool retval = true;
if (tmp_sym->attr.function && tmp_sym->attr.is_bind_c)
bind_c_function = true;
{
tmp_sym = tmp_sym->result;
/* Make sure it wasn't an implicitly typed result. */
- if (tmp_sym->attr.implicit_type && gfc_option.warn_c_binding_type)
+ if (tmp_sym->attr.implicit_type && warn_c_binding_type)
{
- gfc_warning ("Implicitly declared BIND(C) function '%s' at "
+ gfc_warning (OPT_Wc_binding_type,
+ "Implicitly declared BIND(C) function %qs at "
"%L may not be C interoperable", tmp_sym->name,
&tmp_sym->declared_at);
tmp_sym->ts.f90_type = tmp_sym->ts.type;
enough type info, then verify that it's a C interop kind.
The info could be in the symbol already, or possibly still in
the given ts (current_ts), so look in both. */
- if (tmp_sym->ts.type != BT_UNKNOWN || ts->type != BT_UNKNOWN)
+ if (tmp_sym->ts.type != BT_UNKNOWN || ts->type != BT_UNKNOWN)
{
- if (gfc_verify_c_interop (&(tmp_sym->ts)) != SUCCESS)
+ if (!gfc_verify_c_interop (&(tmp_sym->ts)))
{
/* See if we're dealing with a sym in a common block or not. */
- if (is_in_common == 1 && gfc_option.warn_c_binding_type)
+ if (is_in_common == 1 && warn_c_binding_type)
{
- gfc_warning ("Variable '%s' in common block '%s' at %L "
+ gfc_warning (OPT_Wc_binding_type,
+ "Variable %qs in common block %qs at %L "
"may not be a C interoperable "
- "kind though common block '%s' is BIND(C)",
+ "kind though common block %qs is BIND(C)",
tmp_sym->name, com_block->name,
&(tmp_sym->declared_at), com_block->name);
}
else
{
if (tmp_sym->ts.type == BT_DERIVED || ts->type == BT_DERIVED)
- gfc_error ("Type declaration '%s' at %L is not C "
+ gfc_error ("Type declaration %qs at %L is not C "
"interoperable but it is BIND(C)",
tmp_sym->name, &(tmp_sym->declared_at));
- else if (gfc_option.warn_c_binding_type)
- gfc_warning ("Variable '%s' at %L "
+ else if (warn_c_binding_type)
+ gfc_warning (OPT_Wc_binding_type, "Variable %qs at %L "
"may not be a C interoperable "
- "kind but it is bind(c)",
+ "kind but it is BIND(C)",
tmp_sym->name, &(tmp_sym->declared_at));
}
}
-
+
/* Variables declared w/in a common block can't be bind(c)
since there's no way for C to see these variables, so there's
semantically no reason for the attribute. */
if (is_in_common == 1 && tmp_sym->attr.is_bind_c == 1)
{
- gfc_error ("Variable '%s' in common block '%s' at "
+ gfc_error ("Variable %qs in common block %qs at "
"%L cannot be declared with BIND(C) "
"since it is not a global",
tmp_sym->name, com_block->name,
&(tmp_sym->declared_at));
- retval = FAILURE;
+ retval = false;
}
-
+
/* Scalar variables that are bind(c) can not have the pointer
or allocatable attributes. */
if (tmp_sym->attr.is_bind_c == 1)
{
if (tmp_sym->attr.pointer == 1)
{
- gfc_error ("Variable '%s' at %L cannot have both the "
+ gfc_error ("Variable %qs at %L cannot have both the "
"POINTER and BIND(C) attributes",
tmp_sym->name, &(tmp_sym->declared_at));
- retval = FAILURE;
+ retval = false;
}
if (tmp_sym->attr.allocatable == 1)
{
- gfc_error ("Variable '%s' at %L cannot have both the "
+ gfc_error ("Variable %qs at %L cannot have both the "
"ALLOCATABLE and BIND(C) attributes",
tmp_sym->name, &(tmp_sym->declared_at));
- retval = FAILURE;
+ retval = false;
}
}
scalar value. The previous tests in this function made sure
the type is interoperable. */
if (bind_c_function && tmp_sym->as != NULL)
- gfc_error ("Return type of BIND(C) function '%s' at %L cannot "
+ gfc_error ("Return type of BIND(C) function %qs at %L cannot "
"be an array", tmp_sym->name, &(tmp_sym->declared_at));
/* BIND(C) functions can not return a character string. */
if (tmp_sym->ts.u.cl == NULL || tmp_sym->ts.u.cl->length == NULL
|| tmp_sym->ts.u.cl->length->expr_type != EXPR_CONSTANT
|| mpz_cmp_si (tmp_sym->ts.u.cl->length->value.integer, 1) != 0)
- gfc_error ("Return type of BIND(C) function '%s' at %L cannot "
+ gfc_error ("Return type of BIND(C) function %qs at %L cannot "
"be a character string", tmp_sym->name,
&(tmp_sym->declared_at));
}
&& tmp_sym->binding_label)
/* Use gfc_warning_now because we won't say that the symbol fails
just because of this. */
- gfc_warning_now ("Symbol '%s' at %L is marked PRIVATE but has been "
- "given the binding label '%s'", tmp_sym->name,
+ gfc_warning_now ("Symbol %qs at %L is marked PRIVATE but has been "
+ "given the binding label %qs", tmp_sym->name,
&(tmp_sym->declared_at), tmp_sym->binding_label);
return retval;
the type is C interoperable. Errors are reported by the functions
used to set/test these fields. */
-gfc_try
+bool
set_verify_bind_c_sym (gfc_symbol *tmp_sym, int num_idents)
{
- gfc_try retval = SUCCESS;
-
+ bool retval = true;
+
/* TODO: Do we need to make sure the vars aren't marked private? */
/* Set the is_bind_c bit in symbol_attribute. */
gfc_add_is_bind_c (&(tmp_sym->attr), tmp_sym->name, &gfc_current_locus, 0);
- if (set_binding_label (&tmp_sym->binding_label, tmp_sym->name,
- num_idents) != SUCCESS)
- return FAILURE;
+ if (!set_binding_label (&tmp_sym->binding_label, tmp_sym->name, num_idents))
+ return false;
return retval;
}
/* Set the fields marking the given common block as BIND(C), including
a binding label, and report any errors encountered. */
-gfc_try
+bool
set_verify_bind_c_com_block (gfc_common_head *com_block, int num_idents)
{
- gfc_try retval = SUCCESS;
-
+ bool retval = true;
+
/* destLabel, common name, typespec (which may have binding label). */
- if (set_binding_label (&com_block->binding_label, com_block->name,
- num_idents)
- != SUCCESS)
- return FAILURE;
+ if (!set_binding_label (&com_block->binding_label, com_block->name,
+ num_idents))
+ return false;
/* Set the given common block (com_block) to being bind(c) (1). */
set_com_block_bind_c (com_block, 1);
/* Retrieve the list of one or more identifiers that the given bind(c)
attribute applies to. */
-gfc_try
+bool
get_bind_c_idents (void)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_symbol *tmp_sym = NULL;
match found_id;
gfc_common_head *com_block = NULL;
-
+
if (gfc_match_name (name) == MATCH_YES)
{
found_id = MATCH_YES;
{
gfc_error ("Need either entity or common block name for "
"attribute specification statement at %C");
- return FAILURE;
+ return false;
}
-
+
/* Save the current identifier and look for more. */
do
{
/* Make sure we have a sym or com block, and verify that it can
be bind(c). Set the appropriate field(s) and look for more
identifiers. */
- if (tmp_sym != NULL || com_block != NULL)
+ if (tmp_sym != NULL || com_block != NULL)
{
if (tmp_sym != NULL)
{
- if (set_verify_bind_c_sym (tmp_sym, num_idents)
- != SUCCESS)
- return FAILURE;
+ if (!set_verify_bind_c_sym (tmp_sym, num_idents))
+ return false;
}
else
{
- if (set_verify_bind_c_com_block(com_block, num_idents)
- != SUCCESS)
- return FAILURE;
+ if (!set_verify_bind_c_com_block (com_block, num_idents))
+ return false;
}
-
+
/* Look to see if we have another identifier. */
tmp_sym = NULL;
if (gfc_match_eos () == MATCH_YES)
{
gfc_error ("Missing entity or common block name for "
"attribute specification statement at %C");
- return FAILURE;
+ return false;
}
}
else
} while (found_id == MATCH_YES);
/* if we get here we were successful */
- return SUCCESS;
+ return true;
}
/* Try and match a BIND(C) attribute specification statement. */
-
+
match
gfc_match_bind_c_stmt (void)
{
gfc_typespec *ts;
ts = ¤t_ts;
-
+
/* This may not be necessary. */
gfc_clear_ts (ts);
/* Clear the temporary binding label holder. */
if (found_match == MATCH_YES)
{
+ if (!gfc_notify_std (GFC_STD_F2003, "BIND(C) statement at %C"))
+ return MATCH_ERROR;
+
/* Look for the :: now, but it is not required. */
gfc_match (" :: ");
found can have all appropriate parts updated (assuming that the same
spec stmt can have multiple attrs, such as both bind(c) and
allocatable...). */
- if (get_bind_c_idents () != SUCCESS)
+ if (!get_bind_c_idents ())
/* Error message should have printed already. */
return MATCH_ERROR;
}
int elem;
num_idents_on_line = 0;
-
+
m = gfc_match_decl_type_spec (¤t_ts, 0);
if (m != MATCH_YES)
return m;
goto cleanup;
}
+ if (current_ts.type == BT_CLASS
+ && current_ts.u.derived->attr.unlimited_polymorphic)
+ goto ok;
+
if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
&& current_ts.u.derived->components == NULL
&& !current_ts.u.derived->attr.zero_comp)
goto ok;
gfc_find_symbol (current_ts.u.derived->name,
- current_ts.u.derived->ns->parent, 1, &sym);
+ current_ts.u.derived->ns, 1, &sym);
/* Any symbol that we find had better be a type definition
which has its components defined. */
|| current_ts.u.derived->attr.zero_comp))
goto ok;
- /* 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;
+ gfc_error ("Derived type at %C has not been previously defined "
+ "and so cannot appear in a derived type definition");
+ m = MATCH_ERROR;
+ goto cleanup;
}
ok:
break;
}
- if (gfc_error_flag_test () == 0)
+ if (!gfc_error_flag_test ())
gfc_error ("Syntax error in data declaration at %C");
m = MATCH_ERROR;
if (gfc_match ("elemental% ") == MATCH_YES)
{
- if (gfc_add_elemental (¤t_attr, NULL) == FAILURE)
+ if (!gfc_add_elemental (¤t_attr, NULL))
goto error;
found_prefix = true;
if (gfc_match ("pure% ") == MATCH_YES)
{
- if (gfc_add_pure (¤t_attr, NULL) == FAILURE)
+ if (!gfc_add_pure (¤t_attr, NULL))
goto error;
found_prefix = true;
if (gfc_match ("recursive% ") == MATCH_YES)
{
- if (gfc_add_recursive (¤t_attr, NULL) == FAILURE)
+ if (!gfc_add_recursive (¤t_attr, NULL))
goto error;
found_prefix = true;
automatically PURE. */
if (gfc_match ("impure% ") == MATCH_YES)
{
- if (gfc_notify_std (GFC_STD_F2008,
- "Fortran 2008: IMPURE procedure at %C")
- == FAILURE)
+ if (!gfc_notify_std (GFC_STD_F2008, "IMPURE procedure at %C"))
goto error;
seen_impure = true;
/* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
if (!seen_impure && current_attr.elemental && !current_attr.pure)
{
- if (gfc_add_pure (¤t_attr, NULL) == FAILURE)
+ if (!gfc_add_pure (¤t_attr, NULL))
goto error;
}
/* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
-static gfc_try
+static bool
copy_prefix (symbol_attribute *dest, locus *where)
{
- if (current_attr.pure && gfc_add_pure (dest, where) == FAILURE)
- return FAILURE;
+ if (current_attr.pure && !gfc_add_pure (dest, where))
+ return false;
- if (current_attr.elemental && gfc_add_elemental (dest, where) == FAILURE)
- return FAILURE;
+ if (current_attr.elemental && !gfc_add_elemental (dest, where))
+ return false;
- if (current_attr.recursive && gfc_add_recursive (dest, where) == FAILURE)
- return FAILURE;
+ if (current_attr.recursive && !gfc_add_recursive (dest, where))
+ return false;
- return SUCCESS;
+ return true;
}
for (;;)
{
if (gfc_match_char ('*') == MATCH_YES)
- sym = NULL;
+ {
+ sym = NULL;
+ if (!gfc_notify_std (GFC_STD_F95_OBS, "Alternate-return argument "
+ "at %C"))
+ {
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+ }
else
{
m = gfc_match_name (name);
dummy procedure. We don't apply these attributes to formal
arguments of statement functions. */
if (sym != NULL && !st_flag
- && (gfc_add_dummy (&sym->attr, sym->name, NULL) == FAILURE
- || gfc_missing_attr (&sym->attr, NULL) == FAILURE))
+ && (!gfc_add_dummy(&sym->attr, sym->name, NULL)
+ || !gfc_missing_attr (&sym->attr, NULL)))
{
m = MATCH_ERROR;
goto cleanup;
if (gfc_new_block != NULL && sym != NULL
&& strcmp (sym->name, gfc_new_block->name) == 0)
{
- gfc_error ("Name '%s' at %C is the name of the procedure",
+ gfc_error ("Name %qs at %C is the name of the procedure",
sym->name);
m = MATCH_ERROR;
goto cleanup;
for (q = p->next; q; q = q->next)
if (p->sym == q->sym)
{
- gfc_error ("Duplicate symbol '%s' in formal argument list "
+ gfc_error ("Duplicate symbol %qs in formal argument list "
"at %C", p->sym->name);
m = MATCH_ERROR;
}
}
- if (gfc_add_explicit_interface (progname, IFSRC_DECL, head, NULL)
- == FAILURE)
+ if (!gfc_add_explicit_interface (progname, IFSRC_DECL, head, NULL))
{
m = MATCH_ERROR;
goto cleanup;
/* Get the right paren, and that's it because there could be the
bind(c) attribute after the result clause. */
- if (gfc_match_char(')') != MATCH_YES)
+ if (gfc_match_char (')') != MATCH_YES)
{
/* TODO: should report the missing right paren here. */
return MATCH_ERROR;
if (gfc_get_symbol (name, NULL, &r))
return MATCH_ERROR;
- if (gfc_add_result (&r->attr, r->name, NULL) == FAILURE)
+ if (!gfc_add_result (&r->attr, r->name, NULL))
return MATCH_ERROR;
*result = r;
/* Initialize to having found nothing. */
found_match = MATCH_NO;
- is_bind_c = MATCH_NO;
+ is_bind_c = MATCH_NO;
is_result = MATCH_NO;
/* Get the next char to narrow between result and bind(c). */
}
else
/* This should only be MATCH_ERROR. */
- found_match = is_result;
+ found_match = is_result;
break;
case 'b':
/* Look for bind(c) first. */
/* Fortran 2008 draft allows BIND(C) for internal procedures. */
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)
+ && !gfc_notify_std (GFC_STD_F2008, "BIND(C) attribute "
+ "at %L may not be specified for an internal "
+ "procedure", &gfc_current_locus))
return MATCH_ERROR;
- if (gfc_add_is_bind_c (&(sym->attr), sym->name, &gfc_current_locus, 1)
- == FAILURE)
+ if (!gfc_add_is_bind_c (&(sym->attr), sym->name, &gfc_current_locus, 1))
return MATCH_ERROR;
}
-
+
return found_match;
}
/* Procedure pointer return value without RESULT statement:
Add "hidden" result variable named "ppr@". */
-static gfc_try
+static bool
add_hidden_procptr_result (gfc_symbol *sym)
{
bool case1,case2;
if (gfc_notification_std (GFC_STD_F2003) == ERROR)
- return FAILURE;
+ return false;
/* First usage case: PROCEDURE and EXTERNAL statements. */
case1 = gfc_current_state () == COMP_FUNCTION && gfc_current_block ()
{
sym->result->attr.proc_pointer = 1;
sym->attr.pointer = 0;
- return SUCCESS;
+ return true;
}
else
- return FAILURE;
+ return false;
}
gfc_current_ns = old_ns;
*proc_if = st->n.sym;
- /* Various interface checks. */
if (*proc_if)
{
(*proc_if)->refs++;
/* Resolve interface if possible. That way, attr.procedure is only set
if it is declared by a later procedure-declaration-stmt, which is
- invalid per C1212. */
+ invalid per F08:C1216 (cf. resolve_procedure_interface). */
while ((*proc_if)->ts.interface)
*proc_if = (*proc_if)->ts.interface;
- if ((*proc_if)->generic)
- {
- gfc_error ("Interface '%s' at %C may not be generic",
- (*proc_if)->name);
- return MATCH_ERROR;
- }
- if ((*proc_if)->attr.proc == PROC_ST_FUNCTION)
- {
- gfc_error ("Interface '%s' at %C may not be a statement function",
- (*proc_if)->name);
- return MATCH_ERROR;
- }
- /* Handle intrinsic procedures. */
- if (!((*proc_if)->attr.external || (*proc_if)->attr.use_assoc
- || (*proc_if)->attr.if_source == IFSRC_IFBODY)
- && (gfc_is_intrinsic ((*proc_if), 0, gfc_current_locus)
- || gfc_is_intrinsic ((*proc_if), 1, gfc_current_locus)))
- (*proc_if)->attr.intrinsic = 1;
- if ((*proc_if)->attr.intrinsic
- && !gfc_intrinsic_actual_ok ((*proc_if)->name, 0))
- {
- gfc_error ("Intrinsic procedure '%s' not allowed "
- "in PROCEDURE statement at %C", (*proc_if)->name);
- return MATCH_ERROR;
- }
+ if ((*proc_if)->attr.flavor == FL_UNKNOWN
+ && (*proc_if)->ts.type == BT_UNKNOWN
+ && !gfc_add_flavor (&(*proc_if)->attr, FL_PROCEDURE,
+ (*proc_if)->name, NULL))
+ return MATCH_ERROR;
}
got_ts:
int num;
gfc_expr *initializer = NULL;
- /* Parse interface (with brackets). */
+ /* Parse interface (with brackets). */
m = match_procedure_interface (&proc_if);
if (m != MATCH_YES)
return m;
return m;
/* Add current_attr to the symbol attributes. */
- if (gfc_copy_attr (&sym->attr, ¤t_attr, NULL) == FAILURE)
+ if (!gfc_copy_attr (&sym->attr, ¤t_attr, NULL))
return MATCH_ERROR;
if (sym->attr.is_bind_c)
return MATCH_ERROR;
}
/* Set binding label for BIND(C). */
- if (set_binding_label (&sym->binding_label, sym->name, num)
- != SUCCESS)
+ if (!set_binding_label (&sym->binding_label, sym->name, num))
return MATCH_ERROR;
}
- if (gfc_add_external (&sym->attr, NULL) == FAILURE)
+ if (!gfc_add_external (&sym->attr, NULL))
return MATCH_ERROR;
- if (add_hidden_procptr_result (sym) == SUCCESS)
+ if (add_hidden_procptr_result (sym))
sym = sym->result;
- if (gfc_add_proc (&sym->attr, sym->name, NULL) == FAILURE)
+ if (!gfc_add_proc (&sym->attr, sym->name, NULL))
return MATCH_ERROR;
/* Set interface. */
{
if (sym->ts.type != BT_UNKNOWN)
{
- gfc_error ("Procedure '%s' at %L already has basic type of %s",
+ gfc_error ("Procedure %qs at %L already has basic type of %s",
sym->name, &gfc_current_locus,
gfc_basic_typename (sym->ts.type));
return MATCH_ERROR;
}
else if (current_ts.type != BT_UNKNOWN)
{
- if (gfc_add_type (sym, ¤t_ts, &gfc_current_locus) == FAILURE)
+ if (!gfc_add_type (sym, ¤t_ts, &gfc_current_locus))
return MATCH_ERROR;
sym->ts.interface = gfc_new_symbol ("", gfc_current_ns);
sym->ts.interface->ts = current_ts;
if (m != MATCH_YES)
goto cleanup;
- if (add_init_expr_to_sym (sym->name, &initializer, &gfc_current_locus)
- != SUCCESS)
+ if (!add_init_expr_to_sym (sym->name, &initializer, &gfc_current_locus))
goto cleanup;
}
- gfc_set_sym_referenced (sym);
-
if (gfc_match_eos () == MATCH_YES)
return MATCH_YES;
if (gfc_match_char (',') != MATCH_YES)
/* Match the colons (required). */
if (gfc_match (" ::") != MATCH_YES)
{
- gfc_error ("Expected '::' after binding-attributes at %C");
+ gfc_error ("Expected %<::%> after binding-attributes at %C");
return MATCH_ERROR;
}
return MATCH_ERROR;
}
- if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure pointer "
- "component at %C") == FAILURE)
+ if (!gfc_notify_std (GFC_STD_F2003, "Procedure pointer component at %C"))
return MATCH_ERROR;
/* Match PPC names. */
else if (m == MATCH_ERROR)
return m;
- if (gfc_add_component (gfc_current_block (), name, &c) == FAILURE)
+ if (!gfc_add_component (gfc_current_block(), name, &c))
return MATCH_ERROR;
/* Add current_attr to the symbol attributes. */
- if (gfc_copy_attr (&c->attr, ¤t_attr, NULL) == FAILURE)
+ if (!gfc_copy_attr (&c->attr, ¤t_attr, NULL))
return MATCH_ERROR;
- if (gfc_add_external (&c->attr, NULL) == FAILURE)
+ if (!gfc_add_external (&c->attr, NULL))
return MATCH_ERROR;
- if (gfc_add_proc (&c->attr, name, NULL) == FAILURE)
+ if (!gfc_add_proc (&c->attr, name, NULL))
return MATCH_ERROR;
- c->tb = tb;
+ if (num == 1)
+ c->tb = tb;
+ else
+ {
+ c->tb = XCNEW (gfc_typebound_proc);
+ c->tb->where = gfc_current_locus;
+ *c->tb = *tb;
+ }
/* Set interface. */
if (proc_if != NULL)
{
c->ts = ts;
c->ts.interface = gfc_new_symbol ("", gfc_current_ns);
+ c->ts.interface->result = c->ts.interface;
c->ts.interface->ts = ts;
c->ts.interface->attr.flavor = FL_PROCEDURE;
c->ts.interface->attr.function = 1;
match m;
gfc_symbol *sym;
char name[GFC_MAX_SYMBOL_LEN + 1];
+ locus old_locus;
if (current_interface.type == INTERFACE_NAMELESS
|| current_interface.type == INTERFACE_ABSTRACT)
return MATCH_ERROR;
}
+ /* Check if the F2008 optional double colon appears. */
+ gfc_gobble_whitespace ();
+ old_locus = gfc_current_locus;
+ if (gfc_match ("::") == MATCH_YES)
+ {
+ if (!gfc_notify_std (GFC_STD_F2008, "double colon in "
+ "MODULE PROCEDURE statement at %L", &old_locus))
+ return MATCH_ERROR;
+ }
+ else
+ gfc_current_locus = old_locus;
+
for(;;)
{
m = gfc_match_name (name);
if (gfc_get_symbol (name, gfc_current_ns->parent, &sym))
return MATCH_ERROR;
- if (gfc_add_interface (sym) == FAILURE)
+ if (!gfc_add_interface (sym))
return MATCH_ERROR;
if (gfc_match_eos () == MATCH_YES)
if (m != MATCH_YES)
return m;
- if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PROCEDURE statement at %C")
- == FAILURE)
+ if (!gfc_notify_std (GFC_STD_F2003, "PROCEDURE statement at %C"))
return MATCH_ERROR;
return m;
parser-state-stack to find out whether we're in a module. */
static void
-warn_intrinsic_shadow (const gfc_symbol* sym, bool func)
+do_warn_intrinsic_shadow (const gfc_symbol* sym, bool func)
{
bool in_module;
locus old_loc;
match m;
match suffix_match;
- match found_match; /* Status returned by match func. */
+ match found_match; /* Status returned by match func. */
if (gfc_current_state () != COMP_NONE
&& gfc_current_state () != COMP_INTERFACE
if (get_proc_name (name, &sym, false))
return MATCH_ERROR;
- if (add_hidden_procptr_result (sym) == SUCCESS)
+ if (add_hidden_procptr_result (sym))
sym = sym->result;
gfc_new_block = sym;
{
/* Make changes to the symbol. */
m = MATCH_ERROR;
-
- if (gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
+
+ if (!gfc_add_function (&sym->attr, sym->name, NULL))
goto cleanup;
-
- if (gfc_missing_attr (&sym->attr, NULL) == FAILURE
- || copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
+
+ if (!gfc_missing_attr (&sym->attr, NULL)
+ || !copy_prefix (&sym->attr, &sym->declared_at))
goto cleanup;
/* Delay matching the function characteristics until after the
if (result == NULL)
{
if (current_ts.type != BT_UNKNOWN
- && gfc_add_type (sym, ¤t_ts, &gfc_current_locus) == FAILURE)
+ && !gfc_add_type (sym, ¤t_ts, &gfc_current_locus))
goto cleanup;
sym->result = sym;
}
else
{
if (current_ts.type != BT_UNKNOWN
- && gfc_add_type (result, ¤t_ts, &gfc_current_locus)
- == FAILURE)
+ && !gfc_add_type (result, ¤t_ts, &gfc_current_locus))
goto cleanup;
sym->result = result;
}
/* Warn if this procedure has the same name as an intrinsic. */
- warn_intrinsic_shadow (sym, true);
+ do_warn_intrinsic_shadow (sym, true);
return MATCH_YES;
}
to return false upon finding an existing global entry. */
static bool
-add_global_entry (const char *name, int sub)
+add_global_entry (const char *name, const char *binding_label, bool sub,
+ locus *where)
{
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
+ /* Only in Fortran 2003: For procedures with a binding label also the Fortran
+ name is a global identifier. */
+ if (!binding_label || gfc_notification_std (GFC_STD_F2008))
{
- s->type = type;
- s->where = gfc_current_locus;
- s->defined = 1;
- s->ns = gfc_current_ns;
- return true;
+ s = gfc_get_gsymbol (name);
+
+ if (s->defined || (s->type != GSYM_UNKNOWN && s->type != type))
+ {
+ gfc_global_used (s, where);
+ return false;
+ }
+ else
+ {
+ s->type = type;
+ s->sym_name = name;
+ s->where = *where;
+ s->defined = 1;
+ s->ns = gfc_current_ns;
+ }
+ }
+
+ /* Don't add the symbol multiple times. */
+ if (binding_label
+ && (!gfc_notification_std (GFC_STD_F2008)
+ || strcmp (name, binding_label) != 0))
+ {
+ s = gfc_get_gsymbol (binding_label);
+
+ if (s->defined || (s->type != GSYM_UNKNOWN && s->type != type))
+ {
+ gfc_global_used (s, where);
+ return false;
+ }
+ else
+ {
+ s->type = type;
+ s->sym_name = name;
+ s->binding_label = binding_label;
+ s->where = *where;
+ s->defined = 1;
+ s->ns = gfc_current_ns;
+ }
}
- return false;
+
+ return true;
}
if (m != MATCH_YES)
return m;
- if (gfc_notify_std (GFC_STD_F2008_OBS, "Fortran 2008 obsolescent feature: "
- "ENTRY statement at %C") == FAILURE)
+ if (!gfc_notify_std (GFC_STD_F2008_OBS, "ENTRY statement at %C"))
return MATCH_ERROR;
state = gfc_current_state ();
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). */
+ old_loc = gfc_current_locus;
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;
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)
+ if (!gfc_add_is_bind_c (&(entry->attr), entry->name,
+ &(entry->declared_at), 1))
return MATCH_ERROR;
}
- if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
- || gfc_add_subroutine (&entry->attr, entry->name, NULL) == FAILURE)
+ if (!gfc_current_ns->parent
+ && !add_global_entry (name, entry->binding_label, true,
+ &old_loc))
+ return MATCH_ERROR;
+
+ /* An entry in a subroutine. */
+ if (!gfc_add_entry (&entry->attr, entry->name, NULL)
+ || !gfc_add_subroutine (&entry->attr, entry->name, NULL))
return MATCH_ERROR;
}
else
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;
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)
+ if (!gfc_add_entry (&entry->attr, entry->name, NULL)
+ || !gfc_add_function (&entry->attr, entry->name, NULL))
return MATCH_ERROR;
entry->result = entry;
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)
+ if (!gfc_add_result (&result->attr, result->name, NULL)
+ || !gfc_add_entry (&entry->attr, result->name, NULL)
+ || !gfc_add_function (&entry->attr, result->name, NULL))
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)
+ if (!gfc_add_entry (&entry->attr, entry->name, NULL)
+ || !gfc_add_function (&entry->attr, entry->name, NULL))
return MATCH_ERROR;
entry->result = entry;
}
}
+
+ if (!gfc_current_ns->parent
+ && !add_global_entry (name, entry->binding_label, false,
+ &old_loc))
+ return MATCH_ERROR;
}
if (gfc_match_eos () != MATCH_YES)
return MATCH_ERROR;
/* Set declared_at as it might point to, e.g., a PUBLIC statement, if
- the symbol existed before. */
+ the symbol existed before. */
sym->declared_at = gfc_current_locus;
- if (add_hidden_procptr_result (sym) == SUCCESS)
+ if (add_hidden_procptr_result (sym))
sym = sym->result;
gfc_new_block = sym;
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)
+
+ if (!gfc_add_subroutine (&sym->attr, sym->name, NULL))
return MATCH_ERROR;
if (gfc_match_formal_arglist (sym, 0, 1) != 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)
+ && !gfc_notify_std (GFC_STD_F2008, "BIND(C) attribute "
+ "at %L may not be specified for an internal "
+ "procedure", &gfc_current_locus))
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)
+ if (!gfc_add_is_bind_c (&(sym->attr), sym->name,
+ &(sym->declared_at), 1))
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)
+ if (!copy_prefix (&sym->attr, &sym->declared_at))
return MATCH_ERROR;
/* Warn if it has the same name as an intrinsic. */
- warn_intrinsic_shadow (sym, false);
+ do_warn_intrinsic_shadow (sym, false);
+
+ return MATCH_YES;
+}
+
+
+/* Check that the NAME identifier in a BIND attribute or statement
+ is conform to C identifier rules. */
+
+match
+check_bind_name_identifier (char **name)
+{
+ char *n = *name, *p;
+
+ /* Remove leading spaces. */
+ while (*n == ' ')
+ n++;
+
+ /* On an empty string, free memory and set name to NULL. */
+ if (*n == '\0')
+ {
+ free (*name);
+ *name = NULL;
+ return MATCH_YES;
+ }
+
+ /* Remove trailing spaces. */
+ p = n + strlen(n) - 1;
+ while (*p == ' ')
+ *(p--) = '\0';
+
+ /* Insert the identifier into the symbol table. */
+ p = xstrdup (n);
+ free (*name);
+ *name = p;
+
+ /* Now check that identifier is valid under C rules. */
+ if (ISDIGIT (*p))
+ {
+ gfc_error ("Invalid C identifier in NAME= specifier at %C");
+ return MATCH_ERROR;
+ }
+
+ for (; *p; p++)
+ if (!(ISALNUM (*p) || *p == '_' || *p == '$'))
+ {
+ gfc_error ("Invalid C identifier in NAME= specifier at %C");
+ return MATCH_ERROR;
+ }
return MATCH_YES;
}
match
gfc_match_bind_c (gfc_symbol *sym, bool allow_binding_name)
{
- /* binding label, if exists */
- const char* binding_label = NULL;
- match double_quote;
- match single_quote;
+ char *binding_label = NULL;
+ gfc_expr *e = NULL;
- /* Initialize the flag that specifies whether we encountered a NAME=
+ /* Initialize the flag that specifies whether we encountered a NAME=
specifier or not. */
has_name_equals = 0;
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;
- }
+ if (gfc_match_init_expr (&e) != MATCH_YES)
+ {
+ gfc_free_expr (e);
+ return MATCH_ERROR;
}
- else
+
+ if (!gfc_simplify_expr(e, 0))
{
- if (gfc_match_char ('\'') != MATCH_YES)
- {
- gfc_error ("Missing closing quote '\'' for binding label at %C");
- /* User started string with "'" char. */
- return MATCH_ERROR;
- }
+ gfc_error ("NAME= specifier at %C should be a constant expression");
+ gfc_free_expr (e);
+ return MATCH_ERROR;
}
- }
+
+ if (e->expr_type != EXPR_CONSTANT || e->ts.type != BT_CHARACTER
+ || e->ts.kind != gfc_default_character_kind || e->rank != 0)
+ {
+ gfc_error ("NAME= specifier at %C should be a scalar of "
+ "default character kind");
+ gfc_free_expr(e);
+ return MATCH_ERROR;
+ }
+
+ // Get a C string from the Fortran string constant
+ binding_label = gfc_widechar_to_char (e->value.character.string,
+ e->value.character.length);
+ gfc_free_expr(e);
+
+ // Check that it is valid (old gfc_match_name_C)
+ if (check_bind_name_identifier (&binding_label) != MATCH_YES)
+ return MATCH_ERROR;
+ }
/* Get the required right paren. */
if (gfc_match_char (')') != MATCH_YES)
/* 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. */
+ created. */
if (sym != NULL && sym->name != NULL && has_name_equals == 0)
sym->binding_label = IDENTIFIER_POINTER (get_identifier (sym->name));
}
const char *target;
int eos_ok;
match m;
+ gfc_namespace *parent_ns, *ns, *prev_ns;
+ gfc_namespace **nsp;
old_loc = gfc_current_locus;
if (gfc_match ("end") != MATCH_YES)
goto cleanup;
}
+ old_loc = gfc_current_locus;
if (gfc_match_eos () == MATCH_YES)
{
if (!eos_ok && (*st == ST_END_SUBROUTINE || *st == ST_END_FUNCTION))
{
- if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: END statement "
- "instead of %s statement at %L",
- gfc_ascii_statement (*st), &old_loc) == FAILURE)
+ if (!gfc_notify_std (GFC_STD_F2008, "END statement "
+ "instead of %s statement at %L",
+ gfc_ascii_statement(*st), &old_loc))
goto cleanup;
}
else if (!eos_ok)
/* 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));
+ gfc_error ("Expecting %s statement at %L", gfc_ascii_statement (*st),
+ &old_loc);
goto cleanup;
}
+ old_loc = gfc_current_locus;
/* If we're at the end, make sure a block name wasn't required. */
if (gfc_match_eos () == 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));
+ gfc_error ("Expected block name of %qs in %s statement at %L",
+ block_name, gfc_ascii_statement (*st), &old_loc);
return MATCH_ERROR;
}
if (strcmp (name, block_name) != 0 && strcmp (block_name, "ppr@") != 0)
{
- gfc_error ("Expected label '%s' for %s statement at %C", block_name,
+ gfc_error ("Expected label %qs for %s statement at %C", block_name,
gfc_ascii_statement (*st));
goto cleanup;
}
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_error ("Expected label %qs for %s statement at %C",
gfc_current_block ()->ns->proc_name->name,
gfc_ascii_statement (*st));
goto cleanup;
cleanup:
gfc_current_locus = old_loc;
+
+ /* If we are missing an END BLOCK, we created a half-ready namespace.
+ Remove it from the parent namespace's sibling list. */
+
+ if (state == COMP_BLOCK)
+ {
+ parent_ns = gfc_current_ns->parent;
+
+ nsp = &(gfc_state_stack->previous->tail->ext.block.ns);
+
+ prev_ns = NULL;
+ ns = *nsp;
+ while (ns)
+ {
+ if (ns == gfc_current_ns)
+ {
+ if (prev_ns == NULL)
+ *nsp = NULL;
+ else
+ prev_ns->sibling = ns->sibling;
+ }
+ prev_ns = ns;
+ ns = ns->sibling;
+ }
+
+ gfc_free_namespace (gfc_current_ns);
+ gfc_current_ns = parent_ns;
+ }
+
return MATCH_ERROR;
}
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_array_spec *as;
- gfc_symbol *sym;
+
+ /* Workaround -Wmaybe-uninitialized false positive during
+ profiledbootstrap by initializing them. */
+ gfc_symbol *sym = NULL;
locus var_locus;
match m;
if (find_special (name, &sym, false))
return MATCH_ERROR;
- if (check_function_name (name) == FAILURE)
+ if (!check_function_name (name))
{
m = MATCH_ERROR;
goto cleanup;
}
-
+
var_locus = gfc_current_locus;
/* Deal with possible array specification for certain attributes. */
to the first component, or '_data' field. */
if (sym->ts.type == BT_CLASS && sym->ts.u.derived->attr.is_class)
{
- if (gfc_copy_attr (&CLASS_DATA (sym)->attr, ¤t_attr, &var_locus)
- == FAILURE)
+ if (!gfc_copy_attr (&CLASS_DATA(sym)->attr, ¤t_attr, &var_locus))
{
m = MATCH_ERROR;
goto cleanup;
else
{
if (current_attr.dimension == 0 && current_attr.codimension == 0
- && gfc_copy_attr (&sym->attr, ¤t_attr, &var_locus) == FAILURE)
+ && !gfc_copy_attr (&sym->attr, ¤t_attr, &var_locus))
{
m = MATCH_ERROR;
goto cleanup;
}
}
-
+
if (sym->ts.type == BT_CLASS
- && gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as, false) == FAILURE)
+ && !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as))
{
m = MATCH_ERROR;
goto cleanup;
}
- if (gfc_set_array_spec (sym, as, &var_locus) == FAILURE)
+ if (!gfc_set_array_spec (sym, as, &var_locus))
{
m = MATCH_ERROR;
goto cleanup;
if (sym->attr.cray_pointee && sym->as != NULL)
{
/* Fix the array spec. */
- m = gfc_mod_pointee_as (sym->as);
+ m = gfc_mod_pointee_as (sym->as);
if (m == MATCH_ERROR)
goto cleanup;
}
- if (gfc_add_attribute (&sym->attr, &var_locus) == FAILURE)
+ if (!gfc_add_attribute (&sym->attr, &var_locus))
{
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)
+ && !gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL))
{
m = MATCH_ERROR;
goto cleanup;
{
if (gfc_match_char ('(') != MATCH_YES)
{
- gfc_error ("Expected '(' at %C");
+ gfc_error ("Expected %<(%> at %C");
return MATCH_ERROR;
}
return m;
}
- if (gfc_add_cray_pointer (&cptr->attr, &var_locus) == FAILURE)
+ if (!gfc_add_cray_pointer (&cptr->attr, &var_locus))
return MATCH_ERROR;
gfc_set_sym_referenced (cptr);
{
gfc_free_array_spec (as);
as = NULL;
- }
+ }
- if (gfc_add_cray_pointee (&cpte->attr, &var_locus) == FAILURE)
+ if (!gfc_add_cray_pointee (&cpte->attr, &var_locus))
return MATCH_ERROR;
gfc_set_sym_referenced (cpte);
if (cpte->as == NULL)
{
- if (gfc_set_array_spec (cpte, as, &var_locus) == FAILURE)
+ if (!gfc_set_array_spec (cpte, as, &var_locus))
gfc_internal_error ("Couldn't set Cray pointee array spec.");
}
else if (as != NULL)
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;
+ 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");
+ gfc_error ("Expected %<,%> or end of statement at %C");
return MATCH_ERROR;
}
return MATCH_YES;
gfc_gobble_whitespace ();
if (gfc_peek_ascii_char () == '(')
{
- if (!gfc_option.flag_cray_pointer)
+ if (!flag_cray_pointer)
{
gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
"flag");
{
gfc_clear_attr (¤t_attr);
current_attr.pointer = 1;
-
+
return attr_decl ();
}
}
match
gfc_match_contiguous (void)
{
- if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: CONTIGUOUS statement at %C")
- == FAILURE)
+ if (!gfc_notify_std (GFC_STD_F2008, "CONTIGUOUS statement at %C"))
return MATCH_ERROR;
gfc_clear_attr (¤t_attr);
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)
+ if (!gfc_add_access (&sym->attr,
+ (st == ST_PUBLIC)
+ ? ACCESS_PUBLIC : ACCESS_PRIVATE,
+ sym->name, NULL))
return MATCH_ERROR;
if (sym->attr.generic && (dt_sym = gfc_find_dt_in_generic (sym))
- && gfc_add_access (&dt_sym->attr,
- (st == ST_PUBLIC) ? ACCESS_PUBLIC
- : ACCESS_PRIVATE,
- sym->name, NULL) == FAILURE)
+ && !gfc_add_access (&dt_sym->attr,
+ (st == ST_PUBLIC)
+ ? ACCESS_PUBLIC : ACCESS_PRIVATE,
+ sym->name, NULL))
return MATCH_ERROR;
break;
}
- if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PROTECTED statement at %C")
- == FAILURE)
+ if (!gfc_notify_std (GFC_STD_F2003, "PROTECTED statement at %C"))
return MATCH_ERROR;
if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
switch (m)
{
case MATCH_YES:
- if (gfc_add_protected (&sym->attr, sym->name, &gfc_current_locus)
- == FAILURE)
+ if (!gfc_add_protected (&sym->attr, sym->name, &gfc_current_locus))
return MATCH_ERROR;
goto next_item;
gfc_symbol *sym;
gfc_expr *init;
match m;
- gfc_try t;
+ bool t;
m = gfc_match_symbol (&sym, 0);
if (m == MATCH_NO)
return m;
if (sym->ts.type == BT_UNKNOWN
- && gfc_set_default_type (sym, 1, NULL) == FAILURE)
+ && !gfc_set_default_type (sym, 1, NULL))
{
m = MATCH_ERROR;
goto cleanup;
}
- if (gfc_check_assign_symbol (sym, init) == FAILURE
- || gfc_add_flavor (&sym->attr, FL_PARAMETER, sym->name, NULL) == FAILURE)
+ if (!gfc_check_assign_symbol (sym, NULL, init)
+ || !gfc_add_flavor (&sym->attr, FL_PARAMETER, sym->name, NULL))
{
m = MATCH_ERROR;
goto cleanup;
}
t = add_init_expr_to_sym (sym->name, &init, &gfc_current_locus);
- return (t == SUCCESS) ? MATCH_YES : MATCH_ERROR;
+ return (t) ? MATCH_YES : MATCH_ERROR;
cleanup:
gfc_free_expr (init);
{
if (gfc_current_ns->seen_save)
{
- if (gfc_notify_std (GFC_STD_LEGACY, "Blanket SAVE statement at %C "
- "follows previous SAVE statement")
- == FAILURE)
+ if (!gfc_notify_std (GFC_STD_LEGACY, "Blanket SAVE statement at %C "
+ "follows previous SAVE statement"))
return MATCH_ERROR;
}
if (gfc_current_ns->save_all)
{
- if (gfc_notify_std (GFC_STD_LEGACY, "SAVE statement at %C follows "
- "blanket SAVE statement")
- == FAILURE)
+ if (!gfc_notify_std (GFC_STD_LEGACY, "SAVE statement at %C follows "
+ "blanket SAVE statement"))
return MATCH_ERROR;
}
switch (m)
{
case MATCH_YES:
- if (gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name,
- &gfc_current_locus) == FAILURE)
+ if (!gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name,
+ &gfc_current_locus))
return MATCH_ERROR;
goto next_item;
return MATCH_ERROR;
}
- if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VALUE statement at %C")
- == FAILURE)
+ if (!gfc_notify_std (GFC_STD_F2003, "VALUE statement at %C"))
return MATCH_ERROR;
if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
switch (m)
{
case MATCH_YES:
- if (gfc_add_value (&sym->attr, sym->name, &gfc_current_locus)
- == FAILURE)
+ if (!gfc_add_value (&sym->attr, sym->name, &gfc_current_locus))
return MATCH_ERROR;
goto next_item;
gfc_symbol *sym;
match m;
- if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VOLATILE statement at %C")
- == FAILURE)
+ if (!gfc_notify_std (GFC_STD_F2003, "VOLATILE statement at %C"))
return MATCH_ERROR;
if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
for(;;)
{
- /* VOLATILE is special because it can be added to host-associated
- symbols locally. Except for coarrays. */
+ /* VOLATILE is special because it can be added to host-associated
+ symbols locally. Except for coarrays. */
m = gfc_match_symbol (&sym, 1);
switch (m)
{
for variable in a BLOCK which is defined outside of the BLOCK. */
if (sym->ns != gfc_current_ns && sym->attr.codimension)
{
- gfc_error ("Specifying VOLATILE for coarray variable '%s' at "
+ gfc_error ("Specifying VOLATILE for coarray variable %qs at "
"%C, which is use-/host-associated", sym->name);
return MATCH_ERROR;
}
- if (gfc_add_volatile (&sym->attr, sym->name, &gfc_current_locus)
- == FAILURE)
+ if (!gfc_add_volatile (&sym->attr, sym->name, &gfc_current_locus))
return MATCH_ERROR;
goto next_item;
gfc_symbol *sym;
match m;
- if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ASYNCHRONOUS statement at %C")
- == FAILURE)
+ if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS statement at %C"))
return MATCH_ERROR;
if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
for(;;)
{
- /* ASYNCHRONOUS is special because it can be added to host-associated
+ /* ASYNCHRONOUS is special because it can be added to host-associated
symbols locally. */
m = gfc_match_symbol (&sym, 1);
switch (m)
{
case MATCH_YES:
- if (gfc_add_asynchronous (&sym->attr, sym->name, &gfc_current_locus)
- == FAILURE)
+ if (!gfc_add_asynchronous (&sym->attr, sym->name, &gfc_current_locus))
return MATCH_ERROR;
goto next_item;
old_locus = gfc_current_locus;
if (gfc_match ("::") == MATCH_YES)
{
- if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: double colon in "
- "MODULE PROCEDURE statement at %L", &old_locus)
- == FAILURE)
+ if (!gfc_notify_std (GFC_STD_F2008, "double colon in "
+ "MODULE PROCEDURE statement at %L", &old_locus))
return MATCH_ERROR;
}
else
gfc_current_locus = old_locus;
-
+
for (;;)
{
bool last = false;
}
if (sym->attr.proc != PROC_MODULE
- && gfc_add_procedure (&sym->attr, PROC_MODULE,
- sym->name, NULL) == FAILURE)
+ && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL))
return MATCH_ERROR;
- if (gfc_add_interface (sym) == FAILURE)
+ if (!gfc_add_interface (sym))
return MATCH_ERROR;
sym->attr.mod_proc = 1;
/* Check a derived type that is being extended. */
+
static gfc_symbol*
check_extended_derived_type (char *name)
{
return NULL;
}
+ extended = gfc_find_dt_in_generic (extended);
+
+ /* F08:C428. */
if (!extended)
{
- gfc_error ("No such symbol in TYPE definition at %C");
+ gfc_error ("Symbol %qs at %C has not been previously defined", name);
return NULL;
}
- extended = gfc_find_dt_in_generic (extended);
-
if (extended->attr.flavor != FL_DERIVED)
{
- gfc_error ("'%s' in EXTENDS expression at %C is not a "
+ gfc_error ("%qs in EXTENDS expression at %C is not a "
"derived type", name);
return NULL;
}
if (extended->attr.is_bind_c)
{
- gfc_error ("'%s' cannot be extended at %C because it "
+ gfc_error ("%qs cannot be extended at %C because it "
"is BIND(C)", extended->name);
return NULL;
}
if (extended->attr.sequence)
{
- gfc_error ("'%s' cannot be extended at %C because it "
+ gfc_error ("%qs cannot be extended at %C because it "
"is a SEQUENCE type", extended->name);
return NULL;
}
return MATCH_ERROR;
}
- if (gfc_add_access (attr, ACCESS_PRIVATE, NULL, NULL) == FAILURE)
+ if (!gfc_add_access (attr, ACCESS_PRIVATE, NULL, NULL))
return MATCH_ERROR;
}
else if (gfc_match (" , public") == MATCH_YES)
return MATCH_ERROR;
}
- if (gfc_add_access (attr, ACCESS_PUBLIC, NULL, NULL) == FAILURE)
+ if (!gfc_add_access (attr, ACCESS_PUBLIC, NULL, NULL))
return MATCH_ERROR;
}
else if (gfc_match (" , bind ( c )") == MATCH_YES)
sure that all fields are interoperable. This will
need to be a semantic check on the finished derived type.
See 15.2.3 (lines 9-12) of F2003 draft. */
- if (gfc_add_is_bind_c (attr, NULL, &gfc_current_locus, 0) != SUCCESS)
+ if (!gfc_add_is_bind_c (attr, NULL, &gfc_current_locus, 0))
return MATCH_ERROR;
/* TODO: attr conflicts need to be checked, probably in symbol.c. */
}
else if (gfc_match (" , abstract") == MATCH_YES)
{
- if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ABSTRACT type at %C")
- == FAILURE)
+ if (!gfc_notify_std (GFC_STD_F2003, "ABSTRACT type at %C"))
return MATCH_ERROR;
- if (gfc_add_abstract (attr, &gfc_current_locus) == FAILURE)
+ if (!gfc_add_abstract (attr, &gfc_current_locus))
return MATCH_ERROR;
}
- else if (name && gfc_match(" , extends ( %n )", name) == MATCH_YES)
+ else if (name && gfc_match (" , extends ( %n )", name) == MATCH_YES)
{
- if (gfc_add_extension (attr, &gfc_current_locus) == FAILURE)
+ if (!gfc_add_extension (attr, &gfc_current_locus))
return MATCH_ERROR;
}
else
/* Make sure the name is not the name of an intrinsic type. */
if (gfc_is_intrinsic_typename (name))
{
- gfc_error ("Type name '%s' at %C cannot be the same as an intrinsic "
+ gfc_error ("Type name %qs at %C cannot be the same as an intrinsic "
"type", name);
return MATCH_ERROR;
}
if (!gensym->attr.generic && gensym->ts.type != BT_UNKNOWN)
{
- gfc_error ("Derived type name '%s' at %C already has a basic type "
+ gfc_error ("Derived type name %qs at %C already has a basic type "
"of %s", gensym->name, gfc_typename (&gensym->ts));
return MATCH_ERROR;
}
if (!gensym->attr.generic
- && gfc_add_generic (&gensym->attr, gensym->name, NULL) == FAILURE)
+ && !gfc_add_generic (&gensym->attr, gensym->name, NULL))
return MATCH_ERROR;
if (!gensym->attr.function
- && gfc_add_function (&gensym->attr, gensym->name, NULL) == FAILURE)
+ && !gfc_add_function (&gensym->attr, gensym->name, NULL))
return MATCH_ERROR;
sym = gfc_find_dt_in_generic (gensym);
if (sym && (sym->components != NULL || sym->attr.zero_comp))
{
- gfc_error ("Derived type definition of '%s' at %C has already been "
+ gfc_error ("Derived type definition of %qs at %C has already been "
"defined", sym->name);
return MATCH_ERROR;
}
derived type that is a pointer. The first part of the AND clause
is true if the symbol is not the return value of a function. */
if (sym->attr.flavor != FL_DERIVED
- && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
+ && !gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL))
return MATCH_ERROR;
if (attr.access != ACCESS_UNKNOWN
- && gfc_add_access (&sym->attr, attr.access, sym->name, NULL) == FAILURE)
+ && !gfc_add_access (&sym->attr, attr.access, sym->name, NULL))
return MATCH_ERROR;
else if (sym->attr.access == ACCESS_UNKNOWN
&& gensym->attr.access != ACCESS_UNKNOWN
- && gfc_add_access (&sym->attr, gensym->attr.access, sym->name, NULL)
- == FAILURE)
+ && !gfc_add_access (&sym->attr, gensym->attr.access,
+ sym->name, NULL))
return MATCH_ERROR;
if (sym->attr.access != ACCESS_UNKNOWN
/* Construct the f2k_derived namespace if it is not yet there. */
if (!sym->f2k_derived)
sym->f2k_derived = gfc_get_namespace (NULL, 0);
-
+
if (extended && !sym->components)
{
gfc_component *p;
- gfc_symtree *st;
/* Add the extended derived type as the first component. */
gfc_add_component (sym, parent, &p);
p->ts.type = BT_DERIVED;
p->ts.u.derived = extended;
p->initializer = gfc_default_initializer (&p->ts);
-
+
/* Set extension level. */
if (extended->attr.extension == 255)
{
/* Since the extension field is 8 bit wide, we can only have
up to 255 extension levels. */
- gfc_error ("Maximum extension level reached with type '%s' at %L",
+ gfc_error ("Maximum extension level reached with type %qs at %L",
extended->name, &extended->declared_at);
return MATCH_ERROR;
}
/* Provide the links between the extended type and its extension. */
if (!extended->f2k_derived)
extended->f2k_derived = gfc_get_namespace (NULL, 0);
- st = gfc_new_symtree (&extended->f2k_derived->sym_root, sym->name);
- st->n.sym = sym;
}
if (!sym->hash_value)
}
-/* Cray Pointees can be declared as:
+/* Cray Pointees can be declared as:
pointer (ipt, a (n,m,...,*)) */
match
}
-/* Match the enum definition statement, here we are trying to match
- the first line of enum definition statement.
+/* 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, "Fortran 2003: ENUM and ENUMERATOR at %C")
- == FAILURE)
+ if (!gfc_notify_std (GFC_STD_F2003, "ENUM and ENUMERATOR at %C"))
return MATCH_ERROR;
return MATCH_YES;
gfc_symbol *sym;
locus var_locus;
match m;
- gfc_try t;
+ bool t;
locus old_locus;
initializer = NULL;
/* OK, we've successfully matched the declaration. Now put the
symbol in the current namespace. If we fail to create the symbol,
bail out. */
- if (build_sym (name, NULL, false, &as, &var_locus) == FAILURE)
+ if (!build_sym (name, NULL, false, &as, &var_locus))
{
m = MATCH_ERROR;
goto cleanup;
gfc_find_symbol (name, NULL, 0, &sym);
create_enum_history (sym, last_initializer);
- return (t == SUCCESS) ? MATCH_YES : MATCH_ERROR;
+ return (t) ? MATCH_YES : MATCH_ERROR;
cleanup:
/* Free stuff up and return. */
gfc_match_enumerator_def (void)
{
match m;
- gfc_try t;
+ bool t;
gfc_clear_ts (¤t_ts);
gfc_clear_attr (¤t_attr);
t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, NULL);
- if (t == FAILURE)
+ if (!t)
{
m = MATCH_ERROR;
goto cleanup;
return m;
if (m != MATCH_YES)
{
- gfc_error ("Interface-name expected after '(' at %C");
+ gfc_error ("Interface-name expected after %<(%> at %C");
return MATCH_ERROR;
}
if (gfc_match (" )") != MATCH_YES)
{
- gfc_error ("')' expected at %C");
+ gfc_error ("%<)%> expected at %C");
return MATCH_ERROR;
}
seen_colons = (m == MATCH_YES);
if (seen_attrs && !seen_colons)
{
- gfc_error ("Expected '::' after binding-attributes at %C");
+ gfc_error ("Expected %<::%> after binding-attributes at %C");
return MATCH_ERROR;
}
- /* Match the binding names. */
+ /* Match the binding names. */
for(num=1;;num++)
{
m = gfc_match_name (name);
return MATCH_ERROR;
}
- if (num>1 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: PROCEDURE list"
- " at %C") == FAILURE)
+ if (num>1 && !gfc_notify_std (GFC_STD_F2008, "PROCEDURE list at %C"))
return MATCH_ERROR;
/* Try to match the '=> target', if it's there. */
{
if (tb.deferred)
{
- gfc_error ("'=> target' is invalid for DEFERRED binding at %C");
+ gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C");
return MATCH_ERROR;
}
if (!seen_colons)
{
- gfc_error ("'::' needed in PROCEDURE binding with explicit target"
+ gfc_error ("%<::%> needed in PROCEDURE binding with explicit target"
" at %C");
return MATCH_ERROR;
}
return m;
if (m == MATCH_NO)
{
- gfc_error ("Expected binding target after '=>' at %C");
+ gfc_error ("Expected binding target after %<=>%> at %C");
return MATCH_ERROR;
}
target = target_buf;
/* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
if (tb.deferred && !block->attr.abstract)
{
- gfc_error ("Type '%s' containing DEFERRED binding at %C "
+ gfc_error ("Type %qs containing DEFERRED binding at %C "
"is not ABSTRACT", block->name);
return MATCH_ERROR;
}
/* See if we already have a binding with this name in the symtree which
- would be an error. If a GENERIC already targetted this binding, it may
+ would be an error. If a GENERIC already targeted this binding, it may
be already there but then typebound is still NULL. */
stree = gfc_find_symtree (ns->tb_sym_root, name);
if (stree && stree->n.tb)
{
- gfc_error ("There is already a procedure with binding name '%s' for "
- "the derived type '%s' at %C", name, block->name);
+ gfc_error ("There is already a procedure with binding name %qs for "
+ "the derived type %qs at %C", name, block->name);
return MATCH_ERROR;
}
false))
return MATCH_ERROR;
gfc_set_sym_referenced (stree->n.tb->u.specific->n.sym);
-
+
if (gfc_match_eos () == MATCH_YES)
return MATCH_YES;
if (gfc_match_char (',') != MATCH_YES)
/* Now the colons, those are required. */
if (gfc_match (" ::") != MATCH_YES)
{
- gfc_error ("Expected '::' at %C");
+ gfc_error ("Expected %<::%> at %C");
goto error;
}
/* Match the binding name; depending on type (operator / generic) format
it for future error messages into bind_name. */
-
+
m = gfc_match_generic_spec (&op_type, name, &op);
if (m == MATCH_ERROR)
return MATCH_ERROR;
case INTERFACE_GENERIC:
snprintf (bind_name, sizeof (bind_name), "%s", name);
break;
-
+
case INTERFACE_USER_OP:
snprintf (bind_name, sizeof (bind_name), "OPERATOR(.%s.)", name);
break;
-
+
case INTERFACE_INTRINSIC_OP:
snprintf (bind_name, sizeof (bind_name), "OPERATOR(%s)",
gfc_op2string (op));
/* Match the required =>. */
if (gfc_match (" =>") != MATCH_YES)
{
- gfc_error ("Expected '=>' at %C");
+ gfc_error ("Expected %<=>%> at %C");
goto error;
}
-
+
/* Try to find existing GENERIC binding with this name / for this operator;
if there is something, check that it is another GENERIC and then extend
it rather than building a new node. Otherwise, create it and put it
{
gcc_assert (op_type == INTERFACE_GENERIC);
gfc_error ("There's already a non-generic procedure with binding name"
- " '%s' for the derived type '%s' at %C",
+ " %qs for the derived type %qs at %C",
bind_name, block->name);
goto error;
}
if (tb->access != tbattr.access)
{
gfc_error ("Binding at %C must have the same access as already"
- " defined binding '%s'", bind_name);
+ " defined binding %qs", bind_name);
goto error;
}
}
break;
}
-
+
case INTERFACE_INTRINSIC_OP:
ns->tb_op[op] = tb;
break;
for (target = tb->u.generic; target; target = target->next)
if (target_st == target->specific_st)
{
- gfc_error ("'%s' already defined as specific binding for the"
- " generic '%s' at %C", name, bind_name);
+ gfc_error ("%qs already defined as specific binding for the"
+ " generic %qs at %C", name, bind_name);
goto error;
}
if (!gfc_is_whitespace (c) && c != ':')
return MATCH_NO;
}
-
+
if (gfc_state_stack->state != COMP_DERIVED_CONTAINS)
{
if (gfc_current_form == FORM_FIXED)
last = true;
if (!last && gfc_match_char (',') != MATCH_YES)
{
- gfc_error ("Expected ',' at %C");
+ gfc_error ("Expected %<,%> at %C");
return MATCH_ERROR;
}
if (gfc_get_symbol (name, module_ns, &sym))
{
- gfc_error ("Unknown procedure name \"%s\" at %C", name);
+ gfc_error ("Unknown procedure name %qs at %C", name);
return MATCH_ERROR;
}
/* Mark the symbol as module procedure. */
if (sym->attr.proc != PROC_MODULE
- && gfc_add_procedure (&sym->attr, PROC_MODULE,
- sym->name, NULL) == FAILURE)
+ && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL))
return MATCH_ERROR;
/* Check if we already have this symbol in the list, this is an error. */
for (f = block->f2k_derived->finalizers; f; f = f->next)
if (f->proc_sym == sym)
{
- gfc_error ("'%s' at %C is already defined as FINAL procedure!",
+ gfc_error ("%qs at %C is already defined as FINAL procedure!",
name);
return MATCH_ERROR;
}
const ext_attr_t ext_attr_list[] = {
- { "dllimport", EXT_ATTR_DLLIMPORT, "dllimport" },
- { "dllexport", EXT_ATTR_DLLEXPORT, "dllexport" },
- { "cdecl", EXT_ATTR_CDECL, "cdecl" },
- { "stdcall", EXT_ATTR_STDCALL, "stdcall" },
- { "fastcall", EXT_ATTR_FASTCALL, "fastcall" },
- { NULL, EXT_ATTR_LAST, NULL }
+ { "dllimport", EXT_ATTR_DLLIMPORT, "dllimport" },
+ { "dllexport", EXT_ATTR_DLLEXPORT, "dllexport" },
+ { "cdecl", EXT_ATTR_CDECL, "cdecl" },
+ { "stdcall", EXT_ATTR_STDCALL, "stdcall" },
+ { "fastcall", EXT_ATTR_FASTCALL, "fastcall" },
+ { "no_arg_check", EXT_ATTR_NO_ARG_CHECK, NULL },
+ { NULL, EXT_ATTR_LAST, NULL }
};
/* Match a !GCC$ ATTRIBUTES statement of the form:
MATCH_NO. */
match
gfc_match_gcc_attributes (void)
-{
+{
symbol_attribute attr;
char name[GFC_MAX_SYMBOL_LEN + 1];
unsigned id;
return MATCH_ERROR;
}
- if (gfc_add_ext_attribute (&attr, (ext_attr_id_t) id, &gfc_current_locus)
- == FAILURE)
+ if (!gfc_add_ext_attribute (&attr, (ext_attr_id_t)id, &gfc_current_locus))
return MATCH_ERROR;
gfc_gobble_whitespace ();
if (find_special (name, &sym, true))
return MATCH_ERROR;
-
+
sym->attr.ext_attr |= attr.ext_attr;
if (gfc_match_eos () == MATCH_YES)
projects / gcc.git / blobdiff