/* 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);
}
}
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))
- gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as, false);
+ if (sym->ts.type == BT_CLASS)
+ 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;
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;
}
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;
}
+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
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;
}
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. */
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;
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)
/* 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 || 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)
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;
}
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;
}
case COMP_MODULE:
case COMP_SUBROUTINE:
case COMP_FUNCTION:
+ case COMP_BLOCK:
m = match_procedure_decl ();
break;
case COMP_INTERFACE:
"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 (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. */
+ 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;
}
}
- if (sym->ts.type == BT_CLASS && !sym->attr.class_ok
- && (sym->attr.class_ok = sym->attr.class_ok || current_attr.allocatable
- || current_attr.pointer))
- gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as, false);
+ 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
{
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;
OSDN Git Service
