/* Primary expression subroutines
- Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007
+ Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008
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 "toplev.h"
/* Matches a kind-parameter expression, which is either a named
symbolic constant or a nonnegative integer constant. If
if (p != NULL)
return MATCH_NO;
+ gfc_set_sym_referenced (sym);
+
if (*kind < 0)
return MATCH_NO;
/* Given a character and a radix, see if the character is a valid
digit in that radix. */
-static int
-check_digit (int c, int radix)
+int
+gfc_check_digit (char c, int radix)
{
int r;
break;
default:
- gfc_internal_error ("check_digit(): bad radix");
+ gfc_internal_error ("gfc_check_digit(): bad radix");
}
return r;
match_digits (int signflag, int radix, char *buffer)
{
locus old_loc;
- int length, c;
+ int length;
+ char c;
length = 0;
- c = gfc_next_char ();
+ c = gfc_next_ascii_char ();
if (signflag && (c == '+' || c == '-'))
{
if (buffer != NULL)
*buffer++ = c;
gfc_gobble_whitespace ();
- c = gfc_next_char ();
+ c = gfc_next_ascii_char ();
length++;
}
- if (!check_digit (c, radix))
+ if (!gfc_check_digit (c, radix))
return -1;
length++;
for (;;)
{
old_loc = gfc_current_locus;
- c = gfc_next_char ();
+ c = gfc_next_ascii_char ();
- if (!check_digit (c, radix))
+ if (!gfc_check_digit (c, radix))
break;
if (buffer != NULL)
if (length == -1)
return MATCH_NO;
- buffer = alloca (length + 1);
+ buffer = (char *) alloca (length + 1);
memset (buffer, '\0', length + 1);
gfc_gobble_whitespace ();
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;
locus old_loc;
gfc_expr *e = NULL;
const char *msg;
- char *buffer;
int num;
int i;
}
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;
+
+ e->representation.string = XCNEWVEC (char, num + 1);
+
+ for (i = 0; i < num; i++)
+ {
+ gfc_char_t c = gfc_next_char_literal (1);
+ if (! gfc_wide_fits_in_byte (c))
+ {
+ gfc_error ("Invalid Hollerith constant at %L contains a "
+ "wide character", &old_loc);
+ goto cleanup;
+ }
+
+ e->representation.string[i] = (unsigned char) c;
+ }
+
+ e->representation.string[num] = '\0';
+ e->representation.length = num;
+
*result = e;
return MATCH_YES;
}
static match
match_boz_constant (gfc_expr **result)
{
- int post, radix, delim, length, x_hex, kind;
+ int radix, length, x_hex, kind;
locus old_loc, start_loc;
- char *buffer;
+ char *buffer, post, delim;
gfc_expr *e;
start_loc = old_loc = gfc_current_locus;
gfc_gobble_whitespace ();
x_hex = 0;
- switch (post = gfc_next_char ())
+ switch (post = gfc_next_ascii_char ())
{
case 'b':
radix = 2;
/* No whitespace allowed here. */
if (post == 0)
- delim = gfc_next_char ();
+ delim = gfc_next_ascii_char ();
if (delim != '\'' && delim != '\"')
goto backup;
- 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)
{
- int kind, c, count, seen_dp, seen_digits, exp_char;
+ int kind, count, seen_dp, seen_digits;
locus old_loc, temp_loc;
- char *p, *buffer;
+ char *p, *buffer, c, exp_char;
gfc_expr *e;
bool negate;
exp_char = ' ';
negate = FALSE;
- c = gfc_next_char ();
+ c = gfc_next_ascii_char ();
if (signflag && (c == '+' || c == '-'))
{
if (c == '-')
negate = TRUE;
gfc_gobble_whitespace ();
- c = gfc_next_char ();
+ c = gfc_next_ascii_char ();
}
/* Scan significand. */
- for (;; c = gfc_next_char (), count++)
+ for (;; c = gfc_next_ascii_char (), count++)
{
if (c == '.')
{
/* Check to see if "." goes with a following operator like
".eq.". */
temp_loc = gfc_current_locus;
- c = gfc_next_char ();
+ c = gfc_next_ascii_char ();
if (c == 'e' || c == 'd' || c == 'q')
{
- c = gfc_next_char ();
+ c = gfc_next_ascii_char ();
if (c == '.')
goto done; /* Operator named .e. or .d. */
}
exp_char = c;
/* Scan exponent. */
- c = gfc_next_char ();
+ c = gfc_next_ascii_char ();
count++;
if (c == '+' || c == '-')
{ /* optional sign */
- c = gfc_next_char ();
+ c = gfc_next_ascii_char ();
count++;
}
while (ISDIGIT (c))
{
- c = gfc_next_char ();
+ c = gfc_next_ascii_char ();
count++;
}
gfc_current_locus = old_loc;
gfc_gobble_whitespace ();
- buffer = alloca (count + 1);
+ buffer = (char *) alloca (count + 1);
memset (buffer, '\0', count + 1);
p = buffer;
- c = gfc_next_char ();
+ c = gfc_next_ascii_char ();
if (c == '+' || c == '-')
{
gfc_gobble_whitespace ();
- c = gfc_next_char ();
+ c = gfc_next_ascii_char ();
}
/* Hack for mpfr_set_str(). */
if (--count == 0)
break;
- c = gfc_next_char ();
+ c = gfc_next_ascii_char ();
}
kind = get_kind ();
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;
-
- default:
- /* Unknown backslash codes are simply not expanded */
- gfc_current_locus = old_locus;
- break;
- }
+ if (gfc_match_special_char (&c) == MATCH_NO)
+ gfc_current_locus = old_locus;
if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings)
gfc_warning ("Extension: backslash character at %C");
return c;
gfc_current_locus = old_locus;
- return -1;
+ *ret = -1;
+ return 0;
}
int len;
gfc_gobble_whitespace ();
- c = gfc_next_char ();
+ c = gfc_next_ascii_char ();
if (!ISALPHA (c))
return MATCH_NO;
for (;;)
{
old_loc = gfc_current_locus;
- c = gfc_next_char ();
+ c = gfc_next_ascii_char ();
if (c == '_')
{
- peek = gfc_peek_char ();
+ peek = gfc_peek_ascii_char ();
if (peek == '\'' || peek == '\"')
{
static match
match_string_constant (gfc_expr **result)
{
- char *p, name[GFC_MAX_SYMBOL_LEN + 1];
- int i, c, kind, length, delimiter, warn_ampersand;
+ char name[GFC_MAX_SYMBOL_LEN + 1], peek;
+ int i, kind, length, warn_ampersand, ret;
locus old_locus, start_locus;
gfc_symbol *sym;
gfc_expr *e;
const char *q;
match m;
+ gfc_char_t c, delimiter, *p;
old_locus = gfc_current_locus;
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)
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->ref = NULL;
e->ts.type = BT_CHARACTER;
e->ts.kind = kind;
+ e->ts.is_c_interop = 0;
+ e->ts.is_iso_c = 0;
e->where = start_locus;
- e->value.character.string = p = gfc_getmem (length + 1);
+ e->value.character.string = p = gfc_get_wide_string (length + 1);
e->value.character.length = length;
gfc_current_locus = start_locus;
gfc_option.warn_ampersand = 0;
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)
{
- 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;
e->value.logical = i;
e->ts.type = BT_LOGICAL;
e->ts.kind = kind;
+ e->ts.is_c_interop = 0;
+ e->ts.is_iso_c = 0;
e->where = gfc_current_locus;
*result = e;
{
/* 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);
gfc_symtree *symtree;
locus where, w;
gfc_expr *e;
- int c;
+ char c;
where = gfc_current_locus;
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 != ')')
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 ((equiv_flag && gfc_peek_ascii_char () == '(') || sym->attr.dimension)
{
/* In EQUIVALENCE, we don't know yet whether we are seeing
an array, character variable or array of character
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;
}
check_substring:
+ unknown = false;
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;
+ unknown = true;
}
}
break;
case MATCH_NO:
+ if (unknown)
+ gfc_clear_ts (&primary->ts);
break;
case MATCH_ERROR:
/* Match a structure constructor. The initial symbol has already been
seen. */
+typedef struct gfc_structure_ctor_component
+{
+ char* name;
+ gfc_expr* val;
+ locus where;
+ struct gfc_structure_ctor_component* next;
+}
+gfc_structure_ctor_component;
+
+#define gfc_get_structure_ctor_component() XCNEW (gfc_structure_ctor_component)
+
+static void
+gfc_free_structure_ctor_component (gfc_structure_ctor_component *comp)
+{
+ gfc_free (comp->name);
+ gfc_free_expr (comp->val);
+}
+
match
gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result)
{
- gfc_constructor *head, *tail;
- gfc_component *comp;
+ gfc_structure_ctor_component *comp_head, *comp_tail;
+ gfc_structure_ctor_component *comp_iter;
+ gfc_constructor *ctor_head, *ctor_tail;
+ gfc_component *comp; /* Is set NULL when named component is first seen */
gfc_expr *e;
locus where;
match m;
+ const char* last_name = NULL;
- head = tail = NULL;
+ comp_head = comp_tail = NULL;
+ ctor_head = ctor_tail = NULL;
if (gfc_match_char ('(') != MATCH_YES)
goto syntax;
gfc_find_component (sym, NULL);
- for (comp = sym->components; comp; comp = comp->next)
+ /* 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)
{
- if (head == NULL)
- tail = head = gfc_get_constructor ();
- else
+ comp = sym->components;
+ do
{
- tail->next = gfc_get_constructor ();
- tail = tail->next;
+ 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
+ gfc_error ("Too many components in structure constructor at"
+ " %C!");
+ goto cleanup;
+ }
+
+ gfc_current_locus = comp_tail->where;
+ strncpy (comp_tail->name, comp->name, GFC_MAX_SYMBOL_LEN + 1);
+ }
+
+ /* Find the current component in the structure definition; this is
+ needed to get its access attribute in the private check below. */
+ if (comp)
+ this_comp = comp;
+ else
+ {
+ for (comp = sym->components; comp; comp = comp->next)
+ if (!strcmp (comp->name, comp_tail->name))
+ {
+ this_comp = comp;
+ break;
+ }
+ 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)
+ {
+ gfc_error ("Component '%s' in structure constructor at %C"
+ " does not correspond to any component in the"
+ " constructed structure!", comp_tail->name);
+ goto cleanup;
+ }
+ }
+ gcc_assert (this_comp);
+
+ /* Check the current component's access status. */
+ if (sym->attr.use_assoc && this_comp->access == ACCESS_PRIVATE)
+ {
+ gfc_error ("Component '%s' is PRIVATE in structure constructor"
+ " at %C!", comp_tail->name);
+ goto cleanup;
+ }
+
+ /* Check if this component is already given a value. */
+ for (comp_iter = comp_head; comp_iter != comp_tail;
+ comp_iter = comp_iter->next)
+ {
+ 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;
+
+ if (comp)
+ comp = comp->next;
}
+ while (gfc_match_char (',') == MATCH_YES);
- m = gfc_match_expr (&tail->expr);
- if (m == MATCH_NO)
+ if (gfc_match_char (')') != MATCH_YES)
goto syntax;
- if (m == MATCH_ERROR)
- goto cleanup;
+
+ /* If there were components given and all components are private, error
+ out at this place. */
+ if (sym->attr.use_assoc && sym->component_access == ACCESS_PRIVATE)
+ {
+ gfc_error ("All components of '%s' are PRIVATE in structure"
+ " constructor at %C", sym->name);
+ goto cleanup;
+ }
+ }
+
+ /* 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. */
+ for (comp = sym->components; comp; comp = comp->next)
+ {
+ 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)
+ {
+ if (!strcmp (comp_iter->name, comp->name))
+ break;
+ next_ptr = &comp_iter->next;
+ }
- if (gfc_match_char (',') == MATCH_YES)
+ /* If it was not found, try the default initializer if there's any;
+ otherwise, it's an error. */
+ if (!comp_iter)
{
- if (comp->next == NULL)
+ if (comp->initializer)
{
- gfc_error ("Too many components in structure constructor at %C");
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure"
+ " constructor with missing optional arguments"
+ " at %C") == FAILURE)
+ goto cleanup;
+ value = gfc_copy_expr (comp->initializer);
+ }
+ else
+ {
+ gfc_error ("No initializer for component '%s' given in the"
+ " structure constructor at %C!", comp->name);
goto cleanup;
}
+ }
+ else
+ value = comp_iter->val;
- continue;
+ /* Add the value to the constructor chain built. */
+ if (ctor_tail)
+ {
+ ctor_tail->next = gfc_get_constructor ();
+ ctor_tail = ctor_tail->next;
}
+ else
+ ctor_head = ctor_tail = gfc_get_constructor ();
+ gcc_assert (value);
+ ctor_tail->expr = value;
- break;
+ /* 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);
+ }
}
- if (gfc_match_char (')') != MATCH_YES)
- goto syntax;
-
- if (comp->next != NULL)
- {
- gfc_error ("Too few components in structure constructor at %C");
- 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). */
+ gcc_assert (!comp_head);
e = gfc_get_expr ();
e->ts.derived = sym;
e->where = where;
- e->value.constructor = head;
+ 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_free_constructor (ctor_head);
return MATCH_ERROR;
}
int i;
gfc_typespec *ts;
bool implicit_char;
+ gfc_ref *ref;
m = gfc_match_name (name);
if (m != MATCH_YES)
/* 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_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 () == '%'
+ if (sym->ts.type == BT_UNKNOWN && gfc_peek_ascii_char () == '%'
&& gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
gfc_set_default_type (sym, 0, sym->ns);
e->symtree = symtree;
m = match_varspec (e, 0);
+
+ 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 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.function && gfc_peek_ascii_char () == '(')
+ /* Parse functions returning a procptr. */
+ goto function0;
+
+ if (sym->attr.flavor == FL_UNKNOWN) sym->attr.flavor = FL_PROCEDURE;
+ if (gfc_intrinsic_name (sym->name, 0)
+ || gfc_intrinsic_name (sym->name, 1))
+ sym->attr.intrinsic = 1;
+ e = gfc_get_expr ();
+ e->expr_type = EXPR_VARIABLE;
+ e->symtree = symtree;
+ m = match_varspec (e, 0);
+ break;
+ }
+
if (sym->attr.subroutine)
{
gfc_error ("Unexpected use of subroutine name '%s' at %C",
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;
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_set_default_type (sym, 0, sym->ns);
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 ();
}
-/* Match a variable, ie something that can be assigned to. This
+/* Match a variable, i.e. something that can be assigned to. This
starts as a symbol, can be a structure component or an array
reference. It can be a function if the function doesn't have a
separate RESULT variable. If the symbol has not been previously
we force the changed_symbols mechanism to work by setting
host_flag to 0. This prevents valid symbols that have the name
of keywords, such as 'end', being turned into variables by
- failed matching to assignments for, eg., END INTERFACE. */
+ failed matching to assignments for, e.g., END INTERFACE. */
if (gfc_current_state () == COMP_MODULE
|| gfc_current_state () == COMP_INTERFACE
|| gfc_current_state () == COMP_CONTAINS)
switch (sym->attr.flavor)
{
case FL_VARIABLE:
- if (sym->attr.protected && sym->attr.use_assoc)
+ if (sym->attr.is_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,
- 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)
- && !sym->attr.external)
+ /* Check for a nonrecursive function result variable. */
+ if (sym->attr.function
+ && !sym->attr.external
+ && sym->result == sym
+ && ((sym == gfc_current_ns->proc_name
+ && sym == gfc_current_ns->proc_name->result)
+ || (gfc_current_ns->parent
+ && sym == gfc_current_ns->parent->proc_name->result)
+ || (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. */
break;
}
+ if (sym->attr.proc_pointer)
+ 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_set_default_type (sym, 0, implicit_ns);