/* Primary expression subroutines
- Copyright (C) 2000, 2001, 2002, 2004, 2005 Free Software Foundation,
- Inc.
+ Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007
+ Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING. If not, write to the Free
-Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA. */
-
+Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
+02110-1301, USA. */
#include "config.h"
#include "system.h"
const char *p;
match m;
- m = gfc_match_small_literal_int (kind);
+ m = gfc_match_small_literal_int (kind, NULL);
if (m != MATCH_NO)
return m;
A sign will be accepted if signflag is set. */
static match
-match_integer_constant (gfc_expr ** result, int signflag)
+match_integer_constant (gfc_expr **result, int signflag)
{
int length, kind;
locus old_loc;
}
-/* Match a binary, octal or hexadecimal constant that can be found in
- a DATA statement. */
+/* Match a Hollerith constant. */
static match
-match_boz_constant (gfc_expr ** result)
+match_hollerith_constant (gfc_expr **result)
{
- int radix, delim, length, x_hex, kind;
locus old_loc;
+ gfc_expr *e = NULL;
+ const char *msg;
char *buffer;
- gfc_expr *e;
- const char *rname;
+ int num;
+ int i;
old_loc = gfc_current_locus;
gfc_gobble_whitespace ();
+ if (match_integer_constant (&e, 0) == MATCH_YES
+ && gfc_match_char ('h') == MATCH_YES)
+ {
+ if (gfc_notify_std (GFC_STD_LEGACY, "Extension: Hollerith constant "
+ "at %C") == FAILURE)
+ goto cleanup;
+
+ msg = gfc_extract_int (e, &num);
+ if (msg != NULL)
+ {
+ gfc_error (msg);
+ goto cleanup;
+ }
+ if (num == 0)
+ {
+ gfc_error ("Invalid Hollerith constant: %L must contain at least "
+ "one character", &old_loc);
+ goto cleanup;
+ }
+ if (e->ts.kind != gfc_default_integer_kind)
+ {
+ gfc_error ("Invalid Hollerith constant: Integer kind at %L "
+ "should be default", &old_loc);
+ goto cleanup;
+ }
+ else
+ {
+ buffer = (char *) gfc_getmem (sizeof(char) * num + 1);
+ for (i = 0; i < num; i++)
+ {
+ buffer[i] = gfc_next_char_literal (1);
+ }
+ gfc_free_expr (e);
+ e = gfc_constant_result (BT_HOLLERITH, gfc_default_character_kind,
+ &gfc_current_locus);
+ e->value.character.string = gfc_getmem (num + 1);
+ memcpy (e->value.character.string, buffer, num);
+ e->value.character.string[num] = '\0';
+ e->value.character.length = num;
+ *result = e;
+ return MATCH_YES;
+ }
+ }
+
+ gfc_free_expr (e);
+ gfc_current_locus = old_loc;
+ return MATCH_NO;
+
+cleanup:
+ gfc_free_expr (e);
+ return MATCH_ERROR;
+}
+
+
+/* Match a binary, octal or hexadecimal constant that can be found in
+ a DATA statement. The standard permits b'010...', o'73...', and
+ z'a1...' where b, o, and z can be capital letters. This function
+ also accepts postfixed forms of the constants: '01...'b, '73...'o,
+ and 'a1...'z. An additional extension is the use of x for z. */
+
+static match
+match_boz_constant (gfc_expr **result)
+{
+ int post, radix, delim, length, x_hex, kind;
+ locus old_loc, start_loc;
+ char *buffer;
+ gfc_expr *e;
+
+ start_loc = old_loc = gfc_current_locus;
+ gfc_gobble_whitespace ();
+
x_hex = 0;
- switch (gfc_next_char ())
+ switch (post = gfc_next_char ())
{
case 'b':
radix = 2;
- rname = "binary";
+ post = 0;
break;
case 'o':
radix = 8;
- rname = "octal";
+ post = 0;
break;
case 'x':
x_hex = 1;
/* Fall through. */
case 'z':
radix = 16;
- rname = "hexadecimal";
+ post = 0;
+ break;
+ case '\'':
+ /* Fall through. */
+ case '\"':
+ delim = post;
+ post = 1;
+ radix = 16; /* Set to accept any valid digit string. */
break;
default:
goto backup;
/* No whitespace allowed here. */
- delim = gfc_next_char ();
+ if (post == 0)
+ delim = gfc_next_char ();
+
if (delim != '\'' && delim != '\"')
goto backup;
length = match_digits (0, radix, NULL);
if (length == -1)
{
- gfc_error ("Empty set of digits in %s constants at %C", rname);
+ gfc_error ("Empty set of digits in BOZ constant at %C");
return MATCH_ERROR;
}
if (gfc_next_char () != delim)
{
- gfc_error ("Illegal character in %s constant at %C.", rname);
+ gfc_error ("Illegal character in BOZ constant at %C");
return MATCH_ERROR;
}
+ if (post == 1)
+ {
+ switch (gfc_next_char ())
+ {
+ case 'b':
+ radix = 2;
+ break;
+ case 'o':
+ radix = 8;
+ break;
+ case 'x':
+ /* Fall through. */
+ case 'z':
+ radix = 16;
+ break;
+ default:
+ goto backup;
+ }
+ gfc_notify_std (GFC_STD_GNU, "Extension: BOZ constant "
+ "at %C uses non-standard postfix syntax.");
+ }
+
gfc_current_locus = old_loc;
buffer = alloca (length + 1);
memset (buffer, '\0', length + 1);
match_digits (0, radix, buffer);
- gfc_next_char (); /* Eat delimiter. */
-
- kind = get_kind ();
- if (kind == -1)
- return MATCH_ERROR;
- if (kind == -2)
- kind = gfc_default_integer_kind;
- else if (pedantic
- && (gfc_notify_std (GFC_STD_GNU, "Extension: Kind parameter "
- "suffix to boz literal constant at %C.")
- == FAILURE))
- return MATCH_ERROR;
-
+ gfc_next_char (); /* Eat delimiter. */
+ if (post == 1)
+ gfc_next_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
+ variable shall be of type integer. The boz-literal-constant is treated
+ as if it were an int-literal-constant with a kind-param that specifies
+ the representation method with the largest decimal exponent range
+ supported by the processor." */
+
+ kind = gfc_max_integer_kind;
e = gfc_convert_integer (buffer, kind, radix, &gfc_current_locus);
if (gfc_range_check (e) != ARITH_OK)
{
gfc_error ("Integer too big for integer kind %i at %C", kind);
-
gfc_free_expr (e);
return MATCH_ERROR;
}
return MATCH_YES;
backup:
- gfc_current_locus = old_loc;
+ gfc_current_locus = start_loc;
return MATCH_NO;
}
is nonzero. Allow integer constants if allow_int is true. */
static match
-match_real_constant (gfc_expr ** result, int signflag)
+match_real_constant (gfc_expr **result, int signflag)
{
int kind, c, count, seen_dp, seen_digits, exp_char;
locus old_loc, temp_loc;
if (seen_dp)
goto done;
- /* Check to see if "." goes with a following operator like ".eq.". */
+ /* Check to see if "." goes with a following operator like
+ ".eq.". */
temp_loc = gfc_current_locus;
c = gfc_next_char ();
break;
}
- if (!seen_digits
- || (c != 'e' && c != 'd' && c != 'q'))
+ if (!seen_digits || (c != 'e' && c != 'd' && c != 'q'))
goto done;
exp_char = c;
case 'd':
if (kind != -2)
{
- gfc_error
- ("Real number at %C has a 'd' exponent and an explicit kind");
+ gfc_error ("Real number at %C has a 'd' exponent and an explicit "
+ "kind");
goto cleanup;
}
kind = gfc_default_double_kind;
break;
- case 'q':
- if (kind != -2)
- {
- gfc_error
- ("Real number at %C has a 'q' exponent and an explicit kind");
- goto cleanup;
- }
- kind = gfc_option.q_kind;
- break;
-
default:
if (kind == -2)
kind = gfc_default_real_kind;
case ARITH_UNDERFLOW:
if (gfc_option.warn_underflow)
- gfc_warning ("Real constant underflows its kind at %C");
+ gfc_warning ("Real constant underflows its kind at %C");
mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
break;
/* Match a substring reference. */
static match
-match_substring (gfc_charlen * cl, int init, gfc_ref ** result)
+match_substring (gfc_charlen *cl, int init, gfc_ref **result)
{
gfc_expr *start, *end;
locus old_loc;
if (c == '\n')
return -2;
- if (c == '\\')
+ if (gfc_option.flag_backslash && c == '\\')
{
old_locus = gfc_current_locus;
gfc_current_locus = old_locus;
break;
}
+
+ if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings)
+ gfc_warning ("Extension: backslash character at %C");
}
if (c != delimiter)
/* Special case of gfc_match_name() that matches a parameter kind name
before a string constant. This takes case of the weird but legal
- case of: weird case of:
+ case of:
kind_____'string'
delimiter. Using match_kind_param() generates errors too quickly. */
static match
-match_string_constant (gfc_expr ** result)
+match_string_constant (gfc_expr **result)
{
char *p, name[GFC_MAX_SYMBOL_LEN + 1];
int i, c, kind, length, delimiter;
length++;
}
+ /* 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')
+ goto no_match;
+
+
e = gfc_get_expr ();
e->expr_type = EXPR_CONSTANT;
/* Match a .true. or .false. */
static match
-match_logical_constant (gfc_expr ** result)
+match_logical_constant (gfc_expr **result)
{
static mstring logical_ops[] = {
minit (".false.", 0),
symbolic constant. */
static match
-match_sym_complex_part (gfc_expr ** result)
+match_sym_complex_part (gfc_expr **result)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_symbol *sym;
return MATCH_ERROR;
}
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PARAMETER symbol in "
+ "complex constant at %C") == FAILURE)
+ return MATCH_ERROR;
+
switch (sym->value->ts.type)
{
case BT_REAL:
gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
}
- *result = e; /* e is a scalar, real, constant expression */
+ *result = e; /* e is a scalar, real, constant expression. */
return MATCH_YES;
error:
/* Match a real or imaginary part of a complex number. */
static match
-match_complex_part (gfc_expr ** result)
+match_complex_part (gfc_expr **result)
{
match m;
/* Try to match a complex constant. */
static match
-match_complex_constant (gfc_expr ** result)
+match_complex_constant (gfc_expr **result)
{
gfc_expr *e, *real, *imag;
gfc_error_buf old_error;
m = match_complex_part (&real);
if (m == MATCH_NO)
- goto cleanup;
+ {
+ gfc_free_error (&old_error);
+ goto cleanup;
+ }
if (gfc_match_char (',') == MATCH_NO)
{
sort. These sort of lists are matched prior to coming here. */
if (m == MATCH_ERROR)
- goto cleanup;
+ {
+ gfc_free_error (&old_error);
+ goto cleanup;
+ }
gfc_pop_error (&old_error);
m = match_complex_part (&imag);
m = gfc_match_char (')');
if (m == MATCH_NO)
+ {
+ /* 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 () == '=')
+ {
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+ else
goto syntax;
+ }
if (m == MATCH_ERROR)
goto cleanup;
match, zero for no match. */
match
-gfc_match_literal_constant (gfc_expr ** result, int signflag)
+gfc_match_literal_constant (gfc_expr **result, int signflag)
{
match m;
if (m != MATCH_NO)
return m;
+ m = match_hollerith_constant (result);
+ if (m != MATCH_NO)
+ return m;
+
m = match_integer_constant (result, signflag);
if (m != MATCH_NO)
return m;
fixing things later during resolution. */
static match
-match_actual_arg (gfc_expr ** result)
+match_actual_arg (gfc_expr **result)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_symtree *symtree;
/* Handle error elsewhere. */
/* Eliminate a couple of common cases where we know we don't
- have a function argument. */
+ have a function argument. */
if (symtree == NULL)
- {
+ {
gfc_get_sym_tree (name, NULL, &symtree);
- gfc_set_sym_referenced (symtree->n.sym);
- }
+ gfc_set_sym_referenced (symtree->n.sym);
+ }
else
{
- gfc_symbol *sym;
+ gfc_symbol *sym;
- sym = symtree->n.sym;
- gfc_set_sym_referenced (sym);
+ sym = symtree->n.sym;
+ gfc_set_sym_referenced (sym);
if (sym->attr.flavor != FL_PROCEDURE
&& sym->attr.flavor != FL_UNKNOWN)
break;
/* If the symbol is a function with itself as the result and
is being defined, then we have a variable. */
- if (sym->result == sym
- && (gfc_current_ns->proc_name == sym
+ 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)))
- break;
+ && gfc_current_ns->parent->proc_name == sym))
+ break;
+
+ if (sym->attr.entry
+ && (sym->ns == gfc_current_ns
+ || sym->ns == gfc_current_ns->parent))
+ {
+ gfc_entry_list *el = NULL;
+
+ for (el = sym->ns->entries; el; el = el->next)
+ if (sym == el->sym)
+ break;
+
+ if (el)
+ break;
+ }
+ }
}
e = gfc_get_expr (); /* Leave it unknown for now */
/* Match a keyword argument. */
static match
-match_keyword_arg (gfc_actual_arglist * actual, gfc_actual_arglist * base)
+match_keyword_arg (gfc_actual_arglist *actual, gfc_actual_arglist *base)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_actual_arglist *a;
for (a = base; a; a = a->next)
if (a->name != NULL && strcmp (a->name, name) == 0)
{
- gfc_error
- ("Keyword '%s' at %C has already appeared in the current "
- "argument list", name);
+ gfc_error ("Keyword '%s' at %C has already appeared in the "
+ "current argument list", name);
return MATCH_ERROR;
}
}
}
+/* Match an argument list function, such as %VAL. */
+
+static match
+match_arg_list_function (gfc_actual_arglist *result)
+{
+ char name[GFC_MAX_SYMBOL_LEN + 1];
+ locus old_locus;
+ match m;
+
+ old_locus = gfc_current_locus;
+
+ if (gfc_match_char ('%') != MATCH_YES)
+ {
+ m = MATCH_NO;
+ goto cleanup;
+ }
+
+ m = gfc_match ("%n (", name);
+ if (m != MATCH_YES)
+ goto cleanup;
+
+ if (name[0] != '\0')
+ {
+ switch (name[0])
+ {
+ case 'l':
+ if (strncmp (name, "loc", 3) == 0)
+ {
+ result->name = "%LOC";
+ break;
+ }
+ case 'r':
+ if (strncmp (name, "ref", 3) == 0)
+ {
+ result->name = "%REF";
+ break;
+ }
+ case 'v':
+ if (strncmp (name, "val", 3) == 0)
+ {
+ result->name = "%VAL";
+ break;
+ }
+ default:
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+ }
+
+ if (gfc_notify_std (GFC_STD_GNU, "Extension: argument list "
+ "function at %C") == FAILURE)
+ {
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+
+ m = match_actual_arg (&result->expr);
+ if (m != MATCH_YES)
+ goto cleanup;
+
+ if (gfc_match_char (')') != MATCH_YES)
+ {
+ m = MATCH_NO;
+ goto cleanup;
+ }
+
+ return MATCH_YES;
+
+cleanup:
+ gfc_current_locus = old_locus;
+ return m;
+}
+
+
/* Matches an actual argument list of a function or subroutine, from
the opening parenthesis to the closing parenthesis. The argument
list is assumed to allow keyword arguments because we don't know if
we're matching the argument list of a subroutine. */
match
-gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist ** argp)
+gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist **argp)
{
gfc_actual_arglist *head, *tail;
int seen_keyword;
if (sub_flag && gfc_match_char ('*') == MATCH_YES)
{
- m = gfc_match_st_label (&label, 0);
+ m = gfc_match_st_label (&label);
if (m == MATCH_NO)
gfc_error ("Expected alternate return label at %C");
if (m != MATCH_YES)
}
/* After the first keyword argument is seen, the following
- arguments must also have keywords. */
+ arguments must also have keywords. */
if (seen_keyword)
{
m = match_keyword_arg (tail, head);
goto cleanup;
if (m == MATCH_NO)
{
- gfc_error
- ("Missing keyword name in actual argument list at %C");
+ gfc_error ("Missing keyword name in actual argument list at %C");
goto cleanup;
}
}
else
{
- /* See if we have the first keyword argument. */
- m = match_keyword_arg (tail, head);
- if (m == MATCH_YES)
- seen_keyword = 1;
+ /* Try an argument list function, like %VAL. */
+ m = match_arg_list_function (tail);
if (m == MATCH_ERROR)
goto cleanup;
+ /* See if we have the first keyword argument. */
+ if (m == MATCH_NO)
+ {
+ m = match_keyword_arg (tail, head);
+ if (m == MATCH_YES)
+ seen_keyword = 1;
+ if (m == MATCH_ERROR)
+ goto cleanup;
+ }
+
if (m == MATCH_NO)
{
/* Try for a non-keyword argument. */
}
}
+
next:
if (gfc_match_char (')') == MATCH_YES)
break;
element. */
static gfc_ref *
-extend_ref (gfc_expr * primary, gfc_ref * tail)
+extend_ref (gfc_expr *primary, gfc_ref *tail)
{
-
if (primary->ref == NULL)
primary->ref = tail = gfc_get_ref ();
else
statement. */
static match
-match_varspec (gfc_expr * primary, int equiv_flag)
+match_varspec (gfc_expr *primary, int equiv_flag)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_ref *substring, *tail;
gfc_component *component;
- gfc_symbol *sym;
+ gfc_symbol *sym = primary->symtree->n.sym;
match m;
tail = NULL;
- if (primary->symtree->n.sym->attr.dimension
- || (equiv_flag
- && gfc_peek_char () == '('))
+ if ((equiv_flag && gfc_peek_char () == '(') || sym->attr.dimension)
{
-
+ /* In EQUIVALENCE, we don't know yet whether we are seeing
+ an array, character variable or array of character
+ variables. We'll leave the decision till resolve time. */
tail = extend_ref (primary, tail);
tail->type = REF_ARRAY;
- m = gfc_match_array_ref (&tail->u.ar, primary->symtree->n.sym->as,
- equiv_flag);
+ m = gfc_match_array_ref (&tail->u.ar, equiv_flag ? NULL : sym->as,
+ equiv_flag);
if (m != MATCH_YES)
return m;
+
+ if (equiv_flag && gfc_peek_char () == '(')
+ {
+ tail = extend_ref (primary, tail);
+ tail->type = REF_ARRAY;
+
+ m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag);
+ if (m != MATCH_YES)
+ return m;
+ }
}
- sym = primary->symtree->n.sym;
primary->ts = sym->ts;
+ if (equiv_flag)
+ return MATCH_YES;
+
if (sym->ts.type != BT_DERIVED || gfc_match_char ('%') != MATCH_YES)
goto check_substring;
}
check_substring:
+ if (primary->ts.type == BT_UNKNOWN)
+ {
+ if (gfc_get_default_type (sym, sym->ns)->type == BT_CHARACTER)
+ {
+ gfc_set_default_type (sym, 0, sym->ns);
+ primary->ts = sym->ts;
+ }
+ }
+
if (primary->ts.type == BT_CHARACTER)
{
switch (match_substring (primary->ts.cl, equiv_flag, &substring))
if (primary->expr_type == EXPR_CONSTANT)
primary->expr_type = EXPR_SUBSTRING;
+ if (substring)
+ primary->ts.cl = NULL;
+
break;
case MATCH_NO:
We can have at most one full array reference. */
symbol_attribute
-gfc_variable_attr (gfc_expr * expr, gfc_typespec * ts)
+gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
{
- int dimension, pointer, target;
+ int dimension, pointer, allocatable, target;
symbol_attribute attr;
gfc_ref *ref;
dimension = attr.dimension;
pointer = attr.pointer;
+ allocatable = attr.allocatable;
target = attr.target;
if (pointer)
break;
case AR_SECTION:
- pointer = 0;
+ allocatable = pointer = 0;
dimension = 1;
break;
case AR_ELEMENT:
- pointer = 0;
+ allocatable = pointer = 0;
break;
case AR_UNKNOWN:
*ts = ref->u.c.component->ts;
pointer = ref->u.c.component->pointer;
+ allocatable = ref->u.c.component->allocatable;
if (pointer)
target = 1;
break;
case REF_SUBSTRING:
- pointer = 0;
+ allocatable = pointer = 0;
break;
}
attr.dimension = dimension;
attr.pointer = pointer;
+ attr.allocatable = allocatable;
attr.target = target;
return attr;
/* Return the attribute from a general expression. */
symbol_attribute
-gfc_expr_attr (gfc_expr * e)
+gfc_expr_attr (gfc_expr *e)
{
symbol_attribute attr;
attr = e->value.function.esym->result->attr;
/* TODO: NULL() returns pointers. May have to take care of this
- here. */
+ here. */
break;
seen. */
match
-gfc_match_structure_constructor (gfc_symbol * sym, gfc_expr ** result)
+gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result)
{
gfc_constructor *head, *tail;
gfc_component *comp;
{
if (comp->next == NULL)
{
- gfc_error
- ("Too many components in structure constructor at %C");
+ gfc_error ("Too many components in structure constructor at %C");
goto cleanup;
}
array reference, argument list of a function, etc. */
match
-gfc_match_rvalue (gfc_expr ** result)
+gfc_match_rvalue (gfc_expr **result)
{
gfc_actual_arglist *actual_arglist;
char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1];
gfc_expr *e;
match m, m2;
int i;
+ gfc_typespec *ts;
+ bool implicit_char;
m = gfc_match_name (name);
if (m != MATCH_YES)
return m;
- if (gfc_find_state (COMP_INTERFACE) == SUCCESS)
+ if (gfc_find_state (COMP_INTERFACE) == SUCCESS
+ && !gfc_current_ns->has_import_set)
i = gfc_get_sym_tree (name, NULL, &symtree);
else
i = gfc_get_ha_sym_tree (name, &symtree);
gfc_set_sym_referenced (sym);
- if (sym->attr.function && sym->result == sym
- && (gfc_current_ns->proc_name == sym
+ if (sym->attr.function && sym->result == sym)
+ {
+ /* See if this is a directly recursive function call. */
+ gfc_gobble_whitespace ();
+ if (sym->attr.recursive
+ && gfc_peek_char () == '('
+ && gfc_current_ns->proc_name == sym)
+ {
+ if (!sym->attr.dimension)
+ goto function0;
+
+ gfc_error ("'%s' is array valued and directly recursive "
+ "at %C , so the keyword RESULT must be specified "
+ "in the FUNCTION statement", sym->name);
+ return MATCH_ERROR;
+ }
+
+ if (gfc_current_ns->proc_name == sym
|| (gfc_current_ns->parent != NULL
- && gfc_current_ns->parent->proc_name == sym)))
- goto variable;
+ && gfc_current_ns->parent->proc_name == sym))
+ goto variable;
+
+ if (sym->attr.entry
+ && (sym->ns == gfc_current_ns
+ || sym->ns == gfc_current_ns->parent))
+ {
+ gfc_entry_list *el = NULL;
+
+ for (el = sym->ns->entries; el; el = el->next)
+ if (sym == el->sym)
+ goto variable;
+ }
+ }
if (sym->attr.function || sym->attr.external || sym->attr.intrinsic)
goto function0;
break;
case FL_PARAMETER:
- if (sym->value
- && sym->value->expr_type != EXPR_ARRAY)
+ /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
+ end up here. Unfortunately, sym->value->expr_type is set to
+ EXPR_CONSTANT, and so the if () branch would be followed without
+ the !sym->as check. */
+ if (sym->value && sym->value->expr_type != EXPR_ARRAY && !sym->as)
e = gfc_copy_expr (sym->value);
else
{
if (sym == NULL)
m = MATCH_ERROR;
else
- m = gfc_match_structure_constructor (sym, &e);
+ m = gfc_match_structure_constructor (sym, &e);
break;
/* If we're here, then the name is known to be the name of a
}
/* At this point, the name has to be a non-statement function.
- If the name is the same as the current function being
- compiled, then we have a variable reference (to the function
- result) if the name is non-recursive. */
+ If the name is the same as the current function being
+ compiled, then we have a variable reference (to the function
+ result) if the name is non-recursive. */
st = gfc_enclosing_unit (NULL);
case FL_UNKNOWN:
/* Special case for derived type variables that get their types
- via an IMPLICIT statement. This can't wait for the
- resolution phase. */
+ via an IMPLICIT statement. This can't wait for the
+ resolution phase. */
if (gfc_peek_char () == '%'
&& sym->ts.type == BT_UNKNOWN
gfc_set_default_type (sym, 0, sym->ns);
/* If the symbol has a dimension attribute, the expression is a
- variable. */
+ variable. */
if (sym->attr.dimension)
{
}
/* Name is not an array, so we peek to see if a '(' implies a
- function call or a substring reference. Otherwise the
- variable is just a scalar. */
+ function call or a substring reference. Otherwise the
+ variable is just a scalar. */
gfc_gobble_whitespace ();
if (gfc_peek_char () != '(')
if (m2 != MATCH_YES)
{
+ /* Try to figure out whether we're dealing with a character type.
+ We're peeking ahead here, because we don't want to call
+ match_substring if we're dealing with an implicitly typed
+ non-character variable. */
+ implicit_char = false;
+ if (sym->ts.type == BT_UNKNOWN)
+ {
+ ts = gfc_get_default_type (sym,NULL);
+ if (ts->type == BT_CHARACTER)
+ implicit_char = true;
+ }
+
/* See if this could possibly be a substring reference of a name
that we're not sure is a variable yet. */
- if ((sym->ts.type == BT_UNKNOWN || sym->ts.type == BT_CHARACTER)
+ if ((implicit_char || sym->ts.type == BT_CHARACTER)
&& match_substring (sym->ts.cl, 0, &e->ref) == MATCH_YES)
{
}
e->ts = sym->ts;
+ if (e->ref)
+ e->ts.cl = NULL;
m = MATCH_YES;
break;
}
}
/* If our new function returns a character, array or structure
- type, it might have subsequent references. */
+ type, it might have subsequent references. */
m = match_varspec (e, 0);
if (m == MATCH_NO)
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
- seen, we assume it is a variable. */
+ seen, we assume it is a variable.
-match
-gfc_match_variable (gfc_expr ** result, int equiv_flag)
+ This function is called by two interface functions:
+ gfc_match_variable, which has host_flag = 1, and
+ gfc_match_equiv_variable, with host_flag = 0, to restrict the
+ match of the symbol to the local scope. */
+
+static match
+match_variable (gfc_expr **result, int equiv_flag, int host_flag)
{
gfc_symbol *sym;
gfc_symtree *st;
locus where;
match m;
- m = gfc_match_sym_tree (&st, 1);
+ /* Since nothing has any business being an lvalue in a module
+ specification block, an interface block or a contains section,
+ 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. */
+ if (gfc_current_state () == COMP_MODULE
+ || gfc_current_state () == COMP_INTERFACE
+ || gfc_current_state () == COMP_CONTAINS)
+ host_flag = 0;
+
+ m = gfc_match_sym_tree (&st, host_flag);
if (m != MATCH_YES)
return m;
where = gfc_current_locus;
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;
+ }
break;
case FL_UNKNOWN:
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;
+ break;
+
case FL_PROCEDURE:
/* Check for a nonrecursive function result */
if (sym->attr.function && (sym->result == sym || sym->attr.entry))
*result = expr;
return MATCH_YES;
}
+
+
+match
+gfc_match_variable (gfc_expr **result, int equiv_flag)
+{
+ return match_variable (result, equiv_flag, 1);
+}
+
+
+match
+gfc_match_equiv_variable (gfc_expr **result)
+{
+ return match_variable (result, 1, 0);
+}
+
OSDN Git Service
