/* Primary expression subroutines
- Copyright (C) 2000, 2001, 2002 Free Software Foundation, Inc.
+ Copyright (C) 2000, 2001, 2002, 2004, 2005 Free Software Foundation,
+ Inc.
Contributed by Andy Vaught
-This file is part of GNU G95.
+This file is part of GCC.
-GNU G95 is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 2, or (at your option) any later
+version.
-GNU G95 is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+for more details.
You should have received a copy of the GNU General Public License
-along with GNU G95; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330,
-Boston, MA 02111-1307, USA. */
+along with GCC; see the file COPYING. If not, write to the Free
+Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
+02110-1301, USA. */
#include "config.h"
#include "system.h"
#include "flags.h"
-
-#include <string.h>
-#include <stdlib.h>
#include "gfortran.h"
#include "arith.h"
#include "match.h"
break;
case 16:
- r = ('0' <= c && c <= '9') || ('a' <= c && c <= 'f');
+ r = ISXDIGIT (c);
break;
default:
{
if (buffer != NULL)
*buffer++ = c;
+ gfc_gobble_whitespace ();
c = gfc_next_char ();
length++;
}
kind = get_kind ();
if (kind == -2)
- kind = gfc_default_integer_kind ();
+ kind = gfc_default_integer_kind;
if (kind == -1)
return MATCH_ERROR;
- if (gfc_validate_kind (BT_INTEGER, kind) == -1)
+ if (gfc_validate_kind (BT_INTEGER, kind, true) < 0)
{
gfc_error ("Integer kind %d at %C not available", kind);
return MATCH_ERROR;
}
+/* Match a Hollerith constant. */
+
+static match
+match_hollerith_constant (gfc_expr ** result)
+{
+ locus old_loc;
+ gfc_expr * e = NULL;
+ const char * msg;
+ char * buffer;
+ 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: Interger 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.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. */
+ 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 radix, delim, length, x_hex;
- locus old_loc;
+ int post, radix, delim, length, x_hex, kind;
+ locus old_loc, start_loc;
char *buffer;
gfc_expr *e;
- const char *rname;
- old_loc = gfc_current_locus;
+ 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;
+ if (x_hex && pedantic
+ && (gfc_notify_std (GFC_STD_GNU, "Extension: Hexadecimal "
+ "constant at %C uses non-standard syntax.")
+ == FAILURE))
+ return MATCH_ERROR;
+
old_loc = gfc_current_locus;
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 ();
+ gfc_next_char (); /* Eat delimiter. */
+ if (post == 1)
+ gfc_next_char (); /* Eat postfixed b, o, z, or x. */
- e = gfc_convert_integer (buffer, gfc_default_integer_kind (), radix,
- &gfc_current_locus);
+ /* 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." */
- if (gfc_range_check (e) != ARITH_OK)
- {
- gfc_error ("Integer too big for default integer kind at %C");
-
- gfc_free_expr (e);
- return MATCH_ERROR;
- }
+ kind = gfc_max_integer_kind;
+ e = gfc_convert_integer (buffer, kind, radix, &gfc_current_locus);
- if (x_hex
- && pedantic
- && (gfc_notify_std (GFC_STD_GNU, "Extension: Hexadecimal "
- "constant at %C uses non-standard syntax.")
- == FAILURE))
+ 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;
}
-/* Match a real constant of some sort. */
+/* Match a real constant of some sort. Allow a signed constant if signflag
+ is nonzero. Allow integer constants if allow_int is true. */
static match
match_real_constant (gfc_expr ** result, int signflag)
locus old_loc, temp_loc;
char *p, *buffer;
gfc_expr *e;
+ bool negate;
old_loc = gfc_current_locus;
gfc_gobble_whitespace ();
seen_dp = 0;
seen_digits = 0;
exp_char = ' ';
+ negate = FALSE;
c = gfc_next_char ();
if (signflag && (c == '+' || c == '-'))
{
+ if (c == '-')
+ negate = TRUE;
+
+ gfc_gobble_whitespace ();
c = gfc_next_char ();
- count++;
}
/* Scan significand. */
{
c = gfc_next_char ();
if (c == '.')
- goto done; /* Operator named .e. or .d. */
+ goto done; /* Operator named .e. or .d. */
}
if (ISALPHA (c))
break;
}
- if (!seen_digits || (c != 'e' && c != 'd' && c != 'q'))
+ if (!seen_digits
+ || (c != 'e' && c != 'd' && c != 'q'))
goto done;
exp_char = c;
if (!ISDIGIT (c))
{
- /* TODO: seen_digits is always true at this point */
- if (!seen_digits)
- {
- gfc_current_locus = old_loc;
- return MATCH_NO; /* ".e" can be something else */
- }
-
gfc_error ("Missing exponent in real number at %C");
return MATCH_ERROR;
}
}
done:
- /* See what we've got! */
+ /* Check that we have a numeric constant. */
if (!seen_digits || (!seen_dp && exp_char == ' '))
{
gfc_current_locus = old_loc;
buffer = alloca (count + 1);
memset (buffer, '\0', count + 1);
- /* Hack for mpf_init_set_str(). */
p = buffer;
- while (count > 0)
+ c = gfc_next_char ();
+ if (c == '+' || c == '-')
+ {
+ gfc_gobble_whitespace ();
+ c = gfc_next_char ();
+ }
+
+ /* Hack for mpfr_set_str(). */
+ for (;;)
{
- *p = gfc_next_char ();
- if (*p == 'd' || *p == 'q')
+ if (c == 'd' || c == 'q')
*p = 'e';
+ else
+ *p = c;
p++;
- count--;
+ if (--count == 0)
+ break;
+
+ c = gfc_next_char ();
}
kind = get_kind ();
("Real number at %C has a 'd' exponent and an explicit kind");
goto cleanup;
}
- kind = gfc_default_double_kind ();
+ kind = gfc_default_double_kind;
break;
case 'q':
default:
if (kind == -2)
- kind = gfc_default_real_kind ();
+ kind = gfc_default_real_kind;
- if (gfc_validate_kind (BT_REAL, kind) == -1)
+ if (gfc_validate_kind (BT_REAL, kind, true) < 0)
{
gfc_error ("Invalid real kind %d at %C", kind);
goto cleanup;
}
e = gfc_convert_real (buffer, kind, &gfc_current_locus);
+ if (negate)
+ mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE);
switch (gfc_range_check (e))
{
case ARITH_UNDERFLOW:
if (gfc_option.warn_underflow)
gfc_warning ("Real constant underflows its kind at %C");
- mpf_set_ui(e->value.real, 0);
+ mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
break;
default:
if (c == '\n')
return -2;
- if (c == '\\')
+ if (gfc_option.flag_backslash && c == '\\')
{
old_locus = gfc_current_locus;
/* 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'
c = gfc_next_char ();
if (c == '\'' || c == '"')
{
- kind = gfc_default_character_kind ();
+ kind = gfc_default_character_kind;
goto got_delim;
}
}
}
- if (gfc_validate_kind (BT_CHARACTER, kind) == -1)
+ if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
{
gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind);
return MATCH_ERROR;
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;
if (kind == -1)
return MATCH_ERROR;
if (kind == -2)
- kind = gfc_default_logical_kind ();
+ kind = gfc_default_logical_kind;
- if (gfc_validate_kind (BT_LOGICAL, kind) == -1)
+ if (gfc_validate_kind (BT_LOGICAL, kind, true) < 0)
gfc_error ("Bad kind for logical constant at %C");
e = gfc_get_expr ();
break;
case BT_INTEGER:
- e = gfc_int2real (sym->value, gfc_default_real_kind ());
+ e = gfc_int2real (sym->value, gfc_default_real_kind);
if (e == NULL)
goto error;
break;
}
-/* Match the real and imaginary parts of a complex number. This
- subroutine is essentially match_real_constant() modified in a
- couple of ways: A sign is always allowed and numbers that would
- look like an integer to match_real_constant() are automatically
- created as floating point numbers. The messiness involved with
- making sure a decimal point belongs to the number and not a
- trailing operator is not necessary here either (Hooray!). */
-
-static match
-match_const_complex_part (gfc_expr ** result)
-{
- int kind, seen_digits, seen_dp, count;
- char *p, c, exp_char, *buffer;
- locus old_loc;
-
- old_loc = gfc_current_locus;
- gfc_gobble_whitespace ();
-
- seen_dp = 0;
- seen_digits = 0;
- count = 0;
- exp_char = ' ';
-
- c = gfc_next_char ();
- if (c == '-' || c == '+')
- {
- c = gfc_next_char ();
- count++;
- }
-
- for (;; c = gfc_next_char (), count++)
- {
- if (c == '.')
- {
- if (seen_dp)
- goto no_match;
- seen_dp = 1;
- continue;
- }
-
- if (ISDIGIT (c))
- {
- seen_digits = 1;
- continue;
- }
-
- break;
- }
-
- if (!seen_digits || (c != 'd' && c != 'e'))
- goto done;
- exp_char = c;
-
- /* Scan exponent. */
- c = gfc_next_char ();
- count++;
-
- if (c == '+' || c == '-')
- { /* optional sign */
- c = gfc_next_char ();
- count++;
- }
-
- if (!ISDIGIT (c))
- {
- gfc_error ("Missing exponent in real number at %C");
- return MATCH_ERROR;
- }
-
- while (ISDIGIT (c))
- {
- c = gfc_next_char ();
- count++;
- }
-
-done:
- if (!seen_digits)
- goto no_match;
-
- /* Convert the number. */
- gfc_current_locus = old_loc;
- gfc_gobble_whitespace ();
-
- buffer = alloca (count + 1);
- memset (buffer, '\0', count + 1);
-
- /* Hack for mpf_init_set_str(). */
- p = buffer;
- while (count > 0)
- {
- c = gfc_next_char ();
- if (c == 'd')
- c = 'e';
- *p++ = c;
- count--;
- }
-
- *p = '\0';
-
- kind = get_kind ();
- if (kind == -1)
- return MATCH_ERROR;
-
- /* If the number looked like an integer, forget about a kind we may
- have seen, otherwise validate the kind against real kinds. */
- if (seen_dp == 0 && exp_char == ' ')
- {
- if (kind == -2)
- kind = gfc_default_integer_kind ();
-
- }
- else
- {
- if (exp_char == 'd')
- {
- if (kind != -2)
- {
- gfc_error
- ("Real number at %C has a 'd' exponent and an explicit kind");
- return MATCH_ERROR;
- }
- kind = gfc_default_double_kind ();
-
- }
- else
- {
- if (kind == -2)
- kind = gfc_default_real_kind ();
- }
-
- if (gfc_validate_kind (BT_REAL, kind) == -1)
- {
- gfc_error ("Invalid real kind %d at %C", kind);
- return MATCH_ERROR;
- }
- }
-
- *result = gfc_convert_real (buffer, kind, &gfc_current_locus);
- return MATCH_YES;
-
-no_match:
- gfc_current_locus = old_loc;
- return MATCH_NO;
-}
-
-
/* Match a real or imaginary part of a complex number. */
static match
if (m != MATCH_NO)
return m;
- return match_const_complex_part (result);
+ m = match_real_constant (result, 1);
+ if (m != MATCH_NO)
+ return m;
+
+ return match_integer_constant (result, 1);
}
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;
/* Decide on the kind of this complex number. */
- kind = gfc_kind_max (real, imag);
+ if (real->ts.type == BT_REAL)
+ {
+ if (imag->ts.type == BT_REAL)
+ kind = gfc_kind_max (real, imag);
+ else
+ kind = real->ts.kind;
+ }
+ else
+ {
+ if (imag->ts.type == BT_REAL)
+ kind = imag->ts.kind;
+ else
+ kind = gfc_default_real_kind;
+ }
target.type = BT_REAL;
target.kind = kind;
- if (kind != real->ts.kind)
+ if (real->ts.type != BT_REAL || kind != real->ts.kind)
gfc_convert_type (real, &target, 2);
- if (kind != imag->ts.kind)
+ if (imag->ts.type != BT_REAL || kind != imag->ts.kind)
gfc_convert_type (imag, &target, 2);
e = gfc_convert_complex (real, imag, kind);
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;
/* 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 */
if (name[0] != '\0')
{
for (a = base; a; a = a->next)
- if (strcmp (a->name, name) == 0)
+ if (a->name != NULL && strcmp (a->name, name) == 0)
{
gfc_error
("Keyword '%s' at %C has already appeared in the current "
}
}
- strcpy (actual->name, name);
+ actual->name = gfc_get_string (name);
return MATCH_YES;
cleanup:
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:
dumped). If we see a full part or section of an array, the
expression is also an array.
- We can have at most one full array reference. */
+ We can have at most one full array reference. */
symbol_attribute
gfc_variable_attr (gfc_expr * expr, gfc_typespec * ts)
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)
+ {
+ 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
{
e->rank = sym->as->rank;
if (!sym->attr.function
- && gfc_add_function (&sym->attr, NULL) == FAILURE)
+ && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
{
m = MATCH_ERROR;
break;
resolution phase. */
if (gfc_peek_char () == '%'
+ && sym->ts.type == BT_UNKNOWN
&& gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
gfc_set_default_type (sym, 0, sym->ns);
if (sym->attr.dimension)
{
- if (gfc_add_flavor (&sym->attr, FL_VARIABLE, NULL) == FAILURE)
+ if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
+ sym->name, NULL) == FAILURE)
{
m = MATCH_ERROR;
break;
e->symtree = symtree;
e->expr_type = EXPR_VARIABLE;
- if (gfc_add_flavor (&sym->attr, FL_VARIABLE, NULL) == FAILURE)
+ if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
+ sym->name, NULL) == FAILURE)
{
m = MATCH_ERROR;
break;
e->expr_type = EXPR_VARIABLE;
if (sym->attr.flavor != FL_VARIABLE
- && gfc_add_flavor (&sym->attr, FL_VARIABLE, NULL) == FAILURE)
+ && gfc_add_flavor (&sym->attr, FL_VARIABLE,
+ sym->name, NULL) == FAILURE)
{
m = MATCH_ERROR;
break;
}
e->ts = sym->ts;
+ if (e->ref)
+ e->ts.cl = NULL;
m = MATCH_YES;
break;
}
e->expr_type = EXPR_FUNCTION;
if (!sym->attr.function
- && gfc_add_function (&sym->attr, NULL) == FAILURE)
+ && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
{
m = MATCH_ERROR;
break;
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);
+ m = gfc_match_sym_tree (&st, host_flag);
if (m != MATCH_YES)
return m;
where = gfc_current_locus;
break;
case FL_UNKNOWN:
- if (gfc_add_flavor (&sym->attr, FL_VARIABLE, NULL) == FAILURE)
+ if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
+ sym->name, NULL) == FAILURE)
return MATCH_ERROR;
-
- /* Special case for derived type variables that get their types
- via an IMPLICIT statement. This can't wait for the
- resolution phase. */
-
- if (gfc_peek_char () == '%'
- && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
- gfc_set_default_type (sym, 0, sym->ns);
-
break;
case FL_PROCEDURE:
/* Check for a nonrecursive function result */
if (sym->attr.function && (sym->result == sym || sym->attr.entry))
{
-
/* 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)
return MATCH_ERROR;
-
break;
}
return MATCH_ERROR;
}
+ /* Special case for derived type variables that get their types
+ via an IMPLICIT statement. This can't wait for the
+ resolution phase. */
+
+ {
+ gfc_namespace * implicit_ns;
+
+ if (gfc_current_ns->proc_name == sym)
+ implicit_ns = gfc_current_ns;
+ else
+ implicit_ns = sym->ns;
+
+ if (gfc_peek_char () == '%'
+ && sym->ts.type == BT_UNKNOWN
+ && gfc_get_default_type (sym, implicit_ns)->type == BT_DERIVED)
+ gfc_set_default_type (sym, 0, implicit_ns);
+ }
+
expr = gfc_get_expr ();
expr->expr_type = EXPR_VARIABLE;
*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
