/* Declaration statement matcher
- Copyright (C) 2002, 2004, 2005, 2006, 2007
+ Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008, 2009
Free Software Foundation, Inc.
Contributed by Andy Vaught
/* Macros to access allocate memory for gfc_data_variable,
gfc_data_value and gfc_data. */
-#define gfc_get_data_variable() gfc_getmem (sizeof (gfc_data_variable))
-#define gfc_get_data_value() gfc_getmem (sizeof (gfc_data_value))
-#define gfc_get_data() gfc_getmem( sizeof (gfc_data))
+#define gfc_get_data_variable() XCNEW (gfc_data_variable)
+#define gfc_get_data_value() XCNEW (gfc_data_value)
+#define gfc_get_data() XCNEW (gfc_data)
/* This flag is set if an old-style length selector is matched
gfc_symbol *gfc_new_block;
-locus gfc_function_kind_locus;
-locus gfc_function_type_locus;
+bool gfc_matching_function;
/********************* DATA statement subroutines *********************/
variable-iterator list. */
static match
-var_element (gfc_data_variable *new)
+var_element (gfc_data_variable *new_var)
{
match m;
gfc_symbol *sym;
- memset (new, 0, sizeof (gfc_data_variable));
+ memset (new_var, 0, sizeof (gfc_data_variable));
if (gfc_match_char ('(') == MATCH_YES)
- return var_list (new);
+ return var_list (new_var);
- m = gfc_match_variable (&new->expr, 0);
+ m = gfc_match_variable (&new_var->expr, 0);
if (m != MATCH_YES)
return m;
- sym = new->expr->symtree->n.sym;
+ 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)
+ return MATCH_ERROR;
if (!sym->attr.function && gfc_current_ns->parent
&& gfc_current_ns->parent == sym->ns)
sym->name) == FAILURE)
return MATCH_ERROR;
- if (gfc_add_data (&sym->attr, sym->name, &new->expr->where) == FAILURE)
+ if (gfc_add_data (&sym->attr, sym->name, &new_var->expr->where) == FAILURE)
return MATCH_ERROR;
return MATCH_YES;
static match
top_var_list (gfc_data *d)
{
- gfc_data_variable var, *tail, *new;
+ gfc_data_variable var, *tail, *new_var;
match m;
tail = NULL;
if (m == MATCH_ERROR)
return MATCH_ERROR;
- new = gfc_get_data_variable ();
- *new = var;
+ new_var = gfc_get_data_variable ();
+ *new_var = var;
if (tail == NULL)
- d->var = new;
+ d->var = new_var;
else
- tail->next = new;
+ tail->next = new_var;
- tail = new;
+ tail = new_var;
if (gfc_match_char ('/') == MATCH_YES)
break;
return MATCH_ERROR;
}
else if (sym->attr.flavor == FL_DERIVED)
- return gfc_match_structure_constructor (sym, result);
+ return gfc_match_structure_constructor (sym, result, false);
/* Check to see if the value is an initialization array expression. */
if (sym->value->expr_type == EXPR_ARRAY)
static match
top_val_list (gfc_data *data)
{
- gfc_data_value *new, *tail;
+ gfc_data_value *new_val, *tail;
gfc_expr *expr;
match m;
if (m == MATCH_ERROR)
return MATCH_ERROR;
- new = gfc_get_data_value ();
- mpz_init (new->repeat);
+ new_val = gfc_get_data_value ();
+ mpz_init (new_val->repeat);
if (tail == NULL)
- data->value = new;
+ data->value = new_val;
else
- tail->next = new;
+ tail->next = new_val;
- tail = new;
+ tail = new_val;
if (expr->ts.type != BT_INTEGER || gfc_match_char ('*') != MATCH_YES)
{
match
gfc_match_data (void)
{
- gfc_data *new;
+ gfc_data *new_data;
match m;
set_in_match_data (true);
for (;;)
{
- new = gfc_get_data ();
- new->where = gfc_current_locus;
+ new_data = gfc_get_data ();
+ new_data->where = gfc_current_locus;
- m = top_var_list (new);
+ m = top_var_list (new_data);
if (m != MATCH_YES)
goto cleanup;
- m = top_val_list (new);
+ m = top_val_list (new_data);
if (m != MATCH_YES)
goto cleanup;
- new->next = gfc_current_ns->data;
- gfc_current_ns->data = new;
+ new_data->next = gfc_current_ns->data;
+ gfc_current_ns->data = new_data;
if (gfc_match_eos () == MATCH_YES)
break;
cleanup:
set_in_match_data (false);
- gfc_free_data (new);
+ gfc_free_data (new_data);
return MATCH_ERROR;
}
}
m = gfc_match_expr (expr);
+
+ if (m == MATCH_YES
+ && gfc_expr_check_typed (*expr, gfc_current_ns, false) == FAILURE)
+ return MATCH_ERROR;
+
if (m == MATCH_YES && (*expr)->expr_type == EXPR_FUNCTION)
{
if ((*expr)->value.function.actual
goto syntax;
m = char_len_param_value (expr);
+ if (m != MATCH_YES && gfc_matching_function)
+ {
+ gfc_undo_symbols ();
+ m = MATCH_YES;
+ }
+
if (m == MATCH_ERROR)
return m;
if (m == MATCH_NO)
(*result)->ts = sym->ts;
/* Put the symbol in the procedure namespace so that, should
- the ENTRY preceed its specification, the specification
+ the ENTRY precede its specification, the specification
can be applied. */
(*result)->ns = gfc_current_ns;
sym = *result;
gfc_current_ns->refs++;
- if (sym && !sym->new && gfc_current_state () != COMP_INTERFACE)
+ if (sym && !sym->gfc_new && gfc_current_state () != COMP_INTERFACE)
{
/* Trap another encompassed procedure with the same name. All
these conditions are necessary to avoid picking up an entry
the compiler could have automatically handled the varying sizes
across platforms. */
-try
+gfc_try
verify_c_interop_param (gfc_symbol *sym)
{
int is_c_interop = 0;
- try retval = SUCCESS;
+ gfc_try retval = SUCCESS;
/* We check implicitly typed variables in symbol.c:gfc_set_default_type().
Don't repeat the checks here. */
if (sym->ns->proc_name->attr.is_bind_c == 1)
{
is_c_interop =
- (verify_c_interop (&(sym->ts), sym->name, &(sym->declared_at))
+ (verify_c_interop (&(sym->ts))
== SUCCESS ? 1 : 0);
if (is_c_interop != 1)
/* Function called by variable_decl() that adds a name to the symbol table. */
-static try
+static gfc_try
build_sym (const char *name, gfc_charlen *cl,
gfc_array_spec **as, locus *var_locus)
{
/* Set character constant to the given length. The constant will be padded or
- truncated. */
+ truncated. If we're inside an array constructor without a typespec, we
+ additionally check that all elements have the same length; check_len -1
+ means no checking. */
void
-gfc_set_constant_character_len (int len, gfc_expr *expr, bool array)
+gfc_set_constant_character_len (int len, gfc_expr *expr, int check_len)
{
- char *s;
+ gfc_char_t *s;
int slen;
gcc_assert (expr->expr_type == EXPR_CONSTANT);
- gcc_assert (expr->ts.type == BT_CHARACTER && expr->ts.kind == 1);
+ gcc_assert (expr->ts.type == BT_CHARACTER);
slen = expr->value.character.length;
if (len != slen)
{
- s = gfc_getmem (len + 1);
- memcpy (s, expr->value.character.string, MIN (len, slen));
+ s = gfc_get_wide_string (len + 1);
+ memcpy (s, expr->value.character.string,
+ MIN (len, slen) * sizeof (gfc_char_t));
if (len > slen)
- memset (&s[slen], ' ', 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 "
/* Apply the standard by 'hand' otherwise it gets cleared for
initializers. */
- if (array && slen < len && !(gfc_option.allow_std & GFC_STD_GNU))
+ if (check_len != -1 && slen != check_len
+ && !(gfc_option.allow_std & GFC_STD_GNU))
gfc_error_now ("The CHARACTER elements of the array constructor "
"at %L must have the same length (%d/%d)",
- &expr->where, slen, len);
+ &expr->where, slen, check_len);
s[len] = '\0';
gfc_free (expr->value.character.string);
enumerator_history *new_enum_history;
gcc_assert (sym != NULL && init != NULL);
- new_enum_history = gfc_getmem (sizeof (enumerator_history));
+ new_enum_history = XCNEW (enumerator_history);
new_enum_history->sym = sym;
new_enum_history->initializer = init;
/* Function called by variable_decl() that adds an initialization
expression to a symbol. */
-static try
+static gfc_try
add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus)
{
symbol_attribute attr;
gfc_constructor * p;
if (init->expr_type == EXPR_CONSTANT)
- gfc_set_constant_character_len (len, init, false);
+ gfc_set_constant_character_len (len, init, -1);
else if (init->expr_type == EXPR_ARRAY)
{
/* Build a new charlen to prevent simplification from
init->ts.cl->length = gfc_copy_expr (sym->ts.cl->length);
for (p = init->value.constructor; p; p = p->next)
- gfc_set_constant_character_len (len, p->expr, false);
+ gfc_set_constant_character_len (len, p->expr, -1);
}
}
}
/* Function called by variable_decl() that adds a name to a structure
being built. */
-static try
+static gfc_try
build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
gfc_array_spec **as)
{
c->ts = current_ts;
c->ts.cl = cl;
- gfc_set_component_attr (c, ¤t_attr);
+ c->attr = current_attr;
c->initializer = *init;
*init = NULL;
c->as = *as;
if (c->as != NULL)
- c->dimension = 1;
+ c->attr.dimension = 1;
*as = NULL;
+ /* Should this ever get more complicated, combine with similar section
+ in add_init_expr_to_sym into a separate function. */
+ if (c->ts.type == BT_CHARACTER && !c->attr.pointer && c->initializer && c->ts.cl
+ && c->ts.cl->length && c->ts.cl->length->expr_type == EXPR_CONSTANT)
+ {
+ int len;
+
+ gcc_assert (c->ts.cl && c->ts.cl->length);
+ gcc_assert (c->ts.cl->length->expr_type == EXPR_CONSTANT);
+ gcc_assert (c->ts.cl->length->ts.type == BT_INTEGER);
+
+ len = mpz_get_si (c->ts.cl->length->value.integer);
+
+ if (c->initializer->expr_type == EXPR_CONSTANT)
+ gfc_set_constant_character_len (len, c->initializer, -1);
+ else if (mpz_cmp (c->ts.cl->length->value.integer,
+ c->initializer->ts.cl->length->value.integer))
+ {
+ bool has_ts;
+ gfc_constructor *ctor = c->initializer->value.constructor;
+
+ bool first = true;
+ int first_len;
+
+ has_ts = (c->initializer->ts.cl
+ && c->initializer->ts.cl->length_from_typespec);
+
+ for (; ctor; ctor = ctor->next)
+ {
+ /* Remember the length of the first element for checking that
+ all elements *in the constructor* have the same length. This
+ need not be the length of the LHS! */
+ if (first)
+ {
+ gcc_assert (ctor->expr->expr_type == EXPR_CONSTANT);
+ gcc_assert (ctor->expr->ts.type == BT_CHARACTER);
+ first_len = ctor->expr->value.character.length;
+ first = false;
+ }
+
+ if (ctor->expr->expr_type == EXPR_CONSTANT)
+ gfc_set_constant_character_len (len, ctor->expr,
+ has_ts ? -1 : first_len);
+ }
+ }
+ }
+
/* Check array components. */
- if (!c->dimension)
+ if (!c->attr.dimension)
{
- if (c->allocatable)
+ if (c->attr.allocatable)
{
gfc_error ("Allocatable component at %C must be an array");
return FAILURE;
return SUCCESS;
}
- if (c->pointer)
+ if (c->attr.pointer)
{
if (c->as->type != AS_DEFERRED)
{
return FAILURE;
}
}
- else if (c->allocatable)
+ else if (c->attr.allocatable)
{
if (c->as->type != AS_DEFERRED)
{
gfc_charlen *cl;
locus var_locus;
match m;
- try t;
+ gfc_try t;
gfc_symbol *sym;
locus old_locus;
}
}
+ /* Procedure pointer as function result. */
+ if (gfc_current_state () == COMP_FUNCTION
+ && strcmp ("ppr@", gfc_current_block ()->name) == 0
+ && strcmp (name, gfc_current_block ()->ns->proc_name->name) == 0)
+ strcpy (name, "ppr@");
+
+ if (gfc_current_state () == COMP_FUNCTION
+ && strcmp (name, gfc_current_block ()->name) == 0
+ && gfc_current_block ()->result
+ && strcmp ("ppr@", gfc_current_block ()->result->name) == 0)
+ strcpy (name, "ppr@");
/* OK, we've successfully matched the declaration. Now put the
symbol in the current namespace, because it might be used in the
locus where, loc;
gfc_expr *e;
match m, n;
+ char c;
const char *msg;
m = MATCH_NO;
if (n != MATCH_YES)
{
- if (gfc_current_state () == COMP_INTERFACE
- || gfc_current_state () == COMP_NONE
- || gfc_current_state () == COMP_CONTAINS)
+ if (gfc_matching_function)
{
- /* Signal using kind = -1 that the expression might include
- use associated or imported parameters and try again after
- the specification expressions..... */
+ /* The function kind expression might include use associated or
+ imported parameters and try again after the specification
+ expressions..... */
if (gfc_match_char (')') != MATCH_YES)
{
gfc_error ("Missing right parenthesis at %C");
}
gfc_free_expr (e);
- ts->kind = -1;
- gfc_function_kind_locus = loc;
gfc_undo_symbols ();
return MATCH_YES;
}
}
msg = gfc_extract_int (e, &ts->kind);
+
if (msg != NULL)
{
gfc_error (msg);
{
gfc_error ("Kind %d not supported for type %s at %C", ts->kind,
gfc_basic_typename (ts->type));
- m = MATCH_ERROR;
+ gfc_current_locus = where;
+ return MATCH_ERROR;
}
- else if (gfc_match_char (')') != MATCH_YES)
+
+ /* Warn if, e.g., c_int is used for a REAL variable, but not
+ if, e.g., c_double is used for COMPLEX as the standard
+ explicitly says that the kind type parameter for complex and real
+ variable is the same, i.e. c_float == c_float_complex. */
+ if (ts->f90_type != BT_UNKNOWN && ts->f90_type != ts->type
+ && !((ts->f90_type == BT_REAL && ts->type == BT_COMPLEX)
+ || (ts->f90_type == BT_COMPLEX && ts->type == BT_REAL)))
+ gfc_error_now ("C kind type parameter is for type %s but type at %L "
+ "is %s", gfc_basic_typename (ts->f90_type), &where,
+ gfc_basic_typename (ts->type));
+
+ gfc_gobble_whitespace ();
+ if ((c = gfc_next_ascii_char ()) != ')'
+ && (ts->type != BT_CHARACTER || c != ','))
{
- gfc_error ("Missing right parenthesis at %C");
+ if (ts->type == BT_CHARACTER)
+ gfc_error ("Missing right parenthesis or comma at %C");
+ else
+ gfc_error ("Missing right parenthesis at %C");
m = MATCH_ERROR;
}
else
where = gfc_current_locus;
n = gfc_match_init_expr (&e);
+
+ if (n != MATCH_YES && gfc_matching_function)
+ {
+ /* The expression might include use-associated or imported
+ parameters and try again after the specification
+ expressions. */
+ gfc_free_expr (e);
+ gfc_undo_symbols ();
+ return MATCH_YES;
+ }
+
if (n == MATCH_NO)
gfc_error ("Expected initialization expression at %C");
if (n != MATCH_YES)
return m;
done:
+ /* Deal with character functions after USE and IMPORT statements. */
+ if (gfc_matching_function)
+ {
+ gfc_free_expr (len);
+ gfc_undo_symbols ();
+ return MATCH_YES;
+ }
+
if (m != MATCH_YES)
{
gfc_free_expr (len);
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_symbol *sym;
match m;
- int c;
- locus loc = gfc_current_locus;
-
+ char c;
+ bool seen_deferred_kind;
+
+ /* A belt and braces check that the typespec is correctly being treated
+ as a deferred characteristic association. */
+ seen_deferred_kind = (gfc_current_state () == COMP_FUNCTION)
+ && (gfc_current_block ()->result->ts.kind == -1)
+ && (ts->kind == -1);
gfc_clear_ts (ts);
+ if (seen_deferred_kind)
+ ts->kind = -1;
/* Clear the current binding label, in case one is given. */
curr_binding_label[0] = '\0';
if (m != MATCH_YES)
return m;
- if (gfc_current_state () == COMP_INTERFACE
- || gfc_current_state () == COMP_NONE)
+ ts->type = BT_DERIVED;
+
+ /* 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. */
+ if (gfc_matching_function)
{
- gfc_function_type_locus = loc;
- ts->type = BT_UNKNOWN;
- ts->kind = -1;
+ ts->derived = NULL;
+ if (gfc_current_state () != COMP_INTERFACE
+ && !gfc_find_symbol (name, NULL, 1, &sym) && sym)
+ ts->derived = sym;
return MATCH_YES;
}
/* Search for the name but allow the components to be defined later. If
type = -1, this typespec has been seen in a function declaration but
- the type could not legally be accessed at that point. */
+ the type could not be accessed at that point. */
+ sym = NULL;
if (ts->kind != -1 && gfc_get_ha_symbol (name, &sym))
{
gfc_error ("Type name '%s' at %C is ambiguous", name);
}
else if (ts->kind == -1)
{
- if (gfc_find_symbol (name, NULL, 0, &sym))
+ int iface = gfc_state_stack->previous->state != COMP_INTERFACE
+ || gfc_current_ns->has_import_set;
+ if (gfc_find_symbol (name, NULL, iface, &sym))
{
gfc_error ("Type name '%s' at %C is ambiguous", name);
return MATCH_ERROR;
}
+ ts->kind = 0;
if (sym == NULL)
return MATCH_NO;
}
&& gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
return MATCH_ERROR;
- ts->type = BT_DERIVED;
- ts->kind = 0;
+ gfc_set_sym_referenced (sym);
ts->derived = sym;
return MATCH_YES;
if (gfc_current_form == FORM_FREE)
{
- c = gfc_peek_char();
+ c = gfc_peek_ascii_char();
if (!gfc_is_whitespace(c) && c != '*' && c != '('
&& c != ':' && c != ',')
return MATCH_NO;
if (m == MATCH_NO && ts->type != BT_CHARACTER)
m = gfc_match_old_kind_spec (ts);
+ /* 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 ())
+ || gfc_matching_function)
+ return MATCH_YES;
+
if (m == MATCH_NO)
m = MATCH_YES; /* No kind specifier found. */
static match
match_implicit_range (void)
{
- int c, c1, c2, inner;
+ char c, c1, c2;
+ int inner;
locus cur_loc;
cur_loc = gfc_current_locus;
gfc_gobble_whitespace ();
- c = gfc_next_char ();
+ c = gfc_next_ascii_char ();
if (c != '(')
{
gfc_error ("Missing character range in IMPLICIT at %C");
while (inner)
{
gfc_gobble_whitespace ();
- c1 = gfc_next_char ();
+ c1 = gfc_next_ascii_char ();
if (!ISALPHA (c1))
goto bad;
gfc_gobble_whitespace ();
- c = gfc_next_char ();
+ c = gfc_next_ascii_char ();
switch (c)
{
case '-':
gfc_gobble_whitespace ();
- c2 = gfc_next_char ();
+ c2 = gfc_next_ascii_char ();
if (!ISALPHA (c2))
goto bad;
gfc_gobble_whitespace ();
- c = gfc_next_char ();
+ c = gfc_next_ascii_char ();
if ((c != ',') && (c != ')'))
goto bad;
{
gfc_typespec ts;
locus cur_loc;
- int c;
+ char c;
match m;
+ gfc_clear_ts (&ts);
+
/* We don't allow empty implicit statements. */
if (gfc_match_eos () == MATCH_YES)
{
{
/* We may have <TYPE> (<RANGE>). */
gfc_gobble_whitespace ();
- c = gfc_next_char ();
+ c = gfc_next_ascii_char ();
if ((c == '\n') || (c == ','))
{
/* Check for CHARACTER with no length parameter. */
goto syntax;
gfc_gobble_whitespace ();
- c = gfc_next_char ();
+ c = gfc_next_ascii_char ();
if ((c != '\n') && (c != ','))
goto syntax;
const char *p;
for (p = target; *p; p++)
- if (gfc_next_char () != *p)
+ if ((char) gfc_next_ascii_char () != *p)
return false;
return true;
}
decl_types d;
const char *attr;
match m;
- try t;
+ gfc_try t;
gfc_clear_attr (¤t_attr);
start = gfc_current_locus;
for (;;)
{
- int ch;
+ char ch;
d = DECL_NONE;
gfc_gobble_whitespace ();
- ch = gfc_next_char ();
+ ch = gfc_next_ascii_char ();
if (ch == ':')
{
/* This is the successful exit condition for the loop. */
- if (gfc_next_char () == ':')
+ if (gfc_next_ascii_char () == ':')
break;
}
else if (ch == ',')
{
gfc_gobble_whitespace ();
- switch (gfc_peek_char ())
+ switch (gfc_peek_ascii_char ())
{
case 'a':
if (match_string_p ("allocatable"))
case 'i':
if (match_string_p ("int"))
{
- ch = gfc_next_char ();
+ ch = gfc_next_ascii_char ();
if (ch == 'e')
{
if (match_string_p ("nt"))
break;
case 'p':
- gfc_next_char ();
- switch (gfc_next_char ())
+ gfc_next_ascii_char ();
+ switch (gfc_next_ascii_char ())
{
case 'a':
if (match_string_p ("rameter"))
break;
case 'r':
- ch = gfc_next_char ();
+ ch = gfc_next_ascii_char ();
if (ch == 'i')
{
if (match_string_p ("vate"))
break;
case 'v':
- gfc_next_char ();
- ch = gfc_next_char ();
+ gfc_next_ascii_char ();
+ ch = gfc_next_ascii_char ();
if (ch == 'a')
{
if (match_string_p ("lue"))
goto cleanup;
}
+ /* Check to make sure any parens are paired up correctly. */
+ if (gfc_match_parens () == MATCH_ERROR)
+ {
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+
seen[d]++;
seen_at[d] = gfc_current_locus;
(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. */
-try
+gfc_try
set_binding_label (char *dest_label, const char *sym_name, int num_idents)
{
if (num_idents > 1 && has_name_equals)
/* Verify that the given gfc_typespec is for a C interoperable type. */
-try
-verify_c_interop (gfc_typespec *ts, const char *name, locus *where)
+gfc_try
+verify_c_interop (gfc_typespec *ts)
{
- try t;
-
- /* Make sure the kind used is appropriate for the type.
- The f90_type is unknown if an integer constant was
- used (e.g., real(4), bind(c) :: myFloat). */
- if (ts->f90_type != BT_UNKNOWN)
- {
- t = gfc_validate_c_kind (ts);
- if (t != SUCCESS)
- {
- /* Print an error, but continue parsing line. */
- gfc_error_now ("C kind parameter is for type %s but "
- "symbol '%s' at %L is of type %s",
- gfc_basic_typename (ts->f90_type),
- name, where,
- gfc_basic_typename (ts->type));
- }
- }
-
- /* Make sure the kind is C interoperable. This does not care about the
- possible error above. */
if (ts->type == BT_DERIVED && ts->derived != NULL)
return (ts->derived->ts.is_c_interop ? SUCCESS : FAILURE);
else if (ts->is_c_interop != 1)
interoperable type. Errors will be reported here, if
encountered. */
-try
+gfc_try
verify_com_block_vars_c_interop (gfc_common_head *com_block)
{
gfc_symbol *curr_sym = NULL;
- try retval = SUCCESS;
+ gfc_try retval = SUCCESS;
curr_sym = com_block->head;
/* Verify that a given BIND(C) symbol is C interoperable. If it is not,
an appropriate error message is reported. */
-try
+gfc_try
verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts,
int is_in_common, gfc_common_head *com_block)
{
- try retval = SUCCESS;
+ bool bind_c_function = false;
+ gfc_try retval = SUCCESS;
+
+ if (tmp_sym->attr.function && tmp_sym->attr.is_bind_c)
+ bind_c_function = true;
if (tmp_sym->attr.function && tmp_sym->result != NULL)
{
tmp_sym->attr.is_c_interop = 1;
}
}
-
+
/* Here, we know we have the bind(c) attribute, so if we have
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 (verify_c_interop (&(tmp_sym->ts), tmp_sym->name,
- &(tmp_sym->declared_at)) != SUCCESS)
+ if (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)
retval = FAILURE;
}
- /* If it is a BIND(C) function, make sure the return value is a
- scalar value. The previous tests in this function made sure
- the type is interoperable. */
- if (tmp_sym->attr.function == 1 && tmp_sym->as != NULL)
- gfc_error ("Return type of BIND(C) function '%s' 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->attr.function == 1 && tmp_sym->ts.type == BT_CHARACTER)
- if (tmp_sym->ts.cl == NULL || tmp_sym->ts.cl->length == NULL
- || tmp_sym->ts.cl->length->expr_type != EXPR_CONSTANT
- || mpz_cmp_si (tmp_sym->ts.cl->length->value.integer, 1) != 0)
- gfc_error ("Return type of BIND(C) function '%s' at %L cannot "
+ }
+
+ /* If it is a BIND(C) function, make sure the return value is a
+ 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 "
+ "be an array", tmp_sym->name, &(tmp_sym->declared_at));
+
+ /* BIND(C) functions can not return a character string. */
+ if (bind_c_function && tmp_sym->ts.type == BT_CHARACTER)
+ if (tmp_sym->ts.cl == NULL || tmp_sym->ts.cl->length == NULL
+ || tmp_sym->ts.cl->length->expr_type != EXPR_CONSTANT
+ || mpz_cmp_si (tmp_sym->ts.cl->length->value.integer, 1) != 0)
+ gfc_error ("Return type of BIND(C) function '%s' at %L cannot "
"be a character string", tmp_sym->name,
&(tmp_sym->declared_at));
- }
}
/* See if the symbol has been marked as private. If it has, make sure
the type is C interoperable. Errors are reported by the functions
used to set/test these fields. */
-try
+gfc_try
set_verify_bind_c_sym (gfc_symbol *tmp_sym, int num_idents)
{
- try retval = SUCCESS;
+ gfc_try retval = SUCCESS;
/* TODO: Do we need to make sure the vars aren't marked private? */
/* Set the fields marking the given common block as BIND(C), including
a binding label, and report any errors encountered. */
-try
+gfc_try
set_verify_bind_c_com_block (gfc_common_head *com_block, int num_idents)
{
- try retval = SUCCESS;
+ gfc_try retval = SUCCESS;
/* destLabel, common name, typespec (which may have binding label). */
if (set_binding_label (com_block->binding_label, com_block->name, num_idents)
/* Retrieve the list of one or more identifiers that the given bind(c)
attribute applies to. */
-try
+gfc_try
get_bind_c_idents (void)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
can be matched. Note that if nothing matches, MATCH_YES is
returned (the null string was matched). */
-static match
-match_prefix (gfc_typespec *ts)
+match
+gfc_match_prefix (gfc_typespec *ts)
{
- int seen_type;
+ bool seen_type;
gfc_clear_attr (¤t_attr);
seen_type = 0;
+ gcc_assert (!gfc_matching_prefix);
+ gfc_matching_prefix = true;
+
loop:
if (!seen_type && ts != NULL
&& gfc_match_type_spec (ts, 0) == MATCH_YES
if (gfc_match ("elemental% ") == MATCH_YES)
{
if (gfc_add_elemental (¤t_attr, NULL) == FAILURE)
- return MATCH_ERROR;
+ goto error;
goto loop;
}
if (gfc_match ("pure% ") == MATCH_YES)
{
if (gfc_add_pure (¤t_attr, NULL) == FAILURE)
- return MATCH_ERROR;
+ goto error;
goto loop;
}
if (gfc_match ("recursive% ") == MATCH_YES)
{
if (gfc_add_recursive (¤t_attr, NULL) == FAILURE)
- return MATCH_ERROR;
+ goto error;
goto loop;
}
/* At this point, the next item is not a prefix. */
+ gcc_assert (gfc_matching_prefix);
+ gfc_matching_prefix = false;
return MATCH_YES;
+
+error:
+ gcc_assert (gfc_matching_prefix);
+ gfc_matching_prefix = false;
+ return MATCH_ERROR;
}
-/* Copy attributes matched by match_prefix() to attributes on a symbol. */
+/* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
-static try
+static gfc_try
copy_prefix (symbol_attribute *dest, locus *where)
{
if (current_attr.pure && gfc_add_pure (dest, where) == FAILURE)
if (gfc_get_symbol (name, NULL, &r))
return MATCH_ERROR;
- if (gfc_add_flavor (&r->attr, FL_VARIABLE, r->name, NULL) == FAILURE
- || gfc_add_result (&r->attr, r->name, NULL) == FAILURE)
+ if (gfc_add_result (&r->attr, r->name, NULL) == FAILURE)
return MATCH_ERROR;
*result = r;
match is_bind_c; /* Found bind(c). */
match is_result; /* Found result clause. */
match found_match; /* Status of whether we've found a good match. */
- int peek_char; /* Character we're going to peek at. */
+ char peek_char; /* Character we're going to peek at. */
bool allow_binding_name;
/* Initialize to having found nothing. */
/* Get the next char to narrow between result and bind(c). */
gfc_gobble_whitespace ();
- peek_char = gfc_peek_char ();
+ peek_char = gfc_peek_ascii_char ();
/* C binding names are not allowed for internal procedures. */
if (gfc_current_state () == COMP_CONTAINS
/* 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_GNU, "Extension: BIND(C) attribute at %L "
- "may not be specified for an internal procedure",
- &gfc_current_locus)
+ && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: BIND(C) attribute "
+ "at %L may not be specified for an internal "
+ "procedure", &gfc_current_locus)
== FAILURE)
return MATCH_ERROR;
}
+/* Procedure pointer return value without RESULT statement:
+ Add "hidden" result variable named "ppr@". */
+
+static gfc_try
+add_hidden_procptr_result (gfc_symbol *sym)
+{
+ bool case1,case2;
+
+ if (gfc_notification_std (GFC_STD_F2003) == ERROR)
+ return FAILURE;
+
+ /* First usage case: PROCEDURE and EXTERNAL statements. */
+ case1 = gfc_current_state () == COMP_FUNCTION && gfc_current_block ()
+ && strcmp (gfc_current_block ()->name, sym->name) == 0
+ && sym->attr.external;
+ /* Second usage case: INTERFACE statements. */
+ case2 = gfc_current_state () == COMP_INTERFACE && gfc_state_stack->previous
+ && gfc_state_stack->previous->state == COMP_FUNCTION
+ && strcmp (gfc_state_stack->previous->sym->name, sym->name) == 0;
+
+ if (case1 || case2)
+ {
+ gfc_symtree *stree;
+ if (case1)
+ gfc_get_sym_tree ("ppr@", gfc_current_ns, &stree);
+ else if (case2)
+ {
+ gfc_symtree *st2;
+ gfc_get_sym_tree ("ppr@", gfc_current_ns->parent, &stree);
+ st2 = gfc_new_symtree (&gfc_current_ns->sym_root, "ppr@");
+ st2->n.sym = stree->n.sym;
+ }
+ sym->result = stree->n.sym;
+
+ sym->result->attr.proc_pointer = sym->attr.proc_pointer;
+ sym->result->attr.pointer = sym->attr.pointer;
+ sym->result->attr.external = sym->attr.external;
+ sym->result->attr.referenced = sym->attr.referenced;
+ sym->attr.proc_pointer = 0;
+ sym->attr.pointer = 0;
+ sym->attr.external = 0;
+ if (sym->result->attr.external && sym->result->attr.pointer)
+ {
+ sym->result->attr.pointer = 0;
+ sym->result->attr.proc_pointer = 1;
+ }
+
+ return gfc_add_result (&sym->result->attr, sym->result->name, NULL);
+ }
+ /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
+ else if (sym->attr.function && !sym->attr.external && sym->attr.pointer
+ && sym->result && sym->result != sym && sym->result->attr.external
+ && sym == gfc_current_ns->proc_name
+ && sym == sym->result->ns->proc_name
+ && strcmp ("ppr@", sym->result->name) == 0)
+ {
+ sym->result->attr.proc_pointer = 1;
+ sym->attr.pointer = 0;
+ return SUCCESS;
+ }
+ else
+ return FAILURE;
+}
+
+
/* Match a PROCEDURE declaration (R1211). */
static match
locus old_loc, entry_loc;
gfc_symbol *sym, *proc_if = NULL;
int num;
+ gfc_expr *initializer = NULL;
old_loc = entry_loc = gfc_current_locus;
/* Get the type spec. for the procedure interface. */
old_loc = gfc_current_locus;
m = gfc_match_type_spec (¤t_ts, 0);
- if (m == MATCH_YES || (m == MATCH_NO && gfc_peek_char () == ')'))
+ gfc_gobble_whitespace ();
+ if (m == MATCH_YES || (m == MATCH_NO && gfc_peek_ascii_char () == ')'))
goto got_ts;
if (m == MATCH_ERROR)
/* 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. */
- while (proc_if->interface)
- proc_if = proc_if->interface;
+ while (proc_if->ts.interface)
+ proc_if = proc_if->ts.interface;
if (proc_if->generic)
{
return MATCH_ERROR;
}
/* Handle intrinsic procedures. */
- if (gfc_intrinsic_name (proc_if->name, 0)
- || gfc_intrinsic_name (proc_if->name, 1))
+ 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))
return MATCH_ERROR;
}
- if (!sym->attr.pointer && gfc_add_external (&sym->attr, NULL) == FAILURE)
+ if (gfc_add_external (&sym->attr, NULL) == FAILURE)
return MATCH_ERROR;
+
+ if (add_hidden_procptr_result (sym) == SUCCESS)
+ sym = sym->result;
+
if (gfc_add_proc (&sym->attr, sym->name, NULL) == FAILURE)
return MATCH_ERROR;
/* Set interface. */
if (proc_if != NULL)
{
- sym->interface = proc_if;
+ if (sym->ts.type != BT_UNKNOWN)
+ {
+ gfc_error ("Procedure '%s' at %L already has basic type of %s",
+ sym->name, &gfc_current_locus,
+ gfc_basic_typename (sym->ts.type));
+ return MATCH_ERROR;
+ }
+ sym->ts.interface = proc_if;
sym->attr.untyped = 1;
+ sym->attr.if_source = IFSRC_IFBODY;
}
else if (current_ts.type != BT_UNKNOWN)
{
- sym->interface = gfc_new_symbol ("", gfc_current_ns);
- sym->interface->ts = current_ts;
- sym->interface->attr.function = 1;
- sym->ts = sym->interface->ts;
- sym->attr.function = sym->interface->attr.function;
+ if (gfc_add_type (sym, ¤t_ts, &gfc_current_locus) == FAILURE)
+ return MATCH_ERROR;
+ sym->ts.interface = gfc_new_symbol ("", gfc_current_ns);
+ sym->ts.interface->ts = current_ts;
+ sym->ts.interface->attr.function = 1;
+ sym->attr.function = sym->ts.interface->attr.function;
+ sym->attr.if_source = IFSRC_UNKNOWN;
+ }
+
+ if (gfc_match (" =>") == MATCH_YES)
+ {
+ if (!current_attr.pointer)
+ {
+ gfc_error ("Initialization at %C isn't for a pointer variable");
+ m = MATCH_ERROR;
+ 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;
+ }
+
+ if (m != MATCH_YES)
+ goto cleanup;
+
+ if (add_init_expr_to_sym (sym->name, &initializer, &gfc_current_locus)
+ != SUCCESS)
+ goto cleanup;
+
}
+ gfc_set_sym_referenced (sym);
+
if (gfc_match_eos () == MATCH_YES)
return MATCH_YES;
if (gfc_match_char (',') != MATCH_YES)
syntax:
gfc_error ("Syntax error in PROCEDURE statement at %C");
return MATCH_ERROR;
+
+cleanup:
+ /* Free stuff up and return. */
+ gfc_free_expr (initializer);
+ return m;
}
/* General matcher for PROCEDURE declarations. */
+static match match_procedure_in_type (void);
+
match
gfc_match_procedure (void)
{
m = match_procedure_in_interface ();
break;
case COMP_DERIVED:
- gfc_error ("Fortran 2003: Procedure components at %C are "
- "not yet implemented in gfortran");
+ gfc_error ("Fortran 2003: Procedure components at %C are not yet"
+ " implemented in gfortran");
return MATCH_ERROR;
+ case COMP_DERIVED_CONTAINS:
+ m = match_procedure_in_type ();
+ break;
default:
return MATCH_NO;
}
}
+/* Warn if a matched procedure has the same name as an intrinsic; this is
+ simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
+ parser-state-stack to find out whether we're in a module. */
+
+static void
+warn_intrinsic_shadow (const gfc_symbol* sym, bool func)
+{
+ bool in_module;
+
+ in_module = (gfc_state_stack->previous
+ && gfc_state_stack->previous->state == COMP_MODULE);
+
+ gfc_warn_intrinsic_shadow (sym, in_module, func);
+}
+
+
/* Match a function declaration. */
match
old_loc = gfc_current_locus;
- m = match_prefix (¤t_ts);
+ m = gfc_match_prefix (¤t_ts);
if (m != MATCH_YES)
{
gfc_current_locus = old_loc;
}
if (get_proc_name (name, &sym, false))
return MATCH_ERROR;
+
+ if (add_hidden_procptr_result (sym) == SUCCESS)
+ sym = sym->result;
+
gfc_new_block = sym;
m = gfc_match_formal_arglist (sym, 0, 0);
goto cleanup;
}
+ /* Delay matching the function characteristics until after the
+ specification block by signalling kind=-1. */
+ sym->declared_at = old_loc;
+ if (current_ts.type != BT_UNKNOWN)
+ current_ts.kind = -1;
+ else
+ current_ts.kind = 0;
+
if (result == NULL)
{
sym->ts = current_ts;
sym->result = result;
}
+ /* Warn if this procedure has the same name as an intrinsic. */
+ warn_intrinsic_shadow (sym, true);
+
return MATCH_YES;
}
add_global_entry (const char *name, int sub)
{
gfc_gsymbol *s;
+ enum gfc_symbol_type type;
s = gfc_get_gsymbol(name);
+ type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
if (s->defined
|| (s->type != GSYM_UNKNOWN
- && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
+ && s->type != type))
gfc_global_used(s, NULL);
else
{
- s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
+ s->type = type;
s->where = gfc_current_locus;
s->defined = 1;
+ s->ns = gfc_current_ns;
return true;
}
return false;
created symbols attached to the current namespace. */
if (get_proc_name (name, &entry,
gfc_current_ns->parent != NULL
- && module_procedure
- && gfc_current_ns->proc_name->attr.function))
+ && module_procedure))
return MATCH_ERROR;
proc = gfc_current_block ();
/* Check what next non-whitespace character is so we can tell if there
is the required parens if we have a BIND(C). */
gfc_gobble_whitespace ();
- peek_char = gfc_peek_char ();
+ peek_char = gfc_peek_ascii_char ();
if (state == COMP_SUBROUTINE)
{
&& gfc_current_state () != COMP_CONTAINS)
return MATCH_NO;
- m = match_prefix (NULL);
+ m = gfc_match_prefix (NULL);
if (m != MATCH_YES)
return m;
if (get_proc_name (name, &sym, false))
return MATCH_ERROR;
+
+ if (add_hidden_procptr_result (sym) == SUCCESS)
+ sym = sym->result;
+
gfc_new_block = sym;
/* Check what next non-whitespace character is so we can tell if there
is the required parens if we have a BIND(C). */
gfc_gobble_whitespace ();
- peek_char = gfc_peek_char ();
+ peek_char = gfc_peek_ascii_char ();
if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
return MATCH_ERROR;
/* 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_GNU, "Extension: BIND(C) attribute at "
- "%L may not be specified for an internal procedure",
- &gfc_current_locus)
+ && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: BIND(C) attribute "
+ "at %L may not be specified for an internal "
+ "procedure", &gfc_current_locus)
== FAILURE)
return MATCH_ERROR;
if (copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
return MATCH_ERROR;
+ /* Warn if it has the same name as an intrinsic. */
+ warn_intrinsic_shadow (sym, false);
+
return MATCH_YES;
}
static int
contained_procedure (void)
{
- gfc_state_data *s;
+ gfc_state_data *s = gfc_state_stack;
- for (s=gfc_state_stack; s; s=s->previous)
- if ((s->state == COMP_SUBROUTINE || s->state == COMP_FUNCTION)
- && s->previous != NULL && s->previous->state == COMP_CONTAINS)
- return 1;
+ if ((s->state == COMP_SUBROUTINE || s->state == COMP_FUNCTION)
+ && s->previous != NULL && s->previous->state == COMP_CONTAINS)
+ return 1;
return 0;
}
block_name = gfc_current_block () == NULL
? NULL : gfc_current_block ()->name;
- if (state == COMP_CONTAINS)
+ if (state == COMP_CONTAINS || state == COMP_DERIVED_CONTAINS)
{
state = gfc_state_stack->previous->state;
block_name = gfc_state_stack->previous->sym == NULL
break;
case COMP_DERIVED:
+ case COMP_DERIVED_CONTAINS:
*st = ST_END_TYPE;
target = " type";
eos_ok = 0;
if (block_name == NULL)
goto syntax;
- if (strcmp (name, block_name) != 0)
+ if (strcmp (name, block_name) != 0 && strcmp (block_name, "ppr@") != 0)
{
gfc_error ("Expected label '%s' for %s statement at %C", block_name,
gfc_ascii_statement (*st));
goto cleanup;
}
+ /* Procedure pointer as function result. */
+ else if (strcmp (block_name, "ppr@") == 0
+ && strcmp (name, gfc_current_block ()->ns->proc_name->name) != 0)
+ {
+ gfc_error ("Expected label '%s' for %s statement at %C",
+ gfc_current_block ()->ns->proc_name->name,
+ gfc_ascii_statement (*st));
+ goto cleanup;
+ }
if (gfc_match_eos () == MATCH_YES)
return MATCH_YES;
goto cleanup;
}
+ if (current_attr.dimension && sym->value)
+ {
+ gfc_error ("Dimensions specified for %s at %L after its "
+ "initialisation", sym->name, &var_locus);
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+
if ((current_attr.allocatable || current_attr.pointer)
&& (m == MATCH_YES) && (as->type != AS_DEFERRED))
{
/* Update symbol table. DIMENSION attribute is set
in gfc_set_array_spec(). */
if (current_attr.dimension == 0
- && gfc_copy_attr (&sym->attr, ¤t_attr, NULL) == FAILURE)
+ && gfc_copy_attr (&sym->attr, ¤t_attr, &var_locus) == FAILURE)
{
m = MATCH_ERROR;
goto cleanup;
goto cleanup;
}
+ add_hidden_procptr_result (sym);
+
return MATCH_YES;
cleanup:
gfc_match_pointer (void)
{
gfc_gobble_whitespace ();
- if (gfc_peek_char () == '(')
+ if (gfc_peek_ascii_char () == '(')
{
if (!gfc_option.flag_cray_pointer)
{
interface_type type;
gfc_user_op *uop;
gfc_symbol *sym;
- gfc_intrinsic_op operator;
+ gfc_intrinsic_op op;
match m;
if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
for (;;)
{
- m = gfc_match_generic_spec (&type, name, &operator);
+ m = gfc_match_generic_spec (&type, name, &op);
if (m == MATCH_NO)
goto syntax;
if (m == MATCH_ERROR)
break;
case INTERFACE_INTRINSIC_OP:
- if (gfc_current_ns->operator_access[operator] == ACCESS_UNKNOWN)
+ if (gfc_current_ns->operator_access[op] == ACCESS_UNKNOWN)
{
- gfc_current_ns->operator_access[operator] =
+ gfc_current_ns->operator_access[op] =
(st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
}
else
{
gfc_error ("Access specification of the %s operator at %C has "
- "already been specified", gfc_op2string (operator));
+ "already been specified", gfc_op2string (op));
goto done;
}
/* The PRIVATE statement is a bit weird in that it can be an attribute
- declaration, but also works as a standlone statement inside of a
+ declaration, but also works as a standalone statement inside of a
type declaration or a module. */
match
return MATCH_NO;
if (gfc_current_state () != COMP_MODULE
- && (gfc_current_state () != COMP_DERIVED
- || !gfc_state_stack->previous
- || gfc_state_stack->previous->state != COMP_MODULE))
+ && !(gfc_current_state () == COMP_DERIVED
+ && gfc_state_stack->previous
+ && gfc_state_stack->previous->state == COMP_MODULE)
+ && !(gfc_current_state () == COMP_DERIVED_CONTAINS
+ && gfc_state_stack->previous && gfc_state_stack->previous->previous
+ && gfc_state_stack->previous->previous->state == COMP_MODULE))
{
gfc_error ("PRIVATE statement at %C is only allowed in the "
"specification part of a module");
goto cleanup;
}
+ if (sym->value)
+ {
+ gfc_error ("Initializing already initialized variable at %C");
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+
if (sym->ts.type == BT_CHARACTER
&& sym->ts.cl != NULL
&& sym->ts.cl->length != NULL
&& sym->ts.cl->length->expr_type == EXPR_CONSTANT
&& init->expr_type == EXPR_CONSTANT
- && init->ts.type == BT_CHARACTER
- && init->ts.kind == 1)
+ && init->ts.type == BT_CHARACTER)
gfc_set_constant_character_len (
- mpz_get_si (sym->ts.cl->length->value.integer), init, false);
+ mpz_get_si (sym->ts.cl->length->value.integer), init, -1);
+ else if (sym->ts.type == BT_CHARACTER && sym->ts.cl != NULL
+ && sym->ts.cl->length == NULL)
+ {
+ int clen;
+ if (init->expr_type == EXPR_CONSTANT)
+ {
+ clen = init->value.character.length;
+ sym->ts.cl->length = gfc_int_expr (clen);
+ }
+ else if (init->expr_type == EXPR_ARRAY)
+ {
+ gfc_expr *p = init->value.constructor->expr;
+ clen = p->value.character.length;
+ sym->ts.cl->length = gfc_int_expr (clen);
+ }
+ else if (init->ts.cl && init->ts.cl->length)
+ sym->ts.cl->length = gfc_copy_expr (sym->value->ts.cl->length);
+ }
sym->value = init;
return MATCH_YES;
}
+/* Check a derived type that is being extended. */
+static gfc_symbol*
+check_extended_derived_type (char *name)
+{
+ gfc_symbol *extended;
+
+ if (gfc_find_symbol (name, gfc_current_ns, 1, &extended))
+ {
+ gfc_error ("Ambiguous symbol in TYPE definition at %C");
+ return NULL;
+ }
+
+ if (!extended)
+ {
+ gfc_error ("No such symbol in TYPE definition at %C");
+ return NULL;
+ }
+
+ if (extended->attr.flavor != FL_DERIVED)
+ {
+ gfc_error ("'%s' 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 "
+ "is BIND(C)", extended->name);
+ return NULL;
+ }
+
+ if (extended->attr.sequence)
+ {
+ gfc_error ("'%s' cannot be extended at %C because it "
+ "is a SEQUENCE type", extended->name);
+ return NULL;
+ }
+
+ return extended;
+}
+
+
/* Match the optional attribute specifiers for a type declaration.
Return MATCH_ERROR if an error is encountered in one of the handled
attributes (public, private, bind(c)), MATCH_NO if what's found is
checking on attribute conflicts needs to be done. */
match
-gfc_get_type_attr_spec (symbol_attribute *attr)
+gfc_get_type_attr_spec (symbol_attribute *attr, char *name)
{
/* See if the derived type is marked as private. */
if (gfc_match (" , private") == MATCH_YES)
if (gfc_add_access (attr, ACCESS_PUBLIC, NULL, NULL) == FAILURE)
return MATCH_ERROR;
}
- else if (gfc_match(" , bind ( c )") == MATCH_YES)
+ else if (gfc_match (" , bind ( c )") == MATCH_YES)
{
/* If the type is defined to be bind(c) it then needs to make
sure that all fields are interoperable. This will
/* 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)
+ return MATCH_ERROR;
+
+ if (gfc_add_abstract (attr, &gfc_current_locus) == FAILURE)
+ return MATCH_ERROR;
+ }
+ else if (name && gfc_match(" , extends ( %n )", name) == MATCH_YES)
+ {
+ if (gfc_add_extension (attr, &gfc_current_locus) == FAILURE)
+ return MATCH_ERROR;
+ }
else
return MATCH_NO;
gfc_match_derived_decl (void)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
+ char parent[GFC_MAX_SYMBOL_LEN + 1];
symbol_attribute attr;
gfc_symbol *sym;
+ gfc_symbol *extended;
match m;
match is_type_attr_spec = MATCH_NO;
bool seen_attr = false;
if (gfc_current_state () == COMP_DERIVED)
return MATCH_NO;
+ name[0] = '\0';
+ parent[0] = '\0';
gfc_clear_attr (&attr);
+ extended = NULL;
do
{
- is_type_attr_spec = gfc_get_type_attr_spec (&attr);
+ is_type_attr_spec = gfc_get_type_attr_spec (&attr, parent);
if (is_type_attr_spec == MATCH_ERROR)
return MATCH_ERROR;
if (is_type_attr_spec == MATCH_YES)
seen_attr = true;
} while (is_type_attr_spec == MATCH_YES);
+ /* Deal with derived type extensions. The extension attribute has
+ been added to 'attr' but now the parent type must be found and
+ checked. */
+ if (parent[0])
+ extended = check_extended_derived_type (parent);
+
+ if (parent[0] && !extended)
+ return MATCH_ERROR;
+
if (gfc_match (" ::") != MATCH_YES && seen_attr)
{
gfc_error ("Expected :: in TYPE definition at %C");
components. The ways this can happen is via a function
definition, an INTRINSIC statement or a subtype in another
derived type that is a pointer. The first part of the AND clause
- is true if a the symbol is not the return value of a function. */
+ is true if 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)
return MATCH_ERROR;
if (attr.is_bind_c != 0)
sym->attr.is_bind_c = attr.is_bind_c;
+ /* 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);
+ sym->attr.extension = attr.extension;
+ extended->refs++;
+ gfc_set_sym_referenced (extended);
+
+ p->ts.type = BT_DERIVED;
+ p->ts.derived = extended;
+ p->initializer = gfc_default_initializer (&p->ts);
+
+ /* 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;
+ }
+
+ /* Take over the ABSTRACT attribute. */
+ sym->attr.abstract = attr.abstract;
+
gfc_new_block = sym;
return MATCH_YES;
is the case. Since there is no bounds-checking for Cray Pointees,
this will be okay. */
-try
+match
gfc_mod_pointee_as (gfc_array_spec *as)
{
as->cray_pointee = true; /* This will be useful to know later. */
gfc_symbol *sym;
locus var_locus;
match m;
- try t;
+ gfc_try t;
locus old_locus;
initializer = NULL;
gfc_match_enumerator_def (void)
{
match m;
- try t;
+ gfc_try t;
gfc_clear_ts (¤t_ts);
}
+
+/* Match binding attributes. */
+
+static match
+match_binding_attributes (gfc_typebound_proc* ba, bool generic)
+{
+ bool found_passing = false;
+ match m;
+
+ /* Intialize to defaults. Do so even before the MATCH_NO check so that in
+ this case the defaults are in there. */
+ ba->access = ACCESS_UNKNOWN;
+ ba->pass_arg = NULL;
+ ba->pass_arg_num = 0;
+ ba->nopass = 0;
+ ba->non_overridable = 0;
+ ba->deferred = 0;
+
+ /* If we find a comma, we believe there are binding attributes. */
+ if (gfc_match_char (',') == MATCH_NO)
+ {
+ ba->access = gfc_typebound_default_access;
+ return MATCH_NO;
+ }
+
+ do
+ {
+ /* Access specifier. */
+
+ m = gfc_match (" public");
+ if (m == MATCH_ERROR)
+ goto error;
+ if (m == MATCH_YES)
+ {
+ if (ba->access != ACCESS_UNKNOWN)
+ {
+ gfc_error ("Duplicate access-specifier at %C");
+ goto error;
+ }
+
+ ba->access = ACCESS_PUBLIC;
+ continue;
+ }
+
+ m = gfc_match (" private");
+ if (m == MATCH_ERROR)
+ goto error;
+ if (m == MATCH_YES)
+ {
+ if (ba->access != ACCESS_UNKNOWN)
+ {
+ gfc_error ("Duplicate access-specifier at %C");
+ goto error;
+ }
+
+ ba->access = ACCESS_PRIVATE;
+ continue;
+ }
+
+ /* If inside GENERIC, the following is not allowed. */
+ if (!generic)
+ {
+
+ /* NOPASS flag. */
+ m = gfc_match (" nopass");
+ if (m == MATCH_ERROR)
+ goto error;
+ if (m == MATCH_YES)
+ {
+ if (found_passing)
+ {
+ gfc_error ("Binding attributes already specify passing,"
+ " illegal NOPASS at %C");
+ goto error;
+ }
+
+ found_passing = true;
+ ba->nopass = 1;
+ continue;
+ }
+
+ /* NON_OVERRIDABLE flag. */
+ m = gfc_match (" non_overridable");
+ if (m == MATCH_ERROR)
+ goto error;
+ if (m == MATCH_YES)
+ {
+ if (ba->non_overridable)
+ {
+ gfc_error ("Duplicate NON_OVERRIDABLE at %C");
+ goto error;
+ }
+
+ ba->non_overridable = 1;
+ continue;
+ }
+
+ /* DEFERRED flag. */
+ m = gfc_match (" deferred");
+ if (m == MATCH_ERROR)
+ goto error;
+ if (m == MATCH_YES)
+ {
+ if (ba->deferred)
+ {
+ gfc_error ("Duplicate DEFERRED at %C");
+ goto error;
+ }
+
+ ba->deferred = 1;
+ continue;
+ }
+
+ /* PASS possibly including argument. */
+ m = gfc_match (" pass");
+ if (m == MATCH_ERROR)
+ goto error;
+ if (m == MATCH_YES)
+ {
+ char arg[GFC_MAX_SYMBOL_LEN + 1];
+
+ if (found_passing)
+ {
+ gfc_error ("Binding attributes already specify passing,"
+ " illegal PASS at %C");
+ goto error;
+ }
+
+ m = gfc_match (" ( %n )", arg);
+ if (m == MATCH_ERROR)
+ goto error;
+ if (m == MATCH_YES)
+ ba->pass_arg = xstrdup (arg);
+ gcc_assert ((m == MATCH_YES) == (ba->pass_arg != NULL));
+
+ found_passing = true;
+ ba->nopass = 0;
+ continue;
+ }
+
+ }
+
+ /* Nothing matching found. */
+ if (generic)
+ gfc_error ("Expected access-specifier at %C");
+ else
+ gfc_error ("Expected binding attribute at %C");
+ goto error;
+ }
+ while (gfc_match_char (',') == MATCH_YES);
+
+ /* NON_OVERRIDABLE and DEFERRED exclude themselves. */
+ if (ba->non_overridable && ba->deferred)
+ {
+ gfc_error ("NON_OVERRIDABLE and DEFERRED can't both appear at %C");
+ goto error;
+ }
+
+ if (ba->access == ACCESS_UNKNOWN)
+ ba->access = gfc_typebound_default_access;
+
+ return MATCH_YES;
+
+error:
+ gfc_free (ba->pass_arg);
+ return MATCH_ERROR;
+}
+
+
+/* Match a PROCEDURE specific binding inside a derived type. */
+
+static match
+match_procedure_in_type (void)
+{
+ char name[GFC_MAX_SYMBOL_LEN + 1];
+ char target_buf[GFC_MAX_SYMBOL_LEN + 1];
+ char* target = NULL;
+ gfc_typebound_proc* tb;
+ bool seen_colons;
+ bool seen_attrs;
+ match m;
+ gfc_symtree* stree;
+ gfc_namespace* ns;
+ gfc_symbol* block;
+
+ /* Check current state. */
+ gcc_assert (gfc_state_stack->state == COMP_DERIVED_CONTAINS);
+ block = gfc_state_stack->previous->sym;
+ gcc_assert (block);
+
+ /* Try to match PROCEDURE(interface). */
+ if (gfc_match (" (") == MATCH_YES)
+ {
+ m = gfc_match_name (target_buf);
+ if (m == MATCH_ERROR)
+ return m;
+ if (m != MATCH_YES)
+ {
+ gfc_error ("Interface-name expected after '(' at %C");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_match (" )") != MATCH_YES)
+ {
+ gfc_error ("')' expected at %C");
+ return MATCH_ERROR;
+ }
+
+ target = target_buf;
+ }
+
+ /* Construct the data structure. */
+ tb = gfc_get_typebound_proc ();
+ tb->where = gfc_current_locus;
+ tb->is_generic = 0;
+
+ /* Match binding attributes. */
+ m = match_binding_attributes (tb, false);
+ if (m == MATCH_ERROR)
+ return m;
+ seen_attrs = (m == MATCH_YES);
+
+ /* Check that attribute DEFERRED is given iff an interface is specified, which
+ means target != NULL. */
+ if (tb->deferred && !target)
+ {
+ gfc_error ("Interface must be specified for DEFERRED binding at %C");
+ return MATCH_ERROR;
+ }
+ if (target && !tb->deferred)
+ {
+ gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
+ return MATCH_ERROR;
+ }
+
+ /* Match the colons. */
+ m = gfc_match (" ::");
+ if (m == MATCH_ERROR)
+ return m;
+ seen_colons = (m == MATCH_YES);
+ if (seen_attrs && !seen_colons)
+ {
+ gfc_error ("Expected '::' after binding-attributes at %C");
+ return MATCH_ERROR;
+ }
+
+ /* Match the binding name. */
+ m = gfc_match_name (name);
+ if (m == MATCH_ERROR)
+ return m;
+ if (m == MATCH_NO)
+ {
+ gfc_error ("Expected binding name at %C");
+ return MATCH_ERROR;
+ }
+
+ /* Try to match the '=> target', if it's there. */
+ m = gfc_match (" =>");
+ if (m == MATCH_ERROR)
+ return m;
+ if (m == MATCH_YES)
+ {
+ if (tb->deferred)
+ {
+ 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"
+ " at %C");
+ return MATCH_ERROR;
+ }
+
+ m = gfc_match_name (target_buf);
+ if (m == MATCH_ERROR)
+ return m;
+ if (m == MATCH_NO)
+ {
+ gfc_error ("Expected binding target after '=>' at %C");
+ return MATCH_ERROR;
+ }
+ target = target_buf;
+ }
+
+ /* Now we should have the end. */
+ m = gfc_match_eos ();
+ if (m == MATCH_ERROR)
+ return m;
+ if (m == MATCH_NO)
+ {
+ gfc_error ("Junk after PROCEDURE declaration at %C");
+ return MATCH_ERROR;
+ }
+
+ /* If no target was found, it has the same name as the binding. */
+ if (!target)
+ target = name;
+
+ /* Get the namespace to insert the symbols into. */
+ ns = block->f2k_derived;
+ gcc_assert (ns);
+
+ /* 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 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 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's already a procedure with binding name '%s' for the"
+ " derived type '%s' at %C", name, block->name);
+ return MATCH_ERROR;
+ }
+
+ /* Insert it and set attributes. */
+
+ if (!stree)
+ {
+ stree = gfc_new_symtree (&ns->tb_sym_root, name);
+ gcc_assert (stree);
+ }
+ stree->n.tb = tb;
+
+ if (gfc_get_sym_tree (target, gfc_current_ns, &tb->u.specific))
+ return MATCH_ERROR;
+ gfc_set_sym_referenced (tb->u.specific->n.sym);
+
+ return MATCH_YES;
+}
+
+
+/* Match a GENERIC procedure binding inside a derived type. */
+
+match
+gfc_match_generic (void)
+{
+ char name[GFC_MAX_SYMBOL_LEN + 1];
+ gfc_symbol* block;
+ gfc_typebound_proc tbattr; /* Used for match_binding_attributes. */
+ gfc_typebound_proc* tb;
+ gfc_symtree* st;
+ gfc_namespace* ns;
+ match m;
+
+ /* Check current state. */
+ if (gfc_current_state () == COMP_DERIVED)
+ {
+ gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
+ return MATCH_ERROR;
+ }
+ if (gfc_current_state () != COMP_DERIVED_CONTAINS)
+ return MATCH_NO;
+ block = gfc_state_stack->previous->sym;
+ ns = block->f2k_derived;
+ gcc_assert (block && ns);
+
+ /* See if we get an access-specifier. */
+ m = match_binding_attributes (&tbattr, true);
+ if (m == MATCH_ERROR)
+ goto error;
+
+ /* Now the colons, those are required. */
+ if (gfc_match (" ::") != MATCH_YES)
+ {
+ gfc_error ("Expected '::' at %C");
+ goto error;
+ }
+
+ /* The binding name and =>. */
+ m = gfc_match (" %n =>", name);
+ if (m == MATCH_ERROR)
+ return MATCH_ERROR;
+ if (m == MATCH_NO)
+ {
+ gfc_error ("Expected generic name at %C");
+ goto error;
+ }
+
+ /* If there's already something with this name, check that it is another
+ GENERIC and then extend that rather than build a new node. */
+ st = gfc_find_symtree (ns->tb_sym_root, name);
+ if (st)
+ {
+ gcc_assert (st->n.tb);
+ tb = st->n.tb;
+
+ if (!tb->is_generic)
+ {
+ gfc_error ("There's already a non-generic procedure with binding name"
+ " '%s' for the derived type '%s' at %C",
+ 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'", name);
+ goto error;
+ }
+ }
+ else
+ {
+ st = gfc_new_symtree (&ns->tb_sym_root, name);
+ gcc_assert (st);
+
+ st->n.tb = tb = gfc_get_typebound_proc ();
+ tb->where = gfc_current_locus;
+ tb->access = tbattr.access;
+ tb->is_generic = 1;
+ tb->u.generic = NULL;
+ }
+
+ /* Now, match all following names as specific targets. */
+ do
+ {
+ gfc_symtree* target_st;
+ gfc_tbp_generic* target;
+
+ m = gfc_match_name (name);
+ if (m == MATCH_ERROR)
+ goto error;
+ if (m == MATCH_NO)
+ {
+ gfc_error ("Expected specific binding name at %C");
+ goto error;
+ }
+
+ target_st = gfc_get_tbp_symtree (&ns->tb_sym_root, name);
+
+ /* See if this is a duplicate specification. */
+ 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, st->name);
+ goto error;
+ }
+
+ target = gfc_get_tbp_generic ();
+ target->specific_st = target_st;
+ target->specific = NULL;
+ target->next = tb->u.generic;
+ tb->u.generic = target;
+ }
+ while (gfc_match (" ,") == MATCH_YES);
+
+ /* Here should be the end. */
+ if (gfc_match_eos () != MATCH_YES)
+ {
+ gfc_error ("Junk after GENERIC binding at %C");
+ goto error;
+ }
+
+ return MATCH_YES;
+
+error:
+ return MATCH_ERROR;
+}
+
+
+/* Match a FINAL declaration inside a derived type. */
+
+match
+gfc_match_final_decl (void)
+{
+ char name[GFC_MAX_SYMBOL_LEN + 1];
+ gfc_symbol* sym;
+ match m;
+ gfc_namespace* module_ns;
+ bool first, last;
+ gfc_symbol* block;
+
+ if (gfc_state_stack->state != COMP_DERIVED_CONTAINS)
+ {
+ gfc_error ("FINAL declaration at %C must be inside a derived type "
+ "CONTAINS section");
+ return MATCH_ERROR;
+ }
+
+ block = gfc_state_stack->previous->sym;
+ gcc_assert (block);
+
+ if (!gfc_state_stack->previous || !gfc_state_stack->previous->previous
+ || gfc_state_stack->previous->previous->state != COMP_MODULE)
+ {
+ gfc_error ("Derived type declaration with FINAL at %C must be in the"
+ " specification part of a MODULE");
+ return MATCH_ERROR;
+ }
+
+ module_ns = gfc_current_ns;
+ gcc_assert (module_ns);
+ gcc_assert (module_ns->proc_name->attr.flavor == FL_MODULE);
+
+ /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
+ if (gfc_match (" ::") == MATCH_ERROR)
+ return MATCH_ERROR;
+
+ /* Match the sequence of procedure names. */
+ first = true;
+ last = false;
+ do
+ {
+ gfc_finalizer* f;
+
+ if (first && gfc_match_eos () == MATCH_YES)
+ {
+ gfc_error ("Empty FINAL at %C");
+ return MATCH_ERROR;
+ }
+
+ m = gfc_match_name (name);
+ if (m == MATCH_NO)
+ {
+ gfc_error ("Expected module procedure name at %C");
+ return MATCH_ERROR;
+ }
+ else if (m != MATCH_YES)
+ return MATCH_ERROR;
+
+ if (gfc_match_eos () == MATCH_YES)
+ last = true;
+ if (!last && gfc_match_char (',') != MATCH_YES)
+ {
+ 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);
+ 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)
+ 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!",
+ name);
+ return MATCH_ERROR;
+ }
+
+ /* Add this symbol to the list of finalizers. */
+ gcc_assert (block->f2k_derived);
+ ++sym->refs;
+ f = XCNEW (gfc_finalizer);
+ f->proc_sym = sym;
+ f->proc_tree = NULL;
+ f->where = gfc_current_locus;
+ f->next = block->f2k_derived->finalizers;
+ block->f2k_derived->finalizers = f;
+
+ first = false;
+ }
+ while (!last);
+
+ return MATCH_YES;
+}
OSDN Git Service
