/* Primary expression subroutines
- Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006
+ Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009, 2010
Free Software Foundation, Inc.
Contributed by Andy Vaught
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
+Software Foundation; either version 3, or (at your option) any later
version.
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
for more details.
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, 51 Franklin Street, Fifth Floor, Boston, MA
-02110-1301, USA. */
-
+along with GCC; see the file COPYING3. If not see
+<http://www.gnu.org/licenses/>. */
#include "config.h"
#include "system.h"
#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)
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;
if (length == -1)
return MATCH_NO;
- buffer = alloca (length + 1);
+ buffer = (char *) alloca (length + 1);
memset (buffer, '\0', length + 1);
gfc_gobble_whitespace ();
if (gfc_range_check (e) != ARITH_OK)
{
- gfc_error ("Integer too big for its kind at %C");
+ gfc_error ("Integer too big for its kind at %C. This check can be "
+ "disabled with the option -fno-range-check");
gfc_free_expr (e);
return MATCH_ERROR;
/* Match a Hollerith constant. */
static match
-match_hollerith_constant (gfc_expr ** result)
+match_hollerith_constant (gfc_expr **result)
{
locus old_loc;
- gfc_expr * e = NULL;
- const char * msg;
- char * buffer;
- int num;
+ gfc_expr *e = NULL;
+ const char *msg;
+ int num, pad;
int i;
old_loc = gfc_current_locus;
gfc_gobble_whitespace ();
if (match_integer_constant (&e, 0) == MATCH_YES
- && gfc_match_char ('h') == MATCH_YES)
+ && gfc_match_char ('h') == MATCH_YES)
{
- if (gfc_notify_std (GFC_STD_LEGACY,
- "Extension: Hollerith constant at %C")
- == FAILURE)
+ if (gfc_notify_std (GFC_STD_LEGACY, "Extension: Hollerith constant "
+ "at %C") == FAILURE)
goto cleanup;
msg = gfc_extract_int (e, &num);
}
if (num == 0)
{
- gfc_error ("Invalid Hollerith constant: %L must contain at least one "
- "character", &old_loc);
+ 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);
+ "should be default", &old_loc);
goto cleanup;
}
else
{
- buffer = (char *) gfc_getmem (sizeof(char) * num + 1);
+ gfc_free_expr (e);
+ 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);
+
for (i = 0; i < num; i++)
{
- buffer[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;
}
- 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;
+
+ /* 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;
}
and 'a1...'z. An additional extension is the use of x for z. */
static match
-match_boz_constant (gfc_expr ** result)
+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;
- if (x_hex && pedantic
+ if (x_hex
&& (gfc_notify_std (GFC_STD_GNU, "Extension: Hexadecimal "
- "constant at %C uses non-standard syntax.")
+ "constant at %C uses non-standard syntax")
== FAILURE))
return MATCH_ERROR;
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;
default:
goto backup;
}
- gfc_notify_std (GFC_STD_GNU, "Extension: BOZ constant "
- "at %C uses non-standard postfix syntax.");
+
+ if (gfc_notify_std (GFC_STD_GNU, "Extension: BOZ constant "
+ "at %C uses non-standard postfix syntax")
+ == FAILURE)
+ return MATCH_ERROR;
}
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
kind = gfc_max_integer_kind;
e = gfc_convert_integer (buffer, kind, radix, &gfc_current_locus);
+ /* Mark as boz variable. */
+ e->is_boz = 1;
+
if (gfc_range_check (e) != ARITH_OK)
{
gfc_error ("Integer too big for integer kind %i at %C", kind);
return MATCH_ERROR;
}
+ if (!gfc_in_match_data ()
+ && (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BOZ used outside a DATA "
+ "statement at %C")
+ == FAILURE))
+ return MATCH_ERROR;
+
*result = e;
return MATCH_YES;
/* Match a real constant of some sort. Allow a signed constant if signflag
- is nonzero. Allow integer constants if allow_int is true. */
+ is nonzero. */
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;
+ 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 == '.')
{
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_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. */
}
break;
}
- if (!seen_digits
- || (c != 'e' && c != 'd' && c != 'q'))
+ if (!seen_digits || (c != 'e' && c != 'd' && c != 'q'))
goto done;
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 ();
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;
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 == '\\')
{
old_locus = gfc_current_locus;
- switch (gfc_next_char_literal (1))
- {
- case 'a':
- c = '\a';
- break;
- case 'b':
- c = '\b';
- break;
- case 't':
- c = '\t';
- break;
- case 'f':
- c = '\f';
- break;
- case 'n':
- c = '\n';
- break;
- case 'r':
- c = '\r';
- break;
- case 'v':
- c = '\v';
- break;
- case '\\':
- c = '\\';
- break;
+ if (gfc_match_special_char (&c) == MATCH_NO)
+ gfc_current_locus = old_locus;
- default:
- /* Unknown backslash codes are simply not expanded */
- 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)
return c;
old_locus = gfc_current_locus;
- c = gfc_next_char_literal (1);
+ c = gfc_next_char_literal (0);
if (c == delimiter)
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;
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;
+ 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->where = start_locus;
-
- e->value.character.string = p = gfc_getmem (length + 1);
- e->value.character.length = length;
+ e->ts.is_c_interop = 0;
+ e->ts.is_iso_c = 0;
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)
}
+/* Match a .true. or .false. Returns 1 if a .true. was found,
+ 0 if a .false. was found, and -1 otherwise. */
+static int
+match_logical_constant_string (void)
+{
+ locus orig_loc = gfc_current_locus;
+
+ gfc_gobble_whitespace ();
+ if (gfc_next_ascii_char () == '.')
+ {
+ char ch = gfc_next_ascii_char ();
+ if (ch == 'f')
+ {
+ 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_ascii_char () == 'r'
+ && gfc_next_ascii_char () == 'u'
+ && gfc_next_ascii_char () == 'e'
+ && gfc_next_ascii_char () == '.')
+ /* Matched ".true.". */
+ return 1;
+ }
+ }
+ gfc_current_locus = orig_loc;
+ return -1;
+}
+
/* 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),
- minit (".true.", 1),
- minit (NULL, -1)
- };
-
gfc_expr *e;
int i, kind;
- i = gfc_match_strings (logical_ops);
+ i = match_logical_constant_string ();
if (i == -1)
return MATCH_NO;
kind = gfc_default_logical_kind;
if (gfc_validate_kind (BT_LOGICAL, kind, true) < 0)
- gfc_error ("Bad kind for logical constant at %C");
-
- e = gfc_get_expr ();
+ {
+ gfc_error ("Bad kind for logical constant at %C");
+ return MATCH_ERROR;
+ }
- e->expr_type = EXPR_CONSTANT;
- e->value.logical = i;
- e->ts.type = BT_LOGICAL;
- e->ts.kind = kind;
- e->where = gfc_current_locus;
+ e = gfc_get_logical_expr (kind, &gfc_current_locus, i);
+ e->ts.is_c_interop = 0;
+ e->ts.is_iso_c = 0;
*result = e;
return MATCH_YES;
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;
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;
{
/* 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;
}
target.type = BT_REAL;
target.kind = kind;
+ target.is_c_interop = 0;
+ target.is_iso_c = 0;
if (real->ts.type != BT_REAL || kind != real->ts.kind)
gfc_convert_type (real, &target, 2);
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;
}
+/* 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
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;
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 != ')')
/* 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_get_sym_tree (name, NULL, &symtree, false);
+ 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 (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
/* 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
the symbol associated with the procedure has an implicit interface
- or not. We make sure keywords are unique. If SUB_FLAG is set,
+ or not. We make sure keywords are unique. If sub_flag is set,
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;
}
/* 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;
}
-/* 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 *
-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
/* 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;
- if ((equiv_flag && gfc_peek_char () == '(')
- || sym->attr.dimension)
+ gfc_gobble_whitespace ();
+
+ 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
- variables. We'll leave the decision till resolve
- time. */
+ 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, equiv_flag ? NULL : sym->as,
- equiv_flag);
+ equiv_flag, sym->as ? sym->as->corank : 0);
if (m != MATCH_YES)
return m;
- if (equiv_flag && gfc_peek_char () == '(')
+ gfc_gobble_whitespace ();
+ 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);
+ 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;
- if (component->ts.type != BT_DERIVED
+ 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 && 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;
+ 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;
}
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, 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)
switch (ref->type)
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->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;
}
/* Return the attribute from a general expression. */
symbol_attribute
-gfc_expr_attr (gfc_expr * e)
+gfc_expr_attr (gfc_expr *e)
{
symbol_attribute 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. */
+ here. */
break;
/* 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;
+ 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 (head == NULL)
- tail = head = gfc_get_constructor ();
- else
+ 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)
{
- tail->next = gfc_get_constructor ();
- tail = tail->next;
+ if (!strcmp (comp_iter->name, comp->name))
+ break;
+ next_ptr = &comp_iter->next;
}
- m = gfc_match_expr (&tail->expr);
- if (m == MATCH_NO)
- goto syntax;
- if (m == MATCH_ERROR)
- goto cleanup;
-
- if (gfc_match_char (',') == MATCH_YES)
+ /* 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)
{
- if (comp->next == NULL)
+ 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_error
- ("Too many components in structure constructor at %C");
- goto cleanup;
+ gfc_free_expr (value);
+ return FAILURE;
}
+ gfc_constructor_append_expr (ctor_head, value, NULL);
continue;
}
- break;
+ /* 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;
+ }
+ }
+ 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)
+ {
+ *next_ptr = comp_iter->next;
+ comp_iter->val = NULL;
+ gfc_free_structure_ctor_component (comp_iter);
+ }
}
+ return SUCCESS;
+}
- if (gfc_match_char (')') != MATCH_YES)
+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 (comp->next != NULL)
+ 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 ("Too few components in structure constructor at %C");
- goto cleanup;
+ gfc_error ("Can't construct ABSTRACT type '%s' at %C", sym->name);
+ return MATCH_ERROR;
}
- e = gfc_get_expr ();
+ /* 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
+ {
+ 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;
+ }
- e->expr_type = EXPR_STRUCTURE;
+ gfc_current_locus = comp_tail->where;
+ strncpy (comp_tail->name, comp->name, GFC_MAX_SYMBOL_LEN + 1);
+ }
- e->ts.type = BT_DERIVED;
- e->ts.derived = sym;
- e->where = where;
+ /* 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;
- e->value.constructor = head;
+ /* Check if this component is already given a value. */
+ for (comp_iter = comp_head; comp_iter != comp_tail;
+ comp_iter = comp_iter->next)
+ {
+ 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;
+ }
+
+ if (comp)
+ comp = comp->next;
+
+ if (parent && !comp)
+ break;
+ }
+
+ while (gfc_match_char (',') == MATCH_YES);
+
+ if (!parent && gfc_match_char (')') != MATCH_YES)
+ goto syntax;
+ }
+
+ if (build_actual_constructor (&comp_head, &ctor_head, sym) == FAILURE)
+ goto cleanup;
+
+ /* 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)
+ {
+ 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_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;
}
+/* If the symbol is an implicit do loop index and implicitly typed,
+ it should not be host associated. Provide a symtree from the
+ current namespace. */
+static match
+check_for_implicit_index (gfc_symtree **st, gfc_symbol **sym)
+{
+ if ((*sym)->attr.flavor == FL_VARIABLE
+ && (*sym)->ns != gfc_current_ns
+ && (*sym)->attr.implied_index
+ && (*sym)->attr.implicit_type
+ && !(*sym)->attr.use_assoc)
+ {
+ int i;
+ i = gfc_get_sym_tree ((*sym)->name, NULL, st, false);
+ if (i)
+ return MATCH_ERROR;
+ *sym = (*st)->n.sym;
+ }
+ return MATCH_YES;
+}
+
+
+/* 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. */
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];
int i;
gfc_typespec *ts;
bool implicit_char;
+ gfc_ref *ref;
m = gfc_match_name (name);
if (m != MATCH_YES)
return m;
- if (gfc_find_state (COMP_INTERFACE) == SUCCESS)
- i = gfc_get_sym_tree (name, NULL, &symtree);
+ if (gfc_find_state (COMP_INTERFACE) == SUCCESS
+ && !gfc_current_ns->has_import_set)
+ 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);
+ if (m != MATCH_YES)
+ return m;
+
gfc_set_sym_referenced (sym);
+ sym->attr.implied_index = 0;
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)
+ && gfc_peek_ascii_char () == '('
+ && gfc_current_ns->proc_name == sym
+ && !sym->attr.dimension)
{
- 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);
+ gfc_error ("'%s' at %C is the name of a recursive function "
+ "and so refers to the result variable. Use an "
+ "explicit RESULT variable for direct recursion "
+ "(12.5.2.1)", sym->name);
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;
+
+ /* Variable array references to derived type parameters cause
+ all sorts of headaches in simplification. Treating such
+ expressions as variable works just fine for all array
+ references. */
+ if (sym->value && sym->ts.type == BT_DERIVED && e->ref)
+ {
+ for (ref = e->ref; ref; ref = ref->next)
+ if (ref->type == REF_ARRAY)
+ break;
+
+ if (ref == NULL || ref->u.ar.type == AR_FULL)
+ break;
+
+ ref = e->ref;
+ e->ref = NULL;
+ gfc_free_expr (e);
+ e = gfc_get_expr ();
+ e->expr_type = EXPR_VARIABLE;
+ e->symtree = symtree;
+ e->ref = ref;
+ }
+
break;
case FL_DERIVED:
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",
}
/* 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->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;
break;
}
+ /* Check here for the existence of at least one argument for the
+ iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED. The
+ argument(s) given will be checked in gfc_iso_c_func_interface,
+ during resolution of the function call. */
+ if (sym->attr.is_iso_c == 1
+ && (sym->from_intmod == INTMOD_ISO_C_BINDING
+ && (sym->intmod_sym_id == ISOCBINDING_LOC
+ || sym->intmod_sym_id == ISOCBINDING_FUNLOC
+ || sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)))
+ {
+ /* make sure we were given a param */
+ if (actual_arglist == NULL)
+ {
+ gfc_error ("Missing argument to '%s' at %C", sym->name);
+ m = MATCH_ERROR;
+ break;
+ }
+ }
+
if (sym->result == NULL)
sym->result = sym;
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 () == '%'
+ 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
- variable. */
+ variable. */
if (sym->attr.dimension)
{
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;
}
/* 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 (gfc_peek_ascii_char () != '(')
{
/* Assume a scalar variable */
e = gfc_get_expr ();
break;
}
+ /*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. */
+ 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
match of the symbol to the local scope. */
static match
-match_variable (gfc_expr ** result, int equiv_flag, int host_flag)
+match_variable (gfc_expr **result, int equiv_flag, int host_flag)
{
gfc_symbol *sym;
gfc_symtree *st;
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;
+
+ /* If this is an implicit do loop index and implicitly typed,
+ it should not be host associated. */
+ m = check_for_implicit_index (&st, &sym);
+ if (m != MATCH_YES)
+ return m;
+
+ sym->attr.implied_index = 0;
+
gfc_set_sym_referenced (sym);
switch (sym->attr.flavor)
{
case FL_VARIABLE:
+ if (sym->attr.is_protected && sym->attr.use_assoc)
+ {
+ gfc_error ("Assigning to PROTECTED variable at %C");
+ return MATCH_ERROR;
+ }
+ if (sym->assoc)
+ sym->assoc->variable = 1;
break;
case FL_UNKNOWN:
- 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:
break;
case FL_PROCEDURE:
- /* Check for a nonrecursive function result */
- if (sym->attr.function && (sym->result == sym || sym->attr.entry))
+ /* 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);
return MATCH_YES;
}
+
match
-gfc_match_variable (gfc_expr ** result, int equiv_flag)
+gfc_match_variable (gfc_expr **result, int equiv_flag)
{
return match_variable (result, equiv_flag, 1);
}
+
match
-gfc_match_equiv_variable (gfc_expr ** result)
+gfc_match_equiv_variable (gfc_expr **result)
{
return match_variable (result, 1, 0);
}
OSDN Git Service
