/* Declaration statement matcher
- Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+ Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
Free Software Foundation, Inc.
Contributed by Andy Vaught
gfc_free_expr (p->expr);
gfc_free_iterator (&p->iter, 0);
free_variable (p->list);
- gfc_free (p);
+ free (p);
}
}
for (; p; p = q)
{
q = p->next;
+ mpz_clear (p->repeat);
gfc_free_expr (p->expr);
- gfc_free (p);
+ free (p);
}
}
q = p->next;
free_variable (p->var);
free_value (p->value);
- gfc_free (p);
+ free (p);
}
}
for (;ns->data;)
{
d = ns->data->next;
- gfc_free (ns->data);
+ free (ns->data);
ns->data = d;
}
}
m = top_val_list (newdata);
if (m != MATCH_YES)
{
- gfc_free (newdata);
+ free (newdata);
return m;
}
if (gfc_pure (NULL))
{
gfc_error ("Initialization at %C is not allowed in a PURE procedure");
- gfc_free (newdata);
+ free (newdata);
return MATCH_ERROR;
}
+ if (gfc_implicit_pure (NULL))
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
+
/* Mark the variable as having appeared in a data statement. */
if (gfc_add_data (&sym->attr, sym->name, &sym->declared_at) == FAILURE)
{
- gfc_free (newdata);
+ free (newdata);
return MATCH_ERROR;
}
return MATCH_ERROR;
}
+ if (gfc_implicit_pure (NULL))
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
+
return MATCH_YES;
cleanup:
/* Matches a character length specification, which is either a
- specification expression or a '*'. */
+ specification expression, '*', or ':'. */
static match
-char_len_param_value (gfc_expr **expr)
+char_len_param_value (gfc_expr **expr, bool *deferred)
{
match m;
+ *expr = NULL;
+ *deferred = false;
+
if (gfc_match_char ('*') == MATCH_YES)
+ return MATCH_YES;
+
+ if (gfc_match_char (':') == MATCH_YES)
{
- *expr = NULL;
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: deferred type "
+ "parameter at %C") == FAILURE)
+ return MATCH_ERROR;
+
+ *deferred = true;
+
return MATCH_YES;
}
char_len_param_value in parenthesis. */
static match
-match_char_length (gfc_expr **expr)
+match_char_length (gfc_expr **expr, bool *deferred)
{
int length;
match m;
+ *deferred = false;
m = gfc_match_char ('*');
if (m != MATCH_YES)
return m;
if (gfc_match_char ('(') == MATCH_NO)
goto syntax;
- m = char_len_param_value (expr);
+ m = char_len_param_value (expr, deferred);
if (m != MATCH_YES && gfc_matching_function)
{
gfc_undo_symbols ();
across platforms. */
gfc_try
-verify_c_interop_param (gfc_symbol *sym)
+gfc_verify_c_interop_param (gfc_symbol *sym)
{
int is_c_interop = 0;
gfc_try retval = SUCCESS;
{
if (sym->ns->proc_name->attr.is_bind_c == 1)
{
- is_c_interop =
- (verify_c_interop (&(sym->ts))
- == SUCCESS ? 1 : 0);
+ is_c_interop = (gfc_verify_c_interop (&(sym->ts)) == SUCCESS ? 1 : 0);
if (is_c_interop != 1)
{
/* Make personalized messages to give better feedback. */
if (sym->ts.type == BT_DERIVED)
- gfc_error ("Type '%s' at %L is a parameter to the BIND(C) "
- " procedure '%s' but is not C interoperable "
+ gfc_error ("Variable '%s' at %L is a dummy argument to the "
+ "BIND(C) procedure '%s' but is not C interoperable "
"because derived type '%s' is not C interoperable",
sym->name, &(sym->declared_at),
sym->ns->proc_name->name,
sym->ts.u.derived->name);
+ else if (sym->ts.type == BT_CLASS)
+ gfc_error ("Variable '%s' at %L is a dummy argument to the "
+ "BIND(C) procedure '%s' but is not C interoperable "
+ "because it is polymorphic",
+ sym->name, &(sym->declared_at),
+ sym->ns->proc_name->name);
else
gfc_warning ("Variable '%s' at %L is a parameter to the "
"BIND(C) procedure '%s' but may not be C "
retval = FAILURE;
}
- if (sym->attr.optional == 1)
+ if (sym->attr.optional == 1 && sym->attr.value)
{
- gfc_error ("Variable '%s' at %L cannot have the "
- "OPTIONAL attribute because procedure '%s'"
- " is BIND(C)", sym->name, &(sym->declared_at),
+ gfc_error ("Variable '%s' at %L cannot have both the OPTIONAL "
+ "and the VALUE attribute because procedure '%s' "
+ "is BIND(C)", sym->name, &(sym->declared_at),
sym->ns->proc_name->name);
retval = FAILURE;
}
+ else if (sym->attr.optional == 1
+ && gfc_notify_std (GFC_STD_F2008_TS, "TS29113: Variable '%s' "
+ "at %L with OPTIONAL attribute in "
+ "procedure '%s' which is BIND(C)",
+ sym->name, &(sym->declared_at),
+ sym->ns->proc_name->name)
+ == FAILURE)
+ retval = FAILURE;
/* Make sure that if it has the dimension attribute, that it is
either assumed size or explicit shape. */
/* Function called by variable_decl() that adds a name to the symbol table. */
static gfc_try
-build_sym (const char *name, gfc_charlen *cl,
+build_sym (const char *name, gfc_charlen *cl, bool cl_deferred,
gfc_array_spec **as, locus *var_locus)
{
symbol_attribute attr;
return FAILURE;
if (sym->ts.type == BT_CHARACTER)
- sym->ts.u.cl = cl;
+ {
+ sym->ts.u.cl = cl;
+ sym->ts.deferred = cl_deferred;
+ }
/* Add dimension attribute if present. */
if (gfc_set_array_spec (sym, *as, var_locus) == FAILURE)
sym->attr.implied_index = 0;
if (sym->ts.type == BT_CLASS)
- {
- sym->attr.class_ok = (sym->attr.dummy
- || sym->attr.pointer
- || sym->attr.allocatable) ? 1 : 0;
- gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as, false);
- }
+ return gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as, false);
return SUCCESS;
}
&expr->where, slen, check_len);
s[len] = '\0';
- gfc_free (expr->value.character.string);
+ free (expr->value.character.string);
expr->value.character.string = s;
expr->value.character.length = len;
}
while (current != NULL)
{
next = current->next;
- gfc_free (current);
+ free (current);
current = next;
}
max_enum = NULL;
}
/* Check if the assignment can happen. This has to be put off
- until later for a derived type variable. */
+ until later for derived type variables and procedure pointers. */
if (sym->ts.type != BT_DERIVED && init->ts.type != BT_DERIVED
&& sym->ts.type != BT_CLASS && init->ts.type != BT_CLASS
+ && !sym->attr.proc_pointer
&& gfc_check_assign_symbol (sym, init) == FAILURE)
return FAILURE;
}
}
+ /* If sym is implied-shape, set its upper bounds from init. */
+ if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension
+ && sym->as->type == AS_IMPLIED_SHAPE)
+ {
+ int dim;
+
+ if (init->rank == 0)
+ {
+ gfc_error ("Can't initialize implied-shape array at %L"
+ " with scalar", &sym->declared_at);
+ return FAILURE;
+ }
+ gcc_assert (sym->as->rank == init->rank);
+
+ /* Shape should be present, we get an initialization expression. */
+ gcc_assert (init->shape);
+
+ for (dim = 0; dim < sym->as->rank; ++dim)
+ {
+ int k;
+ gfc_expr* lower;
+ gfc_expr* e;
+
+ lower = sym->as->lower[dim];
+ if (lower->expr_type != EXPR_CONSTANT)
+ {
+ gfc_error ("Non-constant lower bound in implied-shape"
+ " declaration at %L", &lower->where);
+ return FAILURE;
+ }
+
+ /* All dimensions must be without upper bound. */
+ gcc_assert (!sym->as->upper[dim]);
+
+ k = lower->ts.kind;
+ e = gfc_get_constant_expr (BT_INTEGER, k, &sym->declared_at);
+ mpz_add (e->value.integer,
+ lower->value.integer, init->shape[dim]);
+ mpz_sub_ui (e->value.integer, e->value.integer, 1);
+ sym->as->upper[dim] = e;
+ }
+
+ sym->as->type = AS_EXPLICIT;
+ }
+
/* Need to check if the expression we initialized this
to was one of the iso_c_binding named constants. If so,
and we're a parameter (constant), let it be iso_c.
scalar:
if (c->ts.type == BT_CLASS)
- gfc_build_class_symbol (&c->ts, &c->attr, &c->as, true);
+ {
+ bool delayed = (gfc_state_stack->sym == c->ts.u.derived)
+ || (!c->ts.u.derived->components
+ && !c->ts.u.derived->attr.zero_comp);
+ return gfc_build_class_symbol (&c->ts, &c->attr, &c->as, delayed);
+ }
return t;
}
}
+/* Match the initialization expr for a data pointer or procedure pointer. */
+
+static match
+match_pointer_init (gfc_expr **init, int procptr)
+{
+ match m;
+
+ if (gfc_pure (NULL) && gfc_state_stack->state != COMP_DERIVED)
+ {
+ gfc_error ("Initialization of pointer at %C is not allowed in "
+ "a PURE procedure");
+ return MATCH_ERROR;
+ }
+
+ /* Match NULL() initilization. */
+ m = gfc_match_null (init);
+ if (m != MATCH_NO)
+ return m;
+
+ /* Match non-NULL initialization. */
+ gfc_matching_ptr_assignment = !procptr;
+ gfc_matching_procptr_assignment = procptr;
+ m = gfc_match_rvalue (init);
+ gfc_matching_ptr_assignment = 0;
+ gfc_matching_procptr_assignment = 0;
+ if (m == MATCH_ERROR)
+ return MATCH_ERROR;
+ else if (m == MATCH_NO)
+ {
+ gfc_error ("Error in pointer initialization at %C");
+ return MATCH_ERROR;
+ }
+
+ if (!procptr)
+ gfc_resolve_expr (*init);
+
+ if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: non-NULL pointer "
+ "initialization at %C") == FAILURE)
+ return MATCH_ERROR;
+
+ return MATCH_YES;
+}
+
+
+static gfc_try
+check_function_name (char *name)
+{
+ /* In functions that have a RESULT variable defined, the function name always
+ refers to function calls. Therefore, the name is not allowed to appear in
+ specification statements. When checking this, be careful about
+ 'hidden' procedure pointer results ('ppr@'). */
+
+ if (gfc_current_state () == COMP_FUNCTION)
+ {
+ gfc_symbol *block = gfc_current_block ();
+ if (block && block->result && block->result != block
+ && strcmp (block->result->name, "ppr@") != 0
+ && strcmp (block->name, name) == 0)
+ {
+ gfc_error ("Function name '%s' not allowed at %C", name);
+ return FAILURE;
+ }
+ }
+
+ return SUCCESS;
+}
+
+
/* Match a variable name with an optional initializer. When this
subroutine is called, a variable is expected to be parsed next.
Depending on what is happening at the moment, updates either the
gfc_array_spec *as;
gfc_array_spec *cp_as; /* Extra copy for Cray Pointees. */
gfc_charlen *cl;
+ bool cl_deferred;
locus var_locus;
match m;
gfc_try t;
/* Now we could see the optional array spec. or character length. */
m = gfc_match_array_spec (&as, true, true);
- if (gfc_option.flag_cray_pointer && m == MATCH_YES)
- cp_as = gfc_copy_array_spec (as);
- else if (m == MATCH_ERROR)
+ if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_NO)
else if (current_as)
merge_array_spec (current_as, as, true);
+ if (gfc_option.flag_cray_pointer)
+ cp_as = gfc_copy_array_spec (as);
+
+ /* At this point, we know for sure if the symbol is PARAMETER and can thus
+ determine (and check) whether it can be implied-shape. If it
+ was parsed as assumed-size, change it because PARAMETERs can not
+ be assumed-size. */
+ if (as)
+ {
+ if (as->type == AS_IMPLIED_SHAPE && current_attr.flavor != FL_PARAMETER)
+ {
+ m = MATCH_ERROR;
+ gfc_error ("Non-PARAMETER symbol '%s' at %L can't be implied-shape",
+ name, &var_locus);
+ goto cleanup;
+ }
+
+ if (as->type == AS_ASSUMED_SIZE && as->rank == 1
+ && current_attr.flavor == FL_PARAMETER)
+ as->type = AS_IMPLIED_SHAPE;
+
+ if (as->type == AS_IMPLIED_SHAPE
+ && gfc_notify_std (GFC_STD_F2008,
+ "Fortran 2008: Implied-shape array at %L",
+ &var_locus) == FAILURE)
+ {
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+ }
+
char_len = NULL;
cl = NULL;
+ cl_deferred = false;
if (current_ts.type == BT_CHARACTER)
{
- switch (match_char_length (&char_len))
+ switch (match_char_length (&char_len, &cl_deferred))
{
case MATCH_YES:
cl = gfc_new_charlen (gfc_current_ns, NULL);
else
cl = current_ts.u.cl;
+ cl_deferred = current_ts.deferred;
+
break;
case MATCH_ERROR:
create a symbol for those yet. If we fail to create the symbol,
bail out. */
if (gfc_current_state () != COMP_DERIVED
- && build_sym (name, cl, &as, &var_locus) == FAILURE)
+ && build_sym (name, cl, cl_deferred, &as, &var_locus) == FAILURE)
{
m = MATCH_ERROR;
goto cleanup;
goto cleanup;
}
}
-
- /* In functions that have a RESULT variable defined, the function
- name always refers to function calls. Therefore, the name is
- not allowed to appear in specification statements. */
- if (gfc_current_state () == COMP_FUNCTION
- && gfc_current_block () != NULL
- && gfc_current_block ()->result != NULL
- && gfc_current_block ()->result != gfc_current_block ()
- && strcmp (gfc_current_block ()->name, name) == 0)
+
+ if (check_function_name (name) == FAILURE)
{
- gfc_error ("Function name '%s' not allowed at %C", name);
m = MATCH_ERROR;
goto cleanup;
}
goto cleanup;
}
- m = gfc_match_null (&initializer);
- if (m == MATCH_NO)
- {
- gfc_error ("Pointer initialization requires a NULL() at %C");
- m = MATCH_ERROR;
- }
-
- if (gfc_pure (NULL) && gfc_state_stack->state != COMP_DERIVED)
- {
- gfc_error ("Initialization of pointer at %C is not allowed in "
- "a PURE procedure");
- m = MATCH_ERROR;
- }
-
+ m = match_pointer_init (&initializer, 0);
if (m != MATCH_YES)
goto cleanup;
-
}
else if (gfc_match_char ('=') == MATCH_YES)
{
gfc_charlen *cl;
gfc_expr *len;
match m;
+ bool deferred;
len = NULL;
seen_length = 0;
kind = 0;
is_iso_c = 0;
+ deferred = false;
/* Try the old-style specification first. */
old_char_selector = 0;
- m = match_char_length (&len);
+ m = match_char_length (&len, &deferred);
if (m != MATCH_NO)
{
if (m == MATCH_YES)
if (gfc_match (" , len =") == MATCH_NO)
goto rparen;
- m = char_len_param_value (&len);
+ m = char_len_param_value (&len, &deferred);
if (m == MATCH_NO)
goto syntax;
if (m == MATCH_ERROR)
/* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
if (gfc_match (" len =") == MATCH_YES)
{
- m = char_len_param_value (&len);
+ m = char_len_param_value (&len, &deferred);
if (m == MATCH_NO)
goto syntax;
if (m == MATCH_ERROR)
}
/* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
- m = char_len_param_value (&len);
+ m = char_len_param_value (&len, &deferred);
if (m == MATCH_NO)
goto syntax;
if (m == MATCH_ERROR)
ts->u.cl = cl;
ts->kind = kind == 0 ? gfc_default_character_kind : kind;
+ ts->deferred = deferred;
/* We have to know if it was a c interoperable kind so we can
do accurate type checking of bind(c) procs, etc. */
gfc_symbol *sym;
match m;
char c;
- bool seen_deferred_kind;
+ bool seen_deferred_kind, matched_type;
/* A belt and braces check that the typespec is correctly being treated
as a deferred characteristic association. */
return MATCH_YES;
}
- if (gfc_match (" integer") == MATCH_YES)
+
+ m = gfc_match (" type ( %n", name);
+ matched_type = (m == MATCH_YES);
+
+ if ((matched_type && strcmp ("integer", name) == 0)
+ || (!matched_type && gfc_match (" integer") == MATCH_YES))
{
ts->type = BT_INTEGER;
ts->kind = gfc_default_integer_kind;
goto get_kind;
}
- if (gfc_match (" character") == MATCH_YES)
+ if ((matched_type && strcmp ("character", name) == 0)
+ || (!matched_type && gfc_match (" character") == MATCH_YES))
{
+ if (matched_type
+ && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: TYPE with "
+ "intrinsic-type-spec at %C") == FAILURE)
+ return MATCH_ERROR;
+
ts->type = BT_CHARACTER;
if (implicit_flag == 0)
- return gfc_match_char_spec (ts);
+ m = gfc_match_char_spec (ts);
else
- return MATCH_YES;
+ m = MATCH_YES;
+
+ if (matched_type && m == MATCH_YES && gfc_match_char (')') != MATCH_YES)
+ m = MATCH_ERROR;
+
+ return m;
}
- if (gfc_match (" real") == MATCH_YES)
+ if ((matched_type && strcmp ("real", name) == 0)
+ || (!matched_type && gfc_match (" real") == MATCH_YES))
{
ts->type = BT_REAL;
ts->kind = gfc_default_real_kind;
goto get_kind;
}
- if (gfc_match (" double precision") == MATCH_YES)
+ if ((matched_type
+ && (strcmp ("doubleprecision", name) == 0
+ || (strcmp ("double", name) == 0
+ && gfc_match (" precision") == MATCH_YES)))
+ || (!matched_type && gfc_match (" double precision") == MATCH_YES))
{
+ if (matched_type
+ && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: TYPE with "
+ "intrinsic-type-spec at %C") == FAILURE)
+ return MATCH_ERROR;
+ if (matched_type && gfc_match_char (')') != MATCH_YES)
+ return MATCH_ERROR;
+
ts->type = BT_REAL;
ts->kind = gfc_default_double_kind;
return MATCH_YES;
}
- if (gfc_match (" complex") == MATCH_YES)
+ if ((matched_type && strcmp ("complex", name) == 0)
+ || (!matched_type && gfc_match (" complex") == MATCH_YES))
{
ts->type = BT_COMPLEX;
ts->kind = gfc_default_complex_kind;
goto get_kind;
}
- if (gfc_match (" double complex") == MATCH_YES)
+ if ((matched_type
+ && (strcmp ("doublecomplex", name) == 0
+ || (strcmp ("double", name) == 0
+ && gfc_match (" complex") == MATCH_YES)))
+ || (!matched_type && gfc_match (" double complex") == MATCH_YES))
{
- if (gfc_notify_std (GFC_STD_GNU, "DOUBLE COMPLEX at %C does not "
- "conform to the Fortran 95 standard") == FAILURE)
+ if (gfc_notify_std (GFC_STD_GNU, "Extension: DOUBLE COMPLEX at %C")
+ == FAILURE)
+ return MATCH_ERROR;
+
+ if (matched_type
+ && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: TYPE with "
+ "intrinsic-type-spec at %C") == FAILURE)
+ return MATCH_ERROR;
+
+ if (matched_type && gfc_match_char (')') != MATCH_YES)
return MATCH_ERROR;
ts->type = BT_COMPLEX;
return MATCH_YES;
}
- if (gfc_match (" logical") == MATCH_YES)
+ if ((matched_type && strcmp ("logical", name) == 0)
+ || (!matched_type && gfc_match (" logical") == MATCH_YES))
{
ts->type = BT_LOGICAL;
ts->kind = gfc_default_logical_kind;
goto get_kind;
}
- m = gfc_match (" type ( %n )", name);
+ if (matched_type)
+ m = gfc_match_char (')');
+
if (m == MATCH_YES)
ts->type = BT_DERIVED;
else
{
+ /* Match CLASS declarations. */
+ m = gfc_match (" class ( * )");
+ if (m == MATCH_ERROR)
+ return MATCH_ERROR;
+ else if (m == MATCH_YES)
+ {
+ gfc_fatal_error ("Unlimited polymorphism at %C not yet supported");
+ return MATCH_ERROR;
+ }
+
m = gfc_match (" class ( %n )", name);
if (m != MATCH_YES)
return m;
return MATCH_YES;
get_kind:
+ if (matched_type
+ && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: TYPE with "
+ "intrinsic-type-spec at %C") == FAILURE)
+ return MATCH_ERROR;
+
/* For all types except double, derived and character, look for an
optional kind specifier. MATCH_NO is actually OK at this point. */
if (implicit_flag == 1)
- return MATCH_YES;
+ {
+ if (matched_type && gfc_match_char (')') != MATCH_YES)
+ return MATCH_ERROR;
+
+ return MATCH_YES;
+ }
if (gfc_current_form == FORM_FREE)
{
c = gfc_peek_ascii_char ();
if (!gfc_is_whitespace (c) && c != '*' && c != '('
&& c != ':' && c != ',')
- return MATCH_NO;
+ {
+ if (matched_type && c == ')')
+ {
+ gfc_next_ascii_char ();
+ return MATCH_YES;
+ }
+ return MATCH_NO;
+ }
}
m = gfc_match_kind_spec (ts, false);
if (m == MATCH_NO && ts->type != BT_CHARACTER)
m = gfc_match_old_kind_spec (ts);
+ if (matched_type && gfc_match_char (')') != MATCH_YES)
+ return MATCH_ERROR;
+
/* Defer association of the KIND expression of function results
until after USE and IMPORT statements. */
if ((gfc_current_state () == COMP_NONE && gfc_error_flag_test ())
for(;;)
{
+ sym = NULL;
m = gfc_match (" %n", name);
switch (m)
{
gfc_error ("Type name '%s' at %C is ambiguous", name);
return MATCH_ERROR;
}
- else if (gfc_current_ns->proc_name->ns->parent != NULL
+ else if (!sym && gfc_current_ns->proc_name->ns->parent != NULL
&& gfc_find_symbol (name,
gfc_current_ns->proc_name->ns->parent,
1, &sym))
else if (m == MATCH_YES)
{
merge_array_spec (as, current_as, false);
- gfc_free (as);
+ free (as);
}
if (m == MATCH_NO)
break;
case DECL_SAVE:
- t = gfc_add_save (¤t_attr, NULL, &seen_at[d]);
+ t = gfc_add_save (¤t_attr, SAVE_EXPLICIT, NULL, &seen_at[d]);
break;
case DECL_TARGET:
}
}
+ /* Module variables implicitly have the SAVE attribute. */
+ if (gfc_current_state () == COMP_MODULE && !current_attr.save)
+ current_attr.save = SAVE_IMPLICIT;
+
colon_seen = 1;
return MATCH_YES;
/* Verify that the given gfc_typespec is for a C interoperable type. */
gfc_try
-verify_c_interop (gfc_typespec *ts)
+gfc_verify_c_interop (gfc_typespec *ts)
{
if (ts->type == BT_DERIVED && ts->u.derived != NULL)
- return (ts->u.derived->ts.is_c_interop ? SUCCESS : FAILURE);
+ return (ts->u.derived->ts.is_c_interop || ts->u.derived->attr.is_bind_c)
+ ? SUCCESS : FAILURE;
+ else if (ts->type == BT_CLASS)
+ return FAILURE;
else if (ts->is_c_interop != 1)
return FAILURE;
the given ts (current_ts), so look in both. */
if (tmp_sym->ts.type != BT_UNKNOWN || ts->type != BT_UNKNOWN)
{
- if (verify_c_interop (&(tmp_sym->ts)) != SUCCESS)
+ if (gfc_verify_c_interop (&(tmp_sym->ts)) != SUCCESS)
{
/* See if we're dealing with a sym in a common block or not. */
if (is_in_common == 1)
gfc_match_prefix (gfc_typespec *ts)
{
bool seen_type;
+ bool seen_impure;
+ bool found_prefix;
gfc_clear_attr (¤t_attr);
- seen_type = 0;
+ seen_type = false;
+ seen_impure = false;
gcc_assert (!gfc_matching_prefix);
gfc_matching_prefix = true;
-loop:
- if (!seen_type && ts != NULL
- && gfc_match_decl_type_spec (ts, 0) == MATCH_YES
- && gfc_match_space () == MATCH_YES)
+ do
{
+ found_prefix = false;
- seen_type = 1;
- goto loop;
- }
+ if (!seen_type && ts != NULL
+ && gfc_match_decl_type_spec (ts, 0) == MATCH_YES
+ && gfc_match_space () == MATCH_YES)
+ {
- if (gfc_match ("elemental% ") == MATCH_YES)
- {
- if (gfc_add_elemental (¤t_attr, NULL) == FAILURE)
- goto error;
+ seen_type = true;
+ found_prefix = true;
+ }
+
+ if (gfc_match ("elemental% ") == MATCH_YES)
+ {
+ if (gfc_add_elemental (¤t_attr, NULL) == FAILURE)
+ goto error;
+
+ found_prefix = true;
+ }
+
+ if (gfc_match ("pure% ") == MATCH_YES)
+ {
+ if (gfc_add_pure (¤t_attr, NULL) == FAILURE)
+ goto error;
+
+ found_prefix = true;
+ }
+
+ if (gfc_match ("recursive% ") == MATCH_YES)
+ {
+ if (gfc_add_recursive (¤t_attr, NULL) == FAILURE)
+ goto error;
- goto loop;
+ found_prefix = true;
+ }
+
+ /* IMPURE is a somewhat special case, as it needs not set an actual
+ attribute but rather only prevents ELEMENTAL routines from being
+ automatically PURE. */
+ if (gfc_match ("impure% ") == MATCH_YES)
+ {
+ if (gfc_notify_std (GFC_STD_F2008,
+ "Fortran 2008: IMPURE procedure at %C")
+ == FAILURE)
+ goto error;
+
+ seen_impure = true;
+ found_prefix = true;
+ }
}
+ while (found_prefix);
- if (gfc_match ("pure% ") == MATCH_YES)
+ /* IMPURE and PURE must not both appear, of course. */
+ if (seen_impure && current_attr.pure)
{
- if (gfc_add_pure (¤t_attr, NULL) == FAILURE)
- goto error;
-
- goto loop;
+ gfc_error ("PURE and IMPURE must not appear both at %C");
+ goto error;
}
- if (gfc_match ("recursive% ") == MATCH_YES)
+ /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
+ if (!seen_impure && current_attr.elemental && !current_attr.pure)
{
- if (gfc_add_recursive (¤t_attr, NULL) == FAILURE)
+ if (gfc_add_pure (¤t_attr, NULL) == FAILURE)
goto error;
-
- goto loop;
}
/* At this point, the next item is not a prefix. */
return MATCH_ERROR;
sym->ts.interface = gfc_new_symbol ("", gfc_current_ns);
sym->ts.interface->ts = current_ts;
+ sym->ts.interface->attr.flavor = FL_PROCEDURE;
sym->ts.interface->attr.function = 1;
- sym->attr.function = sym->ts.interface->attr.function;
+ sym->attr.function = 1;
sym->attr.if_source = IFSRC_UNKNOWN;
}
goto cleanup;
}
- m = gfc_match_null (&initializer);
- if (m == MATCH_NO)
- {
- gfc_error ("Pointer initialization requires a NULL() at %C");
- m = MATCH_ERROR;
- }
-
- if (gfc_pure (NULL))
- {
- gfc_error ("Initialization of pointer at %C is not allowed in "
- "a PURE procedure");
- m = MATCH_ERROR;
- }
-
+ m = match_pointer_init (&initializer, 1);
if (m != MATCH_YES)
goto cleanup;
c->ts = ts;
c->ts.interface = gfc_new_symbol ("", gfc_current_ns);
c->ts.interface->ts = ts;
+ c->ts.interface->attr.flavor = FL_PROCEDURE;
c->ts.interface->attr.function = 1;
- c->attr.function = c->ts.interface->attr.function;
+ c->attr.function = 1;
c->attr.if_source = IFSRC_UNKNOWN;
}
if (gfc_match (" =>") == MATCH_YES)
{
- m = gfc_match_null (&initializer);
- if (m == MATCH_NO)
- {
- gfc_error ("Pointer initialization requires a NULL() at %C");
- m = MATCH_ERROR;
- }
- if (gfc_pure (NULL))
- {
- gfc_error ("Initialization of pointer at %C is not allowed in "
- "a PURE procedure");
- m = MATCH_ERROR;
- }
+ m = match_pointer_init (&initializer, 1);
if (m != MATCH_YES)
{
gfc_free_expr (initializer);
case COMP_MODULE:
case COMP_SUBROUTINE:
case COMP_FUNCTION:
+ case COMP_BLOCK:
m = match_procedure_decl ();
break;
case COMP_INTERFACE:
if (m != MATCH_YES)
return m;
+ if (gfc_notify_std (GFC_STD_F2008_OBS, "Fortran 2008 obsolescent feature: "
+ "ENTRY statement at %C") == FAILURE)
+ return MATCH_ERROR;
+
state = gfc_current_state ();
if (state != COMP_SUBROUTINE && state != COMP_FUNCTION)
{
"an IF-THEN block");
break;
case COMP_DO:
+ case COMP_DO_CONCURRENT:
gfc_error ("ENTRY statement at %C cannot appear within "
"a DO block");
break;
{
case COMP_ASSOCIATE:
case COMP_BLOCK:
- if (!strcmp (block_name, "block@"))
+ if (!strncmp (block_name, "block@", strlen("block@")))
block_name = NULL;
break;
break;
case COMP_DO:
+ case COMP_DO_CONCURRENT:
*st = ST_ENDDO;
target = " do";
eos_ok = 0;
if (gfc_match_eos () == MATCH_YES)
{
- if (!eos_ok)
+ if (!eos_ok && (*st == ST_END_SUBROUTINE || *st == ST_END_FUNCTION))
+ {
+ if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: END statement "
+ "instead of %s statement at %L",
+ gfc_ascii_statement (*st), &old_loc) == FAILURE)
+ goto cleanup;
+ }
+ else if (!eos_ok)
{
/* We would have required END [something]. */
gfc_error ("%s statement expected at %L",
if (find_special (name, &sym, false))
return MATCH_ERROR;
+ if (check_function_name (name) == FAILURE)
+ {
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+
var_locus = gfc_current_locus;
/* Deal with possible array specification for certain attributes. */
/* Update symbol table. DIMENSION attribute is set in
gfc_set_array_spec(). For CLASS variables, this must be applied
- to the first component, or '$data' field. */
- if (sym->ts.type == BT_CLASS)
+ to the first component, or '_data' field. */
+ if (sym->ts.type == BT_CLASS && sym->ts.u.derived->attr.is_class)
{
- if (gfc_copy_attr (&CLASS_DATA (sym)->attr, ¤t_attr,&var_locus)
+ if (gfc_copy_attr (&CLASS_DATA (sym)->attr, ¤t_attr, &var_locus)
== FAILURE)
{
m = MATCH_ERROR;
goto cleanup;
}
- sym->attr.class_ok = (sym->attr.class_ok || current_attr.allocatable
- || current_attr.pointer);
}
else
{
goto cleanup;
}
}
+
+ if (sym->ts.type == BT_CLASS
+ && gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as, false) == FAILURE)
+ {
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
if (gfc_set_array_spec (sym, as, &var_locus) == FAILURE)
{
case INTERFACE_INTRINSIC_OP:
if (gfc_current_ns->operator_access[op] == ACCESS_UNKNOWN)
{
+ gfc_intrinsic_op other_op;
+
gfc_current_ns->operator_access[op] =
(st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
+
+ /* Handle the case if there is another op with the same
+ function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
+ other_op = gfc_equivalent_op (op);
+
+ if (other_op != INTRINSIC_NONE)
+ gfc_current_ns->operator_access[other_op] =
+ (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
+
}
else
{
switch (m)
{
case MATCH_YES:
- if (gfc_add_save (&sym->attr, sym->name, &gfc_current_locus)
- == FAILURE)
+ if (gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name,
+ &gfc_current_locus) == FAILURE)
return MATCH_ERROR;
goto next_item;
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_symbol *sym;
match m;
+ locus old_locus;
gfc_namespace *module_ns;
gfc_interface *old_interface_head, *interface;
end up with a syntax error and need to recover. */
old_interface_head = gfc_current_interface_head ();
+ /* Check if the F2008 optional double colon appears. */
+ gfc_gobble_whitespace ();
+ old_locus = gfc_current_locus;
+ if (gfc_match ("::") == MATCH_YES)
+ {
+ if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: double colon in "
+ "MODULE PROCEDURE statement at %L", &old_locus)
+ == FAILURE)
+ return MATCH_ERROR;
+ }
+ else
+ gfc_current_locus = old_locus;
+
for (;;)
{
- locus old_locus = gfc_current_locus;
bool last = false;
+ old_locus = gfc_current_locus;
m = gfc_match_name (name);
if (m == MATCH_NO)
current namespace. */
if (gfc_match_eos () == MATCH_YES)
last = true;
+
if (!last && gfc_match_char (',') != MATCH_YES)
goto syntax;
while (interface != old_interface_head)
{
gfc_interface *i = interface->next;
- gfc_free (interface);
+ free (interface);
interface = i;
}
}
-/* Assign a hash value for a derived type. The algorithm is that of
- SDBM. The hashed string is '[module_name #] derived_name'. */
-static unsigned int
-hash_value (gfc_symbol *sym)
-{
- unsigned int hash = 0;
- const char *c;
- int i, len;
-
- /* Hash of the module or procedure name. */
- if (sym->module != NULL)
- c = sym->module;
- else if (sym->ns && sym->ns->proc_name
- && sym->ns->proc_name->attr.flavor == FL_MODULE)
- c = sym->ns->proc_name->name;
- else
- c = NULL;
-
- if (c)
- {
- len = strlen (c);
- for (i = 0; i < len; i++, c++)
- hash = (hash << 6) + (hash << 16) - hash + (*c);
-
- /* Disambiguate between 'a' in 'aa' and 'aa' in 'a'. */
- hash = (hash << 6) + (hash << 16) - hash + '#';
- }
-
- /* Hash of the derived type name. */
- len = strlen (sym->name);
- c = sym->name;
- for (i = 0; i < len; i++, c++)
- hash = (hash << 6) + (hash << 16) - hash + (*c);
-
- /* Return the hash but take the modulus for the sake of module read,
- even though this slightly increases the chance of collision. */
- return (hash % 100000000);
-}
-
-
/* Match the beginning of a derived type declaration. If a type name
was the result of a function, then it is possible to have a symbol
already to be known as a derived type yet have no components. */
if (!sym->hash_value)
/* Set the hash for the compound name for this type. */
- sym->hash_value = hash_value (sym);
+ sym->hash_value = gfc_hash_value (sym);
/* Take over the ABSTRACT attribute. */
sym->attr.abstract = attr.abstract;
/* OK, we've successfully matched the declaration. Now put the
symbol in the current namespace. If we fail to create the symbol,
bail out. */
- if (build_sym (name, NULL, &as, &var_locus) == FAILURE)
+ if (build_sym (name, NULL, false, &as, &var_locus) == FAILURE)
{
m = MATCH_ERROR;
goto cleanup;
}
/* Construct the data structure. */
+ memset (&tb, 0, sizeof (tb));
tb.where = gfc_current_locus;
- tb.is_generic = 0;
/* Match binding attributes. */
m = match_binding_attributes (&tb, false, false);
ns = block->f2k_derived;
gcc_assert (block && ns);
+ memset (&tbattr, 0, sizeof (tbattr));
+ tbattr.where = gfc_current_locus;
+
/* See if we get an access-specifier. */
m = match_binding_attributes (&tbattr, true, false);
if (m == MATCH_ERROR)
OSDN Git Service
