/* Primary expression subroutines
- Copyright (C) 2000, 2001, 2002 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 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"
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;
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++;
}
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;
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 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;
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;
+ 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)
+match_real_constant (gfc_expr **result, int signflag)
{
int kind, c, count, seen_dp, seen_digits, exp_char;
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. */
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 ();
{
c = gfc_next_char ();
if (c == '.')
- goto done; /* Operator named .e. or .d. */
+ goto done; /* Operator named .e. or .d. */
}
if (ISALPHA (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 ();
case 'd':
if (kind != -2)
{
- 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");
+ gfc_error ("Real number at %C has a 'd' exponent and an explicit "
+ "kind");
goto cleanup;
}
- kind = gfc_option.q_kind;
+ kind = gfc_default_double_kind;
break;
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);
+ gfc_warning ("Real constant underflows its kind at %C");
+ mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
break;
default:
/* 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;
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;
/* 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),
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 ();
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:
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;
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 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
-match_complex_part (gfc_expr ** result)
+match_complex_part (gfc_expr **result)
{
match m;
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);
}
/* 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;
/* 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);
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;
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 "
- "argument list", name);
+ gfc_error ("Keyword '%s' at %C has already appeared in the "
+ "current argument list", name);
return MATCH_ERROR;
}
}
- strcpy (actual->name, name);
+ actual->name = gfc_get_string (name);
return MATCH_YES;
cleanup:
}
+/* 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:
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_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);
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;
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_get_default_type (sym, sym->ns)->type == BT_DERIVED)
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)
{
- 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;
}
/* 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 () != '(')
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;
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->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;
}
/* 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:
- 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;
+ break;
- /* 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);
-
+ 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))
{
-
/* 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
