/* Primary expression subroutines
- Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007
+ Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009, 2010
Free Software Foundation, Inc.
Contributed by Andy Vaught
#include "arith.h"
#include "match.h"
#include "parse.h"
+#include "constructor.h"
/* Matches a kind-parameter expression, which is either a named
symbolic constant or a nonnegative integer constant. If
if (sym->attr.flavor != FL_PARAMETER)
return MATCH_NO;
+ if (sym->value == NULL)
+ return MATCH_NO;
+
p = gfc_extract_int (sym->value, kind);
if (p != NULL)
return MATCH_NO;
+ gfc_set_sym_referenced (sym);
+
if (*kind < 0)
return MATCH_NO;
/* Given a character and a radix, see if the character is a valid
digit in that radix. */
-static int
-check_digit (int c, int radix)
+int
+gfc_check_digit (char c, int radix)
{
int r;
break;
default:
- gfc_internal_error ("check_digit(): bad radix");
+ gfc_internal_error ("gfc_check_digit(): bad radix");
}
return r;
match_digits (int signflag, int radix, char *buffer)
{
locus old_loc;
- int length, c;
+ int length;
+ char c;
length = 0;
- c = gfc_next_char ();
+ c = gfc_next_ascii_char ();
if (signflag && (c == '+' || c == '-'))
{
if (buffer != NULL)
*buffer++ = c;
gfc_gobble_whitespace ();
- c = gfc_next_char ();
+ c = gfc_next_ascii_char ();
length++;
}
- if (!check_digit (c, radix))
+ if (!gfc_check_digit (c, radix))
return -1;
length++;
for (;;)
{
old_loc = gfc_current_locus;
- c = gfc_next_char ();
+ c = gfc_next_ascii_char ();
- if (!check_digit (c, radix))
+ if (!gfc_check_digit (c, radix))
break;
if (buffer != NULL)
if (length == -1)
return MATCH_NO;
- buffer = alloca (length + 1);
+ buffer = (char *) alloca (length + 1);
memset (buffer, '\0', length + 1);
gfc_gobble_whitespace ();
locus old_loc;
gfc_expr *e = NULL;
const char *msg;
- int num;
+ int num, pad;
int i;
old_loc = gfc_current_locus;
else
{
gfc_free_expr (e);
- e = gfc_constant_result (BT_HOLLERITH, gfc_default_character_kind,
- &gfc_current_locus);
+ e = gfc_get_constant_expr (BT_HOLLERITH, gfc_default_character_kind,
+ &gfc_current_locus);
+
+ /* Calculate padding needed to fit default integer memory. */
+ pad = gfc_default_integer_kind - (num % gfc_default_integer_kind);
+
+ e->representation.string = XCNEWVEC (char, num + pad + 1);
- e->representation.string = gfc_getmem (num + 1);
for (i = 0; i < num; i++)
{
- e->representation.string[i] = gfc_next_char_literal (1);
+ gfc_char_t c = gfc_next_char_literal (1);
+ if (! gfc_wide_fits_in_byte (c))
+ {
+ gfc_error ("Invalid Hollerith constant at %L contains a "
+ "wide character", &old_loc);
+ goto cleanup;
+ }
+
+ e->representation.string[i] = (unsigned char) c;
}
- e->representation.string[num] = '\0';
- e->representation.length = num;
+
+ /* Now pad with blanks and end with a null char. */
+ for (i = 0; i < pad; i++)
+ e->representation.string[num + i] = ' ';
+
+ e->representation.string[num + i] = '\0';
+ e->representation.length = num + pad;
+ e->ts.u.pad = pad;
*result = e;
return MATCH_YES;
static match
match_boz_constant (gfc_expr **result)
{
- int post, radix, delim, length, x_hex, kind;
+ int radix, length, x_hex, kind;
locus old_loc, start_loc;
- char *buffer;
+ char *buffer, post, delim;
gfc_expr *e;
start_loc = old_loc = gfc_current_locus;
gfc_gobble_whitespace ();
x_hex = 0;
- switch (post = gfc_next_char ())
+ switch (post = gfc_next_ascii_char ())
{
case 'b':
radix = 2;
/* No whitespace allowed here. */
if (post == 0)
- delim = gfc_next_char ();
+ delim = gfc_next_ascii_char ();
if (delim != '\'' && delim != '\"')
goto backup;
return MATCH_ERROR;
}
- if (gfc_next_char () != delim)
+ if (gfc_next_ascii_char () != delim)
{
gfc_error ("Illegal character in BOZ constant at %C");
return MATCH_ERROR;
if (post == 1)
{
- switch (gfc_next_char ())
+ switch (gfc_next_ascii_char ())
{
case 'b':
radix = 2;
gfc_current_locus = old_loc;
- buffer = alloca (length + 1);
+ buffer = (char *) alloca (length + 1);
memset (buffer, '\0', length + 1);
match_digits (0, radix, buffer);
- gfc_next_char (); /* Eat delimiter. */
+ gfc_next_ascii_char (); /* Eat delimiter. */
if (post == 1)
- gfc_next_char (); /* Eat postfixed b, o, z, or x. */
+ gfc_next_ascii_char (); /* Eat postfixed b, o, z, or x. */
/* In section 5.2.5 and following C567 in the Fortran 2003 standard, we find
"If a data-stmt-constant is a boz-literal-constant, the corresponding
static match
match_real_constant (gfc_expr **result, int signflag)
{
- int kind, c, count, seen_dp, seen_digits, exp_char;
+ int kind, count, seen_dp, seen_digits;
locus old_loc, temp_loc;
- char *p, *buffer;
+ char *p, *buffer, c, exp_char;
gfc_expr *e;
bool negate;
exp_char = ' ';
negate = FALSE;
- c = gfc_next_char ();
+ c = gfc_next_ascii_char ();
if (signflag && (c == '+' || c == '-'))
{
if (c == '-')
negate = TRUE;
gfc_gobble_whitespace ();
- c = gfc_next_char ();
+ c = gfc_next_ascii_char ();
}
/* Scan significand. */
- for (;; c = gfc_next_char (), count++)
+ for (;; c = gfc_next_ascii_char (), count++)
{
if (c == '.')
{
/* Check to see if "." goes with a following operator like
".eq.". */
temp_loc = gfc_current_locus;
- c = gfc_next_char ();
+ c = gfc_next_ascii_char ();
if (c == 'e' || c == 'd' || c == 'q')
{
- c = gfc_next_char ();
+ c = gfc_next_ascii_char ();
if (c == '.')
goto done; /* Operator named .e. or .d. */
}
exp_char = c;
/* Scan exponent. */
- c = gfc_next_char ();
+ c = gfc_next_ascii_char ();
count++;
if (c == '+' || c == '-')
{ /* optional sign */
- c = gfc_next_char ();
+ c = gfc_next_ascii_char ();
count++;
}
while (ISDIGIT (c))
{
- c = gfc_next_char ();
+ c = gfc_next_ascii_char ();
count++;
}
gfc_current_locus = old_loc;
gfc_gobble_whitespace ();
- buffer = alloca (count + 1);
+ buffer = (char *) alloca (count + 1);
memset (buffer, '\0', count + 1);
p = buffer;
- c = gfc_next_char ();
+ c = gfc_next_ascii_char ();
if (c == '+' || c == '-')
{
gfc_gobble_whitespace ();
- c = gfc_next_char ();
+ c = gfc_next_ascii_char ();
}
/* Hack for mpfr_set_str(). */
if (--count == 0)
break;
- c = gfc_next_char ();
+ c = gfc_next_ascii_char ();
}
kind = get_kind ();
ref->type = REF_SUBSTRING;
if (start == NULL)
- start = gfc_int_expr (1);
+ start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
ref->u.ss.start = start;
if (end == NULL && cl)
end = gfc_copy_expr (cl->length);
return doubled delimiters on the input as a single instance of
the delimiter.
- Special return values are:
+ Special return values for "ret" argument are:
-1 End of the string, as determined by the delimiter
-2 Unterminated string detected
Backslash codes are also expanded at this time. */
-static int
-next_string_char (char delimiter)
+static gfc_char_t
+next_string_char (gfc_char_t delimiter, int *ret)
{
locus old_locus;
- int c;
+ gfc_char_t c;
c = gfc_next_char_literal (1);
+ *ret = 0;
if (c == '\n')
- return -2;
+ {
+ *ret = -2;
+ return 0;
+ }
if (gfc_option.flag_backslash && c == '\\')
{
return c;
gfc_current_locus = old_locus;
- return -1;
+ *ret = -1;
+ return 0;
}
int len;
gfc_gobble_whitespace ();
- c = gfc_next_char ();
+ c = gfc_next_ascii_char ();
if (!ISALPHA (c))
return MATCH_NO;
for (;;)
{
old_loc = gfc_current_locus;
- c = gfc_next_char ();
+ c = gfc_next_ascii_char ();
if (c == '_')
{
- peek = gfc_peek_char ();
+ peek = gfc_peek_ascii_char ();
if (peek == '\'' || peek == '\"')
{
if (!ISALNUM (c)
&& c != '_'
- && (gfc_option.flag_dollar_ok && c != '$'))
+ && (c != '$' || !gfc_option.flag_dollar_ok))
break;
*name++ = c;
static match
match_string_constant (gfc_expr **result)
{
- char *p, name[GFC_MAX_SYMBOL_LEN + 1];
- int i, c, kind, length, delimiter, warn_ampersand;
+ char name[GFC_MAX_SYMBOL_LEN + 1], peek;
+ int i, kind, length, warn_ampersand, ret;
locus old_locus, start_locus;
gfc_symbol *sym;
gfc_expr *e;
const char *q;
match m;
+ gfc_char_t c, delimiter, *p;
old_locus = gfc_current_locus;
gfc_gobble_whitespace ();
- start_locus = gfc_current_locus;
-
c = gfc_next_char ();
if (c == '\'' || c == '"')
{
kind = gfc_default_character_kind;
+ start_locus = gfc_current_locus;
goto got_delim;
}
- if (ISDIGIT (c))
+ if (gfc_wide_is_digit (c))
{
kind = 0;
- while (ISDIGIT (c))
+ while (gfc_wide_is_digit (c))
{
kind = kind * 10 + c - '0';
if (kind > 9999999)
goto no_match;
gfc_gobble_whitespace ();
- start_locus = gfc_current_locus;
c = gfc_next_char ();
if (c != '\'' && c != '"')
goto no_match;
+ start_locus = gfc_current_locus;
+
if (kind == -1)
{
q = gfc_extract_int (sym->value, &kind);
gfc_error (q);
return MATCH_ERROR;
}
+ gfc_set_sym_referenced (sym);
}
if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
for (;;)
{
- c = next_string_char (delimiter);
- if (c == -1)
+ c = next_string_char (delimiter, &ret);
+ if (ret == -1)
break;
- if (c == -2)
+ if (ret == -2)
{
gfc_current_locus = start_locus;
gfc_error ("Unterminated character constant beginning at %C");
/* Peek at the next character to see if it is a b, o, z, or x for the
postfixed BOZ literal constants. */
- c = gfc_peek_char ();
- if (c == 'b' || c == 'o' || c =='z' || c == 'x')
+ peek = gfc_peek_ascii_char ();
+ if (peek == 'b' || peek == 'o' || peek =='z' || peek == 'x')
goto no_match;
-
- e = gfc_get_expr ();
-
- e->expr_type = EXPR_CONSTANT;
+ e = gfc_get_character_expr (kind, &start_locus, NULL, length);
e->ref = NULL;
- e->ts.type = BT_CHARACTER;
- e->ts.kind = kind;
e->ts.is_c_interop = 0;
e->ts.is_iso_c = 0;
- e->where = start_locus;
-
- e->value.character.string = p = gfc_getmem (length + 1);
- e->value.character.length = length;
gfc_current_locus = start_locus;
- gfc_next_char (); /* Skip delimiter */
/* We disable the warning for the following loop as the warning has already
been printed in the loop above. */
warn_ampersand = gfc_option.warn_ampersand;
gfc_option.warn_ampersand = 0;
+ p = e->value.character.string;
for (i = 0; i < length; i++)
- *p++ = next_string_char (delimiter);
+ {
+ c = next_string_char (delimiter, &ret);
+
+ if (!gfc_check_character_range (c, kind))
+ {
+ gfc_error ("Character '%s' in string at %C is not representable "
+ "in character kind %d", gfc_print_wide_char (c), kind);
+ return MATCH_ERROR;
+ }
+
+ *p++ = c;
+ }
*p = '\0'; /* TODO: C-style string is for development/debug purposes. */
gfc_option.warn_ampersand = warn_ampersand;
- if (next_string_char (delimiter) != -1)
+ next_string_char (delimiter, &ret);
+ if (ret != -1)
gfc_internal_error ("match_string_constant(): Delimiter not found");
if (match_substring (NULL, 0, &e->ref) != MATCH_NO)
locus orig_loc = gfc_current_locus;
gfc_gobble_whitespace ();
- if (gfc_next_char () == '.')
+ if (gfc_next_ascii_char () == '.')
{
- int ch = gfc_next_char();
+ char ch = gfc_next_ascii_char ();
if (ch == 'f')
{
- if (gfc_next_char () == 'a'
- && gfc_next_char () == 'l'
- && gfc_next_char () == 's'
- && gfc_next_char () == 'e'
- && gfc_next_char () == '.')
+ if (gfc_next_ascii_char () == 'a'
+ && gfc_next_ascii_char () == 'l'
+ && gfc_next_ascii_char () == 's'
+ && gfc_next_ascii_char () == 'e'
+ && gfc_next_ascii_char () == '.')
/* Matched ".false.". */
return 0;
}
else if (ch == 't')
{
- if (gfc_next_char () == 'r'
- && gfc_next_char () == 'u'
- && gfc_next_char () == 'e'
- && gfc_next_char () == '.')
+ if (gfc_next_ascii_char () == 'r'
+ && gfc_next_ascii_char () == 'u'
+ && gfc_next_ascii_char () == 'e'
+ && gfc_next_ascii_char () == '.')
/* Matched ".true.". */
return 1;
}
return MATCH_ERROR;
}
- e = gfc_get_expr ();
-
- e->expr_type = EXPR_CONSTANT;
- e->value.logical = i;
- e->ts.type = BT_LOGICAL;
- e->ts.kind = kind;
+ e = gfc_get_logical_expr (kind, &gfc_current_locus, i);
e->ts.is_c_interop = 0;
e->ts.is_iso_c = 0;
- e->where = gfc_current_locus;
*result = e;
return MATCH_YES;
{
/* Give the matcher for implied do-loops a chance to run. This
yields a much saner error message for (/ (i, 4=i, 6) /). */
- if (gfc_peek_char () == '=')
+ if (gfc_peek_ascii_char () == '=')
{
m = MATCH_ERROR;
goto cleanup;
}
+/* This checks if a symbol is the return value of an encompassing function.
+ Function nesting can be maximally two levels deep, but we may have
+ additional local namespaces like BLOCK etc. */
+
+bool
+gfc_is_function_return_value (gfc_symbol *sym, gfc_namespace *ns)
+{
+ if (!sym->attr.function || (sym->result != sym))
+ return false;
+ while (ns)
+ {
+ if (ns->proc_name == sym)
+ return true;
+ ns = ns->parent;
+ }
+ return false;
+}
+
+
/* Match a single actual argument value. An actual argument is
usually an expression, but can also be a procedure name. If the
argument is a single name, it is not always possible to tell
gfc_symtree *symtree;
locus where, w;
gfc_expr *e;
- int c;
+ char c;
+ gfc_gobble_whitespace ();
where = gfc_current_locus;
switch (gfc_match_name (name))
case MATCH_YES:
w = gfc_current_locus;
gfc_gobble_whitespace ();
- c = gfc_next_char ();
+ c = gfc_next_ascii_char ();
gfc_current_locus = w;
if (c != ',' && c != ')')
have a function argument. */
if (symtree == NULL)
{
- gfc_get_sym_tree (name, NULL, &symtree);
+ gfc_get_sym_tree (name, NULL, &symtree, false);
gfc_set_sym_referenced (symtree->n.sym);
}
else
&& sym->attr.flavor != FL_UNKNOWN)
break;
+ if (sym->attr.in_common && !sym->attr.proc_pointer)
+ {
+ gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name,
+ &sym->declared_at);
+ break;
+ }
+
/* If the symbol is a function with itself as the result and
is being defined, then we have a variable. */
if (sym->attr.function && sym->result == sym)
{
- if (gfc_current_ns->proc_name == sym
- || (gfc_current_ns->parent != NULL
- && gfc_current_ns->parent->proc_name == sym))
+ if (gfc_is_function_return_value (sym, gfc_current_ns))
break;
if (sym->attr.entry
}
-/* Used by match_varspec() to extend the reference list by one
+/* Used by gfc_match_varspec() to extend the reference list by one
element. */
static gfc_ref *
/* Match any additional specifications associated with the current
variable like member references or substrings. If equiv_flag is
set we only match stuff that is allowed inside an EQUIVALENCE
- statement. */
+ statement. sub_flag tells whether we expect a type-bound procedure found
+ to be a subroutine as part of CALL or a FUNCTION. For procedure pointer
+ components, 'ppc_arg' determines whether the PPC may be called (with an
+ argument list), or whether it may just be referred to as a pointer. */
-static match
-match_varspec (gfc_expr *primary, int equiv_flag)
+match
+gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
+ bool ppc_arg)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_ref *substring, *tail;
gfc_component *component;
gfc_symbol *sym = primary->symtree->n.sym;
match m;
+ bool unknown;
tail = NULL;
gfc_gobble_whitespace ();
- if ((equiv_flag && gfc_peek_char () == '(') || sym->attr.dimension)
+
+ if (gfc_peek_ascii_char () == '[')
+ {
+ if (sym->attr.dimension)
+ {
+ gfc_error ("Array section designator, e.g. '(:)', is required "
+ "besides the coarray designator '[...]' at %C");
+ return MATCH_ERROR;
+ }
+ if (!sym->attr.codimension)
+ {
+ gfc_error ("Coarray designator at %C but '%s' is not a coarray",
+ sym->name);
+ return MATCH_ERROR;
+ }
+ }
+
+ /* For associate names, we may not yet know whether they are arrays or not.
+ Thus if we have one and parentheses follow, we have to assume that it
+ actually is one for now. The final decision will be made at
+ resolution time, of course. */
+ if (sym->assoc && gfc_peek_ascii_char () == '(')
+ sym->attr.dimension = 1;
+
+ if ((equiv_flag && gfc_peek_ascii_char () == '(')
+ || gfc_peek_ascii_char () == '[' || sym->attr.codimension
+ || (sym->attr.dimension && !sym->attr.proc_pointer
+ && !gfc_is_proc_ptr_comp (primary, NULL)
+ && !(gfc_matching_procptr_assignment
+ && sym->attr.flavor == FL_PROCEDURE))
+ || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.dimension))
{
/* In EQUIVALENCE, we don't know yet whether we are seeing
an array, character variable or array of character
tail->type = REF_ARRAY;
m = gfc_match_array_ref (&tail->u.ar, equiv_flag ? NULL : sym->as,
- equiv_flag);
+ equiv_flag, sym->as ? sym->as->corank : 0);
if (m != MATCH_YES)
return m;
gfc_gobble_whitespace ();
- if (equiv_flag && gfc_peek_char () == '(')
+ if (equiv_flag && gfc_peek_ascii_char () == '(')
{
tail = extend_ref (primary, tail);
tail->type = REF_ARRAY;
- m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag);
+ m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag, 0);
if (m != MATCH_YES)
return m;
}
if (equiv_flag)
return MATCH_YES;
- if (sym->ts.type != BT_DERIVED || gfc_match_char ('%') != MATCH_YES)
+ if (sym->ts.type == BT_UNKNOWN && gfc_peek_ascii_char () == '%'
+ && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
+ gfc_set_default_type (sym, 0, sym->ns);
+
+ if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
+ || gfc_match_char ('%') != MATCH_YES)
goto check_substring;
- sym = sym->ts.derived;
+ sym = sym->ts.u.derived;
for (;;)
{
+ gfc_try t;
+ gfc_symtree *tbp;
+
m = gfc_match_name (name);
if (m == MATCH_NO)
gfc_error ("Expected structure component name at %C");
if (m != MATCH_YES)
return MATCH_ERROR;
- component = gfc_find_component (sym, name);
+ if (sym->f2k_derived)
+ tbp = gfc_find_typebound_proc (sym, &t, name, false, &gfc_current_locus);
+ else
+ tbp = NULL;
+
+ if (tbp)
+ {
+ gfc_symbol* tbp_sym;
+
+ if (t == FAILURE)
+ return MATCH_ERROR;
+
+ gcc_assert (!tail || !tail->next);
+ gcc_assert (primary->expr_type == EXPR_VARIABLE);
+
+ if (tbp->n.tb->is_generic)
+ tbp_sym = NULL;
+ else
+ tbp_sym = tbp->n.tb->u.specific->n.sym;
+
+ primary->expr_type = EXPR_COMPCALL;
+ primary->value.compcall.tbp = tbp->n.tb;
+ primary->value.compcall.name = tbp->name;
+ primary->value.compcall.ignore_pass = 0;
+ primary->value.compcall.assign = 0;
+ primary->value.compcall.base_object = NULL;
+ gcc_assert (primary->symtree->n.sym->attr.referenced);
+ if (tbp_sym)
+ primary->ts = tbp_sym->ts;
+
+ m = gfc_match_actual_arglist (tbp->n.tb->subroutine,
+ &primary->value.compcall.actual);
+ if (m == MATCH_ERROR)
+ return MATCH_ERROR;
+ if (m == MATCH_NO)
+ {
+ if (sub_flag)
+ primary->value.compcall.actual = NULL;
+ else
+ {
+ gfc_error ("Expected argument list at %C");
+ return MATCH_ERROR;
+ }
+ }
+
+ break;
+ }
+
+ component = gfc_find_component (sym, name, false, false);
if (component == NULL)
return MATCH_ERROR;
primary->ts = component->ts;
- if (component->as != NULL)
+ if (component->attr.proc_pointer && ppc_arg
+ && !gfc_matching_procptr_assignment)
+ {
+ m = gfc_match_actual_arglist (sub_flag,
+ &primary->value.compcall.actual);
+ if (m == MATCH_ERROR)
+ return MATCH_ERROR;
+ if (m == MATCH_YES)
+ primary->expr_type = EXPR_PPC;
+
+ break;
+ }
+
+ if (component->as != NULL && !component->attr.proc_pointer)
+ {
+ tail = extend_ref (primary, tail);
+ tail->type = REF_ARRAY;
+
+ m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag,
+ component->as->corank);
+ if (m != MATCH_YES)
+ return m;
+ }
+ else if (component->ts.type == BT_CLASS
+ && CLASS_DATA (component)->as != NULL
+ && !component->attr.proc_pointer)
{
tail = extend_ref (primary, tail);
tail->type = REF_ARRAY;
- m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag);
+ m = gfc_match_array_ref (&tail->u.ar, CLASS_DATA (component)->as,
+ equiv_flag,
+ CLASS_DATA (component)->as->corank);
if (m != MATCH_YES)
return m;
}
- if (component->ts.type != BT_DERIVED
+ if ((component->ts.type != BT_DERIVED && component->ts.type != BT_CLASS)
|| gfc_match_char ('%') != MATCH_YES)
break;
- sym = component->ts.derived;
+ sym = component->ts.u.derived;
}
check_substring:
- if (primary->ts.type == BT_UNKNOWN)
+ unknown = false;
+ if (primary->ts.type == BT_UNKNOWN && sym->attr.flavor != FL_DERIVED)
{
- if (gfc_get_default_type (sym, sym->ns)->type == BT_CHARACTER)
+ if (gfc_get_default_type (sym->name, sym->ns)->type == BT_CHARACTER)
{
gfc_set_default_type (sym, 0, sym->ns);
primary->ts = sym->ts;
+ unknown = true;
}
}
if (primary->ts.type == BT_CHARACTER)
{
- switch (match_substring (primary->ts.cl, equiv_flag, &substring))
+ switch (match_substring (primary->ts.u.cl, equiv_flag, &substring))
{
case MATCH_YES:
if (tail == NULL)
primary->expr_type = EXPR_SUBSTRING;
if (substring)
- primary->ts.cl = NULL;
+ primary->ts.u.cl = NULL;
break;
case MATCH_NO:
+ if (unknown)
+ {
+ gfc_clear_ts (&primary->ts);
+ gfc_clear_ts (&sym->ts);
+ }
break;
case MATCH_ERROR:
}
}
+ /* F2008, C727. */
+ if (primary->expr_type == EXPR_PPC && gfc_is_coindexed (primary))
+ {
+ gfc_error ("Coindexed procedure-pointer component at %C");
+ return MATCH_ERROR;
+ }
+
return MATCH_YES;
}
int dimension, pointer, allocatable, target;
symbol_attribute attr;
gfc_ref *ref;
+ gfc_symbol *sym;
+ gfc_component *comp;
- if (expr->expr_type != EXPR_VARIABLE)
+ if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION)
gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
- ref = expr->ref;
- attr = expr->symtree->n.sym->attr;
+ sym = expr->symtree->n.sym;
+ attr = sym->attr;
- dimension = attr.dimension;
- pointer = attr.pointer;
- allocatable = attr.allocatable;
+ if (sym->ts.type == BT_CLASS)
+ {
+ dimension = CLASS_DATA (sym)->attr.dimension;
+ pointer = CLASS_DATA (sym)->attr.class_pointer;
+ allocatable = CLASS_DATA (sym)->attr.allocatable;
+ }
+ else
+ {
+ dimension = attr.dimension;
+ pointer = attr.pointer;
+ allocatable = attr.allocatable;
+ }
target = attr.target;
- if (pointer)
+ if (pointer || attr.proc_pointer)
target = 1;
if (ts != NULL && expr->ts.type == BT_UNKNOWN)
- *ts = expr->symtree->n.sym->ts;
+ *ts = sym->ts;
- for (; ref; ref = ref->next)
+ for (ref = expr->ref; ref; ref = ref->next)
switch (ref->type)
{
case REF_ARRAY:
break;
case AR_ELEMENT:
- allocatable = pointer = 0;
+ /* Handle coarrays. */
+ if (ref->u.ar.dimen > 0)
+ allocatable = pointer = 0;
break;
case AR_UNKNOWN:
break;
case REF_COMPONENT:
- gfc_get_component_attr (&attr, ref->u.c.component);
+ comp = ref->u.c.component;
+ attr = comp->attr;
if (ts != NULL)
{
- *ts = ref->u.c.component->ts;
+ *ts = comp->ts;
/* Don't set the string length if a substring reference
follows. */
if (ts->type == BT_CHARACTER
&& ref->next && ref->next->type == REF_SUBSTRING)
- ts->cl = NULL;
+ ts->u.cl = NULL;
}
- pointer = ref->u.c.component->pointer;
- allocatable = ref->u.c.component->allocatable;
- if (pointer)
+ if (comp->ts.type == BT_CLASS)
+ {
+ pointer = CLASS_DATA (comp)->attr.class_pointer;
+ allocatable = CLASS_DATA (comp)->attr.allocatable;
+ }
+ else
+ {
+ pointer = comp->attr.pointer;
+ allocatable = comp->attr.allocatable;
+ }
+ if (pointer || attr.proc_pointer)
target = 1;
break;
attr.pointer = pointer;
attr.allocatable = allocatable;
attr.target = target;
+ attr.save = sym->attr.save;
return attr;
}
gfc_clear_attr (&attr);
if (e->value.function.esym != NULL)
- attr = e->value.function.esym->result->attr;
+ {
+ gfc_symbol *sym = e->value.function.esym->result;
+ attr = sym->attr;
+ if (sym->ts.type == BT_CLASS)
+ {
+ attr.dimension = CLASS_DATA (sym)->attr.dimension;
+ attr.pointer = CLASS_DATA (sym)->attr.class_pointer;
+ attr.allocatable = CLASS_DATA (sym)->attr.allocatable;
+ }
+ }
+ else
+ attr = gfc_variable_attr (e, NULL);
/* TODO: NULL() returns pointers. May have to take care of this
here. */
/* Match a structure constructor. The initial symbol has already been
seen. */
-match
-gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result)
+typedef struct gfc_structure_ctor_component
{
- gfc_constructor *head, *tail;
- gfc_component *comp;
- gfc_expr *e;
+ char* name;
+ gfc_expr* val;
locus where;
- match m;
- bool private_comp = false;
+ struct gfc_structure_ctor_component* next;
+}
+gfc_structure_ctor_component;
- head = tail = NULL;
+#define gfc_get_structure_ctor_component() XCNEW (gfc_structure_ctor_component)
- if (gfc_match_char ('(') != MATCH_YES)
- goto syntax;
+static void
+gfc_free_structure_ctor_component (gfc_structure_ctor_component *comp)
+{
+ gfc_free (comp->name);
+ gfc_free_expr (comp->val);
+}
- where = gfc_current_locus;
- gfc_find_component (sym, NULL);
+/* Translate the component list into the actual constructor by sorting it in
+ the order required; this also checks along the way that each and every
+ component actually has an initializer and handles default initializers
+ for components without explicit value given. */
+static gfc_try
+build_actual_constructor (gfc_structure_ctor_component **comp_head,
+ gfc_constructor_base *ctor_head, gfc_symbol *sym)
+{
+ gfc_structure_ctor_component *comp_iter;
+ gfc_component *comp;
for (comp = sym->components; comp; comp = comp->next)
{
- if (comp->access == ACCESS_PRIVATE)
+ gfc_structure_ctor_component **next_ptr;
+ gfc_expr *value = NULL;
+
+ /* Try to find the initializer for the current component by name. */
+ next_ptr = comp_head;
+ for (comp_iter = *comp_head; comp_iter; comp_iter = comp_iter->next)
{
- private_comp = true;
- break;
+ if (!strcmp (comp_iter->name, comp->name))
+ break;
+ next_ptr = &comp_iter->next;
+ }
+
+ /* If an extension, try building the parent derived type by building
+ a value expression for the parent derived type and calling self. */
+ if (!comp_iter && comp == sym->components && sym->attr.extension)
+ {
+ value = gfc_get_structure_constructor_expr (comp->ts.type,
+ comp->ts.kind,
+ &gfc_current_locus);
+ value->ts = comp->ts;
+
+ if (build_actual_constructor (comp_head, &value->value.constructor,
+ comp->ts.u.derived) == FAILURE)
+ {
+ gfc_free_expr (value);
+ return FAILURE;
+ }
+
+ gfc_constructor_append_expr (ctor_head, value, NULL);
+ continue;
+ }
+
+ /* If it was not found, try the default initializer if there's any;
+ otherwise, it's an error. */
+ if (!comp_iter)
+ {
+ if (comp->initializer)
+ {
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure"
+ " constructor with missing optional arguments"
+ " at %C") == FAILURE)
+ return FAILURE;
+ value = gfc_copy_expr (comp->initializer);
+ }
+ else
+ {
+ gfc_error ("No initializer for component '%s' given in the"
+ " structure constructor at %C!", comp->name);
+ return FAILURE;
+ }
}
- if (head == NULL)
- tail = head = gfc_get_constructor ();
else
+ value = comp_iter->val;
+
+ /* Add the value to the constructor chain built. */
+ gfc_constructor_append_expr (ctor_head, value, NULL);
+
+ /* Remove the entry from the component list. We don't want the expression
+ value to be free'd, so set it to NULL. */
+ if (comp_iter)
{
- tail->next = gfc_get_constructor ();
- tail = tail->next;
+ *next_ptr = comp_iter->next;
+ comp_iter->val = NULL;
+ gfc_free_structure_ctor_component (comp_iter);
}
+ }
+ return SUCCESS;
+}
- m = gfc_match_expr (&tail->expr);
- if (m == MATCH_NO)
- goto syntax;
- if (m == MATCH_ERROR)
- goto cleanup;
+match
+gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result,
+ bool parent)
+{
+ gfc_structure_ctor_component *comp_tail, *comp_head, *comp_iter;
+ gfc_constructor_base ctor_head = NULL;
+ gfc_component *comp; /* Is set NULL when named component is first seen */
+ gfc_expr *e;
+ locus where;
+ match m;
+ const char* last_name = NULL;
+
+ comp_tail = comp_head = NULL;
+
+ if (!parent && gfc_match_char ('(') != MATCH_YES)
+ goto syntax;
- if (gfc_match_char (',') == MATCH_YES)
+ where = gfc_current_locus;
+
+ gfc_find_component (sym, NULL, false, true);
+
+ /* Check that we're not about to construct an ABSTRACT type. */
+ if (!parent && sym->attr.abstract)
+ {
+ gfc_error ("Can't construct ABSTRACT type '%s' at %C", sym->name);
+ return MATCH_ERROR;
+ }
+
+ /* Match the component list and store it in a list together with the
+ corresponding component names. Check for empty argument list first. */
+ if (gfc_match_char (')') != MATCH_YES)
+ {
+ comp = sym->components;
+ do
{
- if (comp->next == NULL)
+ gfc_component *this_comp = NULL;
+
+ if (!comp_head)
+ comp_tail = comp_head = gfc_get_structure_ctor_component ();
+ else
+ {
+ comp_tail->next = gfc_get_structure_ctor_component ();
+ comp_tail = comp_tail->next;
+ }
+ comp_tail->name = XCNEWVEC (char, GFC_MAX_SYMBOL_LEN + 1);
+ comp_tail->val = NULL;
+ comp_tail->where = gfc_current_locus;
+
+ /* Try matching a component name. */
+ if (gfc_match_name (comp_tail->name) == MATCH_YES
+ && gfc_match_char ('=') == MATCH_YES)
+ {
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure"
+ " constructor with named arguments at %C")
+ == FAILURE)
+ goto cleanup;
+
+ last_name = comp_tail->name;
+ comp = NULL;
+ }
+ else
+ {
+ /* Components without name are not allowed after the first named
+ component initializer! */
+ if (!comp)
+ {
+ if (last_name)
+ gfc_error ("Component initializer without name after"
+ " component named %s at %C!", last_name);
+ else if (!parent)
+ gfc_error ("Too many components in structure constructor at"
+ " %C!");
+ goto cleanup;
+ }
+
+ gfc_current_locus = comp_tail->where;
+ strncpy (comp_tail->name, comp->name, GFC_MAX_SYMBOL_LEN + 1);
+ }
+
+ /* Find the current component in the structure definition and check
+ its access is not private. */
+ if (comp)
+ this_comp = gfc_find_component (sym, comp->name, false, false);
+ else
+ {
+ this_comp = gfc_find_component (sym,
+ (const char *)comp_tail->name,
+ false, false);
+ comp = NULL; /* Reset needed! */
+ }
+
+ /* Here we can check if a component name is given which does not
+ correspond to any component of the defined structure. */
+ if (!this_comp)
+ goto cleanup;
+
+ /* Check if this component is already given a value. */
+ for (comp_iter = comp_head; comp_iter != comp_tail;
+ comp_iter = comp_iter->next)
{
- gfc_error ("Too many components in structure constructor at %C");
+ gcc_assert (comp_iter);
+ if (!strcmp (comp_iter->name, comp_tail->name))
+ {
+ gfc_error ("Component '%s' is initialized twice in the"
+ " structure constructor at %C!", comp_tail->name);
+ goto cleanup;
+ }
+ }
+
+ /* Match the current initializer expression. */
+ m = gfc_match_expr (&comp_tail->val);
+ if (m == MATCH_NO)
+ goto syntax;
+ if (m == MATCH_ERROR)
+ goto cleanup;
+
+ /* F2008, R457/C725, for PURE C1283. */
+ if (this_comp->attr.pointer && gfc_is_coindexed (comp_tail->val))
+ {
+ gfc_error ("Coindexed expression to pointer component '%s' in "
+ "structure constructor at %C!", comp_tail->name);
goto cleanup;
+ }
+
+
+ /* If not explicitly a parent constructor, gather up the components
+ and build one. */
+ if (comp && comp == sym->components
+ && sym->attr.extension
+ && (comp_tail->val->ts.type != BT_DERIVED
+ ||
+ comp_tail->val->ts.u.derived != this_comp->ts.u.derived))
+ {
+ gfc_current_locus = where;
+ gfc_free_expr (comp_tail->val);
+ comp_tail->val = NULL;
+
+ m = gfc_match_structure_constructor (comp->ts.u.derived,
+ &comp_tail->val, true);
+ if (m == MATCH_NO)
+ goto syntax;
+ if (m == MATCH_ERROR)
+ goto cleanup;
}
- continue;
+ if (comp)
+ comp = comp->next;
+
+ if (parent && !comp)
+ break;
}
- break;
- }
+ while (gfc_match_char (',') == MATCH_YES);
- if (sym->attr.use_assoc
- && (sym->component_access == ACCESS_PRIVATE || private_comp))
- {
- gfc_error ("Structure constructor for '%s' at %C has PRIVATE "
- "components", sym->name);
- goto cleanup;
+ if (!parent && gfc_match_char (')') != MATCH_YES)
+ goto syntax;
}
- if (gfc_match_char (')') != MATCH_YES)
- goto syntax;
+ if (build_actual_constructor (&comp_head, &ctor_head, sym) == FAILURE)
+ goto cleanup;
- if (comp && comp->next != NULL)
+ /* No component should be left, as this should have caused an error in the
+ loop constructing the component-list (name that does not correspond to any
+ component in the structure definition). */
+ if (comp_head && sym->attr.extension)
{
- gfc_error ("Too few components in structure constructor at %C");
+ for (comp_iter = comp_head; comp_iter; comp_iter = comp_iter->next)
+ {
+ gfc_error ("component '%s' at %L has already been set by a "
+ "parent derived type constructor", comp_iter->name,
+ &comp_iter->where);
+ }
goto cleanup;
}
+ else
+ gcc_assert (!comp_head);
- e = gfc_get_expr ();
-
- e->expr_type = EXPR_STRUCTURE;
-
- e->ts.type = BT_DERIVED;
- e->ts.derived = sym;
- e->where = where;
-
- e->value.constructor = head;
+ e = gfc_get_structure_constructor_expr (BT_DERIVED, 0, &where);
+ e->ts.u.derived = sym;
+ e->value.constructor = ctor_head;
*result = e;
return MATCH_YES;
gfc_error ("Syntax error in structure constructor at %C");
cleanup:
- gfc_free_constructor (head);
+ for (comp_iter = comp_head; comp_iter; )
+ {
+ gfc_structure_ctor_component *next = comp_iter->next;
+ gfc_free_structure_ctor_component (comp_iter);
+ comp_iter = next;
+ }
+ gfc_constructor_free (ctor_head);
return MATCH_ERROR;
}
&& !(*sym)->attr.use_assoc)
{
int i;
- i = gfc_get_sym_tree ((*sym)->name, NULL, st);
+ i = gfc_get_sym_tree ((*sym)->name, NULL, st, false);
if (i)
return MATCH_ERROR;
*sym = (*st)->n.sym;
}
+/* Procedure pointer as function result: Replace the function symbol by the
+ auto-generated hidden result variable named "ppr@". */
+
+static gfc_try
+replace_hidden_procptr_result (gfc_symbol **sym, gfc_symtree **st)
+{
+ /* Check for procedure pointer result variable. */
+ if ((*sym)->attr.function && !(*sym)->attr.external
+ && (*sym)->result && (*sym)->result != *sym
+ && (*sym)->result->attr.proc_pointer
+ && (*sym) == gfc_current_ns->proc_name
+ && (*sym) == (*sym)->result->ns->proc_name
+ && strcmp ("ppr@", (*sym)->result->name) == 0)
+ {
+ /* Automatic replacement with "hidden" result variable. */
+ (*sym)->result->attr.referenced = (*sym)->attr.referenced;
+ *sym = (*sym)->result;
+ *st = gfc_find_symtree ((*sym)->ns->sym_root, (*sym)->name);
+ return SUCCESS;
+ }
+ return FAILURE;
+}
+
+
/* Matches a variable name followed by anything that might follow it--
array reference, argument list of a function, etc. */
if (gfc_find_state (COMP_INTERFACE) == SUCCESS
&& !gfc_current_ns->has_import_set)
- i = gfc_get_sym_tree (name, NULL, &symtree);
+ i = gfc_get_sym_tree (name, NULL, &symtree, false);
else
i = gfc_get_ha_sym_tree (name, &symtree);
e = NULL;
where = gfc_current_locus;
+ replace_hidden_procptr_result (&sym, &symtree);
+
/* If this is an implicit do loop index and implicitly typed,
it should not be host associated. */
m = check_for_implicit_index (&symtree, &sym);
/* See if this is a directly recursive function call. */
gfc_gobble_whitespace ();
if (sym->attr.recursive
- && gfc_peek_char () == '('
+ && gfc_peek_ascii_char () == '('
&& gfc_current_ns->proc_name == sym
&& !sym->attr.dimension)
{
return MATCH_ERROR;
}
- if (gfc_current_ns->proc_name == sym
- || (gfc_current_ns->parent != NULL
- && gfc_current_ns->parent->proc_name == sym))
+ if (gfc_is_function_return_value (sym, gfc_current_ns))
goto variable;
if (sym->attr.entry
}
}
+ if (gfc_matching_procptr_assignment)
+ goto procptr0;
+
if (sym->attr.function || sym->attr.external || sym->attr.intrinsic)
goto function0;
{
case FL_VARIABLE:
variable:
- if (sym->ts.type == BT_UNKNOWN && gfc_peek_char () == '%'
- && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
- gfc_set_default_type (sym, 0, sym->ns);
-
e = gfc_get_expr ();
e->expr_type = EXPR_VARIABLE;
e->symtree = symtree;
- m = match_varspec (e, 0);
+ m = gfc_match_varspec (e, 0, false, true);
break;
case FL_PARAMETER:
}
e->symtree = symtree;
- m = match_varspec (e, 0);
+ m = gfc_match_varspec (e, 0, false, true);
if (sym->ts.is_c_interop || sym->ts.is_iso_c)
break;
if (sym == NULL)
m = MATCH_ERROR;
else
- m = gfc_match_structure_constructor (sym, &e);
+ m = gfc_match_structure_constructor (sym, &e, false);
break;
/* If we're here, then the name is known to be the name of a
procedure, yet it is not sure to be the name of a function. */
case FL_PROCEDURE:
+
+ /* Procedure Pointer Assignments. */
+ procptr0:
+ if (gfc_matching_procptr_assignment)
+ {
+ gfc_gobble_whitespace ();
+ if (!sym->attr.dimension && gfc_peek_ascii_char () == '(')
+ /* Parse functions returning a procptr. */
+ goto function0;
+
+ if (gfc_is_intrinsic (sym, 0, gfc_current_locus)
+ || gfc_is_intrinsic (sym, 1, gfc_current_locus))
+ sym->attr.intrinsic = 1;
+ e = gfc_get_expr ();
+ e->expr_type = EXPR_VARIABLE;
+ e->symtree = symtree;
+ m = gfc_match_varspec (e, 0, false, true);
+ break;
+ }
+
if (sym->attr.subroutine)
{
gfc_error ("Unexpected use of subroutine name '%s' at %C",
e->symtree = symtree;
e->expr_type = EXPR_VARIABLE;
- m = match_varspec (e, 0);
+ m = gfc_match_varspec (e, 0, false, true);
break;
}
gfc_get_ha_sym_tree (name, &symtree); /* Can't fail */
sym = symtree->n.sym;
+ replace_hidden_procptr_result (&sym, &symtree);
+
e = gfc_get_expr ();
e->symtree = symtree;
e->expr_type = EXPR_FUNCTION;
via an IMPLICIT statement. This can't wait for the
resolution phase. */
- if (gfc_peek_char () == '%'
+ if (gfc_peek_ascii_char () == '%'
&& sym->ts.type == BT_UNKNOWN
- && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
+ && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
gfc_set_default_type (sym, 0, sym->ns);
/* If the symbol has a dimension attribute, the expression is a
e = gfc_get_expr ();
e->symtree = symtree;
e->expr_type = EXPR_VARIABLE;
- m = match_varspec (e, 0);
+ m = gfc_match_varspec (e, 0, false, true);
break;
}
variable is just a scalar. */
gfc_gobble_whitespace ();
- if (gfc_peek_char () != '(')
+ if (gfc_peek_ascii_char () != '(')
{
/* Assume a scalar variable */
e = gfc_get_expr ();
break;
}
- /*FIXME:??? match_varspec does set this for us: */
+ /*FIXME:??? gfc_match_varspec does set this for us: */
e->ts = sym->ts;
- m = match_varspec (e, 0);
+ m = gfc_match_varspec (e, 0, false, true);
break;
}
implicit_char = false;
if (sym->ts.type == BT_UNKNOWN)
{
- ts = gfc_get_default_type (sym,NULL);
+ ts = gfc_get_default_type (sym->name, NULL);
if (ts->type == BT_CHARACTER)
implicit_char = true;
}
that we're not sure is a variable yet. */
if ((implicit_char || sym->ts.type == BT_CHARACTER)
- && match_substring (sym->ts.cl, 0, &e->ref) == MATCH_YES)
+ && match_substring (sym->ts.u.cl, 0, &e->ref) == MATCH_YES)
{
e->expr_type = EXPR_VARIABLE;
e->ts = sym->ts;
if (e->ref)
- e->ts.cl = NULL;
+ e->ts.u.cl = NULL;
m = MATCH_YES;
break;
}
/* Give up, assume we have a function. */
- gfc_get_sym_tree (name, NULL, &symtree); /* Can't fail */
+ gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */
sym = symtree->n.sym;
e->expr_type = EXPR_FUNCTION;
/* If our new function returns a character, array or structure
type, it might have subsequent references. */
- m = match_varspec (e, 0);
+ m = gfc_match_varspec (e, 0, false, true);
if (m == MATCH_NO)
m = MATCH_YES;
break;
generic_function:
- gfc_get_sym_tree (name, NULL, &symtree); /* Can't fail */
+ gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */
e = gfc_get_expr ();
e->symtree = symtree;
}
-/* Match a variable, ie something that can be assigned to. This
+/* Match a variable, i.e. something that can be assigned to. This
starts as a symbol, can be a structure component or an array
reference. It can be a function if the function doesn't have a
separate RESULT variable. If the symbol has not been previously
we force the changed_symbols mechanism to work by setting
host_flag to 0. This prevents valid symbols that have the name
of keywords, such as 'end', being turned into variables by
- failed matching to assignments for, eg., END INTERFACE. */
+ failed matching to assignments for, e.g., END INTERFACE. */
if (gfc_current_state () == COMP_MODULE
|| gfc_current_state () == COMP_INTERFACE
|| gfc_current_state () == COMP_CONTAINS)
host_flag = 0;
+ where = gfc_current_locus;
m = gfc_match_sym_tree (&st, host_flag);
if (m != MATCH_YES)
return m;
- where = gfc_current_locus;
sym = st->n.sym;
switch (sym->attr.flavor)
{
case FL_VARIABLE:
- if (sym->attr.protected && sym->attr.use_assoc)
- {
- gfc_error ("Assigning to PROTECTED variable at %C");
- return MATCH_ERROR;
- }
+ /* Everything is alright. */
break;
case FL_UNKNOWN:
- if (sym->attr.access == ACCESS_PUBLIC
- || sym->attr.access == ACCESS_PRIVATE)
- break;
- if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
- sym->name, NULL) == FAILURE)
- return MATCH_ERROR;
+ {
+ sym_flavor flavor = FL_UNKNOWN;
+
+ gfc_gobble_whitespace ();
+
+ if (sym->attr.external || sym->attr.procedure
+ || sym->attr.function || sym->attr.subroutine)
+ flavor = FL_PROCEDURE;
+
+ /* If it is not a procedure, is not typed and is host associated,
+ we cannot give it a flavor yet. */
+ else if (sym->ns == gfc_current_ns->parent
+ && sym->ts.type == BT_UNKNOWN)
+ break;
+
+ /* These are definitive indicators that this is a variable. */
+ else if (gfc_peek_ascii_char () != '(' || sym->ts.type != BT_UNKNOWN
+ || sym->attr.pointer || sym->as != NULL)
+ flavor = FL_VARIABLE;
+
+ if (flavor != FL_UNKNOWN
+ && gfc_add_flavor (&sym->attr, flavor, sym->name, NULL) == FAILURE)
+ return MATCH_ERROR;
+ }
break;
case FL_PARAMETER:
if (equiv_flag)
- gfc_error ("Named constant at %C in an EQUIVALENCE");
- else
- gfc_error ("Cannot assign to a named constant at %C");
- return MATCH_ERROR;
+ {
+ gfc_error ("Named constant at %C in an EQUIVALENCE");
+ return MATCH_ERROR;
+ }
+ /* Otherwise this is checked for and an error given in the
+ variable definition context checks. */
break;
case FL_PROCEDURE:
- /* Check for a nonrecursive function result */
- if (sym->attr.function && sym->result == sym && !sym->attr.external)
+ /* Check for a nonrecursive function result variable. */
+ if (sym->attr.function
+ && !sym->attr.external
+ && sym->result == sym
+ && (gfc_is_function_return_value (sym, gfc_current_ns)
+ || (sym->attr.entry
+ && sym->ns == gfc_current_ns)
+ || (sym->attr.entry
+ && sym->ns == gfc_current_ns->parent)))
{
/* If a function result is a derived type, then the derived
type may still have to be resolved. */
if (sym->ts.type == BT_DERIVED
- && gfc_use_derived (sym->ts.derived) == NULL)
+ && gfc_use_derived (sym->ts.u.derived) == NULL)
return MATCH_ERROR;
break;
}
+ if (sym->attr.proc_pointer
+ || replace_hidden_procptr_result (&sym, &st) == SUCCESS)
+ break;
+
/* Fall through to error */
default:
- gfc_error ("Expected VARIABLE at %C");
+ gfc_error ("'%s' at %C is not a variable", sym->name);
return MATCH_ERROR;
}
else
implicit_ns = sym->ns;
- if (gfc_peek_char () == '%'
+ if (gfc_peek_ascii_char () == '%'
&& sym->ts.type == BT_UNKNOWN
- && gfc_get_default_type (sym, implicit_ns)->type == BT_DERIVED)
+ && gfc_get_default_type (sym->name, implicit_ns)->type == BT_DERIVED)
gfc_set_default_type (sym, 0, implicit_ns);
}
expr->where = where;
/* Now see if we have to do more. */
- m = match_varspec (expr, equiv_flag);
+ m = gfc_match_varspec (expr, equiv_flag, false, false);
if (m != MATCH_YES)
{
gfc_free_expr (expr);