/* Primary expression subroutines
- Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009, 2010
- Free Software Foundation, Inc.
+ Copyright (C) 2000-2016 Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
#include "config.h"
#include "system.h"
-#include "flags.h"
+#include "coretypes.h"
+#include "options.h"
#include "gfortran.h"
#include "arith.h"
#include "match.h"
#include "parse.h"
#include "constructor.h"
+int matching_actual_arglist = 0;
+
/* Matches a kind-parameter expression, which is either a named
symbolic constant or a nonnegative integer constant. If
- successful, sets the kind value to the correct integer. */
+ successful, sets the kind value to the correct integer.
+ The argument 'is_iso_c' signals whether the kind is an ISO_C_BINDING
+ symbol like e.g. 'c_int'. */
static match
-match_kind_param (int *kind)
+match_kind_param (int *kind, int *is_iso_c)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_symbol *sym;
const char *p;
match m;
+ *is_iso_c = 0;
+
m = gfc_match_small_literal_int (kind, NULL);
if (m != MATCH_NO)
return m;
if (sym == NULL)
return MATCH_NO;
+ *is_iso_c = sym->attr.is_iso_c;
+
if (sym->attr.flavor != FL_PARAMETER)
return MATCH_NO;
/* Get a trailing kind-specification for non-character variables.
Returns:
- the integer kind value or:
- -1 if an error was generated
- -2 if no kind was found */
+ * the integer kind value or
+ * -1 if an error was generated,
+ * -2 if no kind was found.
+ The argument 'is_iso_c' signals whether the kind is an ISO_C_BINDING
+ symbol like e.g. 'c_int'. */
static int
-get_kind (void)
+get_kind (int *is_iso_c)
{
int kind;
match m;
+ *is_iso_c = 0;
+
if (gfc_match_char ('_') != MATCH_YES)
return -2;
- m = match_kind_param (&kind);
+ m = match_kind_param (&kind, is_iso_c);
if (m == MATCH_NO)
gfc_error ("Missing kind-parameter at %C");
/* Match the digit string part of an integer if signflag is not set,
- the signed digit string part if signflag is set. If the buffer
- is NULL, we just count characters for the resolution pass. Returns
+ the signed digit string part if signflag is set. If the buffer
+ is NULL, we just count characters for the resolution pass. Returns
the number of characters matched, -1 for no match. */
static int
}
-/* Match an integer (digit string and optional kind).
+/* Match an integer (digit string and optional kind).
A sign will be accepted if signflag is set. */
static match
match_integer_constant (gfc_expr **result, int signflag)
{
- int length, kind;
+ int length, kind, is_iso_c;
locus old_loc;
char *buffer;
gfc_expr *e;
match_digits (signflag, 10, buffer);
- kind = get_kind ();
+ kind = get_kind (&is_iso_c);
if (kind == -2)
kind = gfc_default_integer_kind;
if (kind == -1)
return MATCH_ERROR;
+ if (kind == 4 && flag_integer4_kind == 8)
+ kind = 8;
+
if (gfc_validate_kind (BT_INTEGER, kind, true) < 0)
{
gfc_error ("Integer kind %d at %C not available", kind);
}
e = gfc_convert_integer (buffer, kind, 10, &gfc_current_locus);
+ e->ts.is_c_interop = is_iso_c;
if (gfc_range_check (e) != ARITH_OK)
{
locus old_loc;
gfc_expr *e = NULL;
const char *msg;
- int num;
- int i;
+ 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)
{
- if (gfc_notify_std (GFC_STD_LEGACY, "Extension: Hollerith constant "
- "at %C") == FAILURE)
+ if (!gfc_notify_std (GFC_STD_LEGACY, "Hollerith constant at %C"))
goto cleanup;
msg = gfc_extract_int (e, &num);
e = gfc_get_constant_expr (BT_HOLLERITH, gfc_default_character_kind,
&gfc_current_locus);
- e->representation.string = XCNEWVEC (char, num + 1);
+ /* 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++)
{
- gfc_char_t c = gfc_next_char_literal (1);
+ gfc_char_t c = gfc_next_char_literal (INSTRING_WARN);
if (! gfc_wide_fits_in_byte (c))
{
gfc_error ("Invalid Hollerith constant at %L contains a "
e->representation.string[i] = (unsigned char) c;
}
- e->representation.string[num] = '\0';
- e->representation.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;
goto backup;
if (x_hex
- && (gfc_notify_std (GFC_STD_GNU, "Extension: Hexadecimal "
- "constant at %C uses non-standard syntax")
- == FAILURE))
+ && (!gfc_notify_std(GFC_STD_GNU, "Hexadecimal "
+ "constant at %C uses non-standard syntax")))
return MATCH_ERROR;
old_loc = gfc_current_locus;
goto backup;
}
- if (gfc_notify_std (GFC_STD_GNU, "Extension: BOZ constant "
- "at %C uses non-standard postfix syntax")
- == FAILURE)
+ if (!gfc_notify_std (GFC_STD_GNU, "BOZ constant "
+ "at %C uses non-standard postfix syntax"))
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))
+ && (!gfc_notify_std(GFC_STD_F2003, "BOZ used outside a DATA "
+ "statement at %C")))
return MATCH_ERROR;
*result = e;
static match
match_real_constant (gfc_expr **result, int signflag)
{
- int kind, count, seen_dp, seen_digits;
+ int kind, count, seen_dp, seen_digits, is_iso_c;
locus old_loc, temp_loc;
char *p, *buffer, c, exp_char;
gfc_expr *e;
if (seen_dp)
goto done;
- /* Check to see if "." goes with a following operator like
+ /* Check to see if "." goes with a following operator like
".eq.". */
temp_loc = gfc_current_locus;
c = gfc_next_ascii_char ();
goto done;
exp_char = c;
+
+ if (c == 'q')
+ {
+ if (!gfc_notify_std (GFC_STD_GNU, "exponent-letter 'q' in "
+ "real-literal-constant at %C"))
+ return MATCH_ERROR;
+ else if (warn_real_q_constant)
+ gfc_warning (OPT_Wreal_q_constant,
+ "Extension: exponent-letter %<q%> in real-literal-constant "
+ "at %C");
+ }
+
/* Scan exponent. */
c = gfc_next_ascii_char ();
count++;
c = gfc_next_ascii_char ();
}
- kind = get_kind ();
+ kind = get_kind (&is_iso_c);
if (kind == -1)
goto cleanup;
case 'd':
if (kind != -2)
{
- gfc_error ("Real number at %C has a 'd' exponent and an explicit "
+ gfc_error ("Real number at %C has a %<d%> exponent and an explicit "
"kind");
goto cleanup;
}
kind = gfc_default_double_kind;
+
+ if (kind == 4)
+ {
+ if (flag_real4_kind == 8)
+ kind = 8;
+ if (flag_real4_kind == 10)
+ kind = 10;
+ if (flag_real4_kind == 16)
+ kind = 16;
+ }
+
+ if (kind == 8)
+ {
+ if (flag_real8_kind == 4)
+ kind = 4;
+ if (flag_real8_kind == 10)
+ kind = 10;
+ if (flag_real8_kind == 16)
+ kind = 16;
+ }
+ break;
+
+ case 'q':
+ if (kind != -2)
+ {
+ gfc_error ("Real number at %C has a %<q%> exponent and an explicit "
+ "kind");
+ goto cleanup;
+ }
+
+ /* The maximum possible real kind type parameter is 16. First, try
+ that for the kind, then fallback to trying kind=10 (Intel 80 bit)
+ extended precision. If neither value works, just given up. */
+ kind = 16;
+ if (gfc_validate_kind (BT_REAL, kind, true) < 0)
+ {
+ kind = 10;
+ if (gfc_validate_kind (BT_REAL, kind, true) < 0)
+ {
+ gfc_error ("Invalid exponent-letter %<q%> in "
+ "real-literal-constant at %C");
+ goto cleanup;
+ }
+ }
break;
default:
if (kind == -2)
kind = gfc_default_real_kind;
+ if (kind == 4)
+ {
+ if (flag_real4_kind == 8)
+ kind = 8;
+ if (flag_real4_kind == 10)
+ kind = 10;
+ if (flag_real4_kind == 16)
+ kind = 16;
+ }
+
+ if (kind == 8)
+ {
+ if (flag_real8_kind == 4)
+ kind = 4;
+ if (flag_real8_kind == 10)
+ kind = 10;
+ if (flag_real8_kind == 16)
+ kind = 16;
+ }
+
if (gfc_validate_kind (BT_REAL, kind, true) < 0)
{
gfc_error ("Invalid real kind %d at %C", kind);
e = gfc_convert_real (buffer, kind, &gfc_current_locus);
if (negate)
mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE);
+ e->ts.is_c_interop = is_iso_c;
switch (gfc_range_check (e))
{
goto cleanup;
case ARITH_UNDERFLOW:
- if (gfc_option.warn_underflow)
- gfc_warning ("Real constant underflows its kind at %C");
+ if (warn_underflow)
+ gfc_warning (OPT_Wunderflow, "Real constant underflows its kind at %C");
mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
break;
gfc_internal_error ("gfc_range_check() returned bad value");
}
+ /* Warn about trailing digits which suggest the user added too many
+ trailing digits, which may cause the appearance of higher pecision
+ than the kind kan support.
+
+ This is done by replacing the rightmost non-zero digit with zero
+ and comparing with the original value. If these are equal, we
+ assume the user supplied more digits than intended (or forgot to
+ convert to the correct kind).
+ */
+
+ if (warn_conversion_extra)
+ {
+ mpfr_t r;
+ char *c, *p;
+ bool did_break;
+
+ c = strchr (buffer, 'e');
+ if (c == NULL)
+ c = buffer + strlen(buffer);
+
+ did_break = false;
+ for (p = c - 1; p >= buffer; p--)
+ {
+ if (*p == '.')
+ continue;
+
+ if (*p != '0')
+ {
+ *p = '0';
+ did_break = true;
+ break;
+ }
+ }
+
+ if (did_break)
+ {
+ mpfr_init (r);
+ mpfr_set_str (r, buffer, 10, GFC_RND_MODE);
+ if (negate)
+ mpfr_neg (r, r, GFC_RND_MODE);
+
+ mpfr_sub (r, r, e->value.real, GFC_RND_MODE);
+
+ if (mpfr_cmp_ui (r, 0) == 0)
+ gfc_warning (OPT_Wconversion_extra, "Non-significant digits "
+ "in %qs number at %C, maybe incorrect KIND",
+ gfc_typename (&e->ts));
+
+ mpfr_clear (r);
+ }
+ }
+
*result = e;
return MATCH_YES;
/* 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, bool deferred)
{
gfc_expr *start, *end;
locus old_loc;
}
/* Optimize away the (:) reference. */
- if (start == NULL && end == NULL)
+ if (start == NULL && end == NULL && !deferred)
ref = NULL;
else
{
locus old_locus;
gfc_char_t c;
- c = gfc_next_char_literal (1);
+ c = gfc_next_char_literal (INSTRING_WARN);
*ret = 0;
if (c == '\n')
return 0;
}
- if (gfc_option.flag_backslash && c == '\\')
+ if (flag_backslash && c == '\\')
{
old_locus = gfc_current_locus;
gfc_current_locus = old_locus;
if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings)
- gfc_warning ("Extension: backslash character at %C");
+ gfc_warning (0, "Extension: backslash character at %C");
}
if (c != delimiter)
return c;
old_locus = gfc_current_locus;
- c = gfc_next_char_literal (0);
+ c = gfc_next_char_literal (NONSTRING);
if (c == delimiter)
return c;
if (!ISALNUM (c)
&& c != '_'
- && (c != '$' || !gfc_option.flag_dollar_ok))
+ && (c != '$' || !flag_dollar_ok))
break;
*name++ = c;
match_string_constant (gfc_expr **result)
{
char name[GFC_MAX_SYMBOL_LEN + 1], peek;
- int i, kind, length, warn_ampersand, ret;
+ int i, kind, length, save_warn_ampersand, ret;
locus old_locus, start_locus;
gfc_symbol *sym;
gfc_expr *e;
goto no_match;
e = gfc_get_character_expr (kind, &start_locus, NULL, length);
- e->ref = NULL;
- e->ts.is_c_interop = 0;
- e->ts.is_iso_c = 0;
gfc_current_locus = start_locus;
/* 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;
+ save_warn_ampersand = warn_ampersand;
+ warn_ampersand = false;
p = e->value.character.string;
for (i = 0; i < length; i++)
if (!gfc_check_character_range (c, kind))
{
- gfc_error ("Character '%s' in string at %C is not representable "
+ gfc_free_expr (e);
+ gfc_error ("Character %qs in string at %C is not representable "
"in character kind %d", gfc_print_wide_char (c), kind);
return MATCH_ERROR;
}
}
*p = '\0'; /* TODO: C-style string is for development/debug purposes. */
- gfc_option.warn_ampersand = warn_ampersand;
+ warn_ampersand = save_warn_ampersand;
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)
+ if (match_substring (NULL, 0, &e->ref, false) != MATCH_NO)
e->expr_type = EXPR_SUBSTRING;
*result = e;
match_logical_constant (gfc_expr **result)
{
gfc_expr *e;
- int i, kind;
+ int i, kind, is_iso_c;
i = match_logical_constant_string ();
if (i == -1)
return MATCH_NO;
- kind = get_kind ();
+ kind = get_kind (&is_iso_c);
if (kind == -1)
return MATCH_ERROR;
if (kind == -2)
}
e = gfc_get_logical_expr (kind, &gfc_current_locus, i);
- e->ts.is_c_interop = 0;
- e->ts.is_iso_c = 0;
+ e->ts.is_c_interop = is_iso_c;
*result = e;
return MATCH_YES;
return MATCH_ERROR;
}
+ if (!sym->value)
+ goto error;
+
if (!gfc_numeric_ts (&sym->value->ts))
{
gfc_error ("Numeric PARAMETER required in complex constant at %C");
return MATCH_ERROR;
}
- if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PARAMETER symbol in "
- "complex constant at %C") == FAILURE)
+ if (!gfc_notify_std (GFC_STD_F2003, "PARAMETER symbol in "
+ "complex constant at %C"))
return MATCH_ERROR;
switch (sym->value->ts.type)
match_complex_constant (gfc_expr **result)
{
gfc_expr *e, *real, *imag;
- gfc_error_buf old_error;
+ gfc_error_buffer old_error;
gfc_typespec target;
locus old_loc;
int kind;
else
kind = gfc_default_real_kind;
}
+ gfc_clear_ts (&target);
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);
sym = symtree->n.sym;
gfc_set_sym_referenced (sym);
+ if (sym->attr.flavor == FL_NAMELIST)
+ {
+ gfc_error ("Namelist '%s' can not be an argument at %L",
+ sym->name, &where);
+ break;
+ }
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);
+ if (!gfc_add_flavor (&sym->attr, FL_VARIABLE,
+ sym->name, &sym->declared_at))
+ return MATCH_ERROR;
break;
}
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 "
+ gfc_error ("Keyword %qs at %C has already appeared in the "
"current argument list", name);
return MATCH_ERROR;
}
result->name = "%LOC";
break;
}
+ /* FALLTHRU */
case 'r':
if (strncmp (name, "ref", 3) == 0)
{
result->name = "%REF";
break;
}
+ /* FALLTHRU */
case 'v':
if (strncmp (name, "val", 3) == 0)
{
result->name = "%VAL";
break;
}
+ /* FALLTHRU */
default:
m = MATCH_ERROR;
goto cleanup;
}
}
- if (gfc_notify_std (GFC_STD_GNU, "Extension: argument list "
- "function at %C") == FAILURE)
+ if (!gfc_notify_std (GFC_STD_GNU, "argument list function at %C"))
{
m = MATCH_ERROR;
goto cleanup;
return MATCH_YES;
head = NULL;
+ matching_actual_arglist++;
+
for (;;)
{
if (head == NULL)
if (m != MATCH_YES)
goto cleanup;
+ if (!gfc_notify_std (GFC_STD_F95_OBS, "Alternate-return argument "
+ "at %C"))
+ goto cleanup;
+
tail->label = label;
goto next;
}
}
*argp = head;
+ matching_actual_arglist--;
return MATCH_YES;
syntax:
cleanup:
gfc_free_actual_arglist (head);
gfc_current_locus = old_loc;
-
+ matching_actual_arglist--;
return MATCH_ERROR;
}
bool ppc_arg)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
- gfc_ref *substring, *tail;
+ gfc_ref *substring, *tail, *tmp;
gfc_component *component;
gfc_symbol *sym = primary->symtree->n.sym;
match m;
bool unknown;
+ char sep;
tail = NULL;
if (gfc_peek_ascii_char () == '[')
{
- if (sym->attr.dimension)
+ if ((sym->ts.type != BT_CLASS && sym->attr.dimension)
+ || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
+ && CLASS_DATA (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)
+ if ((sym->ts.type != BT_CLASS && !sym->attr.codimension)
+ || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
+ && !CLASS_DATA (sym)->attr.codimension))
{
- gfc_error ("Coarray designator at %C but '%s' is not a coarray",
+ gfc_error ("Coarray designator at %C but %qs is not a coarray",
sym->name);
return MATCH_ERROR;
}
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 () == '(')
+ if (sym->assoc && gfc_peek_ascii_char () == '('
+ && !(sym->assoc->dangling && sym->assoc->st
+ && sym->assoc->st->n.sym
+ && sym->assoc->st->n.sym->attr.dimension == 0)
+ && sym->ts.type != BT_CLASS)
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)
+ || (sym->attr.dimension && sym->ts.type != BT_CLASS
+ && !sym->attr.proc_pointer && !gfc_is_proc_ptr_comp (primary)
&& !(gfc_matching_procptr_assignment
&& sym->attr.flavor == FL_PROCEDURE))
- || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.dimension))
+ || (sym->ts.type == BT_CLASS && sym->attr.class_ok
+ && (CLASS_DATA (sym)->attr.dimension
+ || CLASS_DATA (sym)->attr.codimension)))
{
+ gfc_array_spec *as;
+
+ tail = extend_ref (primary, tail);
+ tail->type = REF_ARRAY;
+
/* 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, equiv_flag ? NULL : sym->as,
- equiv_flag, sym->as ? sym->as->corank : 0);
+ if (equiv_flag)
+ as = NULL;
+ else if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
+ as = CLASS_DATA (sym)->as;
+ else
+ as = sym->as;
+
+ m = gfc_match_array_ref (&tail->u.ar, as, equiv_flag,
+ as ? as->corank : 0);
if (m != MATCH_YES)
return m;
if (equiv_flag)
return MATCH_YES;
- if (sym->ts.type == BT_UNKNOWN && gfc_peek_ascii_char () == '%'
+ /* With DEC extensions, member separator may be '.' or '%'. */
+ sep = gfc_peek_ascii_char ();
+ m = gfc_match_member_sep (sym);
+ if (m == MATCH_ERROR)
+ return MATCH_ERROR;
+
+ if (sym->ts.type == BT_UNKNOWN && m == MATCH_YES
&& gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
gfc_set_default_type (sym, 0, sym->ns);
+ if (sym->ts.type == BT_UNKNOWN && m == MATCH_YES)
+ {
+ gfc_error ("Symbol %qs at %C has no IMPLICIT type", sym->name);
+ return MATCH_ERROR;
+ }
+ else if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
+ && m == MATCH_YES)
+ {
+ gfc_error ("Unexpected %<%c%> for nonderived-type variable %qs at %C",
+ sep, sym->name);
+ return MATCH_ERROR;
+ }
+
if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
- || gfc_match_char ('%') != MATCH_YES)
+ || m != MATCH_YES)
goto check_substring;
sym = sym->ts.u.derived;
for (;;)
{
- gfc_try t;
+ bool t;
gfc_symtree *tbp;
m = gfc_match_name (name);
{
gfc_symbol* tbp_sym;
- if (t == FAILURE)
+ if (!t)
return MATCH_ERROR;
gcc_assert (!tail || !tail->next);
- gcc_assert (primary->expr_type == EXPR_VARIABLE);
+
+ if (!(primary->expr_type == EXPR_VARIABLE
+ || (primary->expr_type == EXPR_STRUCTURE
+ && primary->symtree && primary->symtree->n.sym
+ && primary->symtree->n.sym->attr.flavor)))
+ return MATCH_ERROR;
if (tbp->n.tb->is_generic)
tbp_sym = NULL;
gcc_assert (primary->symtree->n.sym->attr.referenced);
if (tbp_sym)
primary->ts = tbp_sym->ts;
+ else
+ gfc_clear_ts (&primary->ts);
m = gfc_match_actual_arglist (tbp->n.tb->subroutine,
&primary->value.compcall.actual);
break;
}
- component = gfc_find_component (sym, name, false, false);
+ component = gfc_find_component (sym, name, false, false, &tmp);
if (component == NULL)
return MATCH_ERROR;
- tail = extend_ref (primary, tail);
- tail->type = REF_COMPONENT;
+ /* Extend the reference chain determined by gfc_find_component. */
+ if (primary->ref == NULL)
+ primary->ref = tmp;
+ else
+ {
+ /* Set by the for loop below for the last component ref. */
+ gcc_assert (tail != NULL);
+ tail->next = tmp;
+ }
- tail->u.c.component = component;
- tail->u.c.sym = sym;
+ /* The reference chain may be longer than one hop for union
+ subcomponents; find the new tail. */
+ for (tail = tmp; tail->next; tail = tail->next)
+ ;
primary->ts = component->ts;
- if (component->attr.proc_pointer && ppc_arg
- && !gfc_matching_procptr_assignment)
+ if (component->attr.proc_pointer && ppc_arg)
{
+ /* Procedure pointer component call: Look for argument list. */
m = gfc_match_actual_arglist (sub_flag,
&primary->value.compcall.actual);
if (m == MATCH_ERROR)
return MATCH_ERROR;
+
+ if (m == MATCH_NO && !gfc_matching_ptr_assignment
+ && !gfc_matching_procptr_assignment && !matching_actual_arglist)
+ {
+ gfc_error ("Procedure pointer component %qs requires an "
+ "argument list at %C", component->name);
+ return MATCH_ERROR;
+ }
+
if (m == MATCH_YES)
primary->expr_type = EXPR_PPC;
if (m != MATCH_YES)
return m;
}
- else if (component->ts.type == BT_CLASS
- && CLASS_DATA (component)->as != NULL
- && !component->attr.proc_pointer)
+ else if (component->ts.type == BT_CLASS && component->attr.class_ok
+ && CLASS_DATA (component)->as && !component->attr.proc_pointer)
{
tail = extend_ref (primary, tail);
tail->type = REF_ARRAY;
}
if ((component->ts.type != BT_DERIVED && component->ts.type != BT_CLASS)
- || gfc_match_char ('%') != MATCH_YES)
+ || gfc_match_member_sep (component->ts.u.derived) != MATCH_YES)
break;
sym = component->ts.u.derived;
check_substring:
unknown = false;
- if (primary->ts.type == BT_UNKNOWN && sym->attr.flavor != FL_DERIVED)
+ if (primary->ts.type == BT_UNKNOWN && !gfc_fl_struct (sym->attr.flavor))
{
if (gfc_get_default_type (sym->name, sym->ns)->type == BT_CHARACTER)
{
if (primary->ts.type == BT_CHARACTER)
{
- switch (match_substring (primary->ts.u.cl, equiv_flag, &substring))
+ bool def = primary->ts.deferred == 1;
+ switch (match_substring (primary->ts.u.cl, equiv_flag, &substring, def))
{
case MATCH_YES:
if (tail == NULL)
symbol_attribute
gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
{
- int dimension, pointer, allocatable, target;
+ int dimension, codimension, pointer, allocatable, target;
symbol_attribute attr;
gfc_ref *ref;
gfc_symbol *sym;
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;
sym = expr->symtree->n.sym;
attr = sym->attr;
- if (sym->ts.type == BT_CLASS)
+ if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
{
dimension = CLASS_DATA (sym)->attr.dimension;
+ codimension = CLASS_DATA (sym)->attr.codimension;
pointer = CLASS_DATA (sym)->attr.class_pointer;
allocatable = CLASS_DATA (sym)->attr.allocatable;
}
else
{
dimension = attr.dimension;
+ codimension = attr.codimension;
pointer = attr.pointer;
allocatable = attr.allocatable;
}
if (ts != NULL && expr->ts.type == BT_UNKNOWN)
*ts = sym->ts;
- for (; ref; ref = ref->next)
+ for (ref = expr->ref; ref; ref = ref->next)
switch (ref->type)
{
case REF_ARRAY:
break;
case AR_UNKNOWN:
- gfc_internal_error ("gfc_variable_attr(): Bad array reference");
+ /* If any of start, end or stride is not integer, there will
+ already have been an error issued. */
+ int errors;
+ gfc_get_errors (NULL, &errors);
+ if (errors == 0)
+ gfc_internal_error ("gfc_variable_attr(): Bad array reference");
}
break;
if (comp->ts.type == BT_CLASS)
{
+ codimension = CLASS_DATA (comp)->attr.codimension;
pointer = CLASS_DATA (comp)->attr.class_pointer;
allocatable = CLASS_DATA (comp)->attr.allocatable;
}
else
{
+ codimension = comp->attr.codimension;
pointer = comp->attr.pointer;
allocatable = comp->attr.allocatable;
}
}
attr.dimension = dimension;
+ attr.codimension = codimension;
attr.pointer = pointer;
attr.allocatable = allocatable;
attr.target = target;
+ attr.save = sym->attr.save;
return attr;
}
case EXPR_FUNCTION:
gfc_clear_attr (&attr);
- if (e->value.function.esym != NULL)
+ if (e->value.function.esym && e->value.function.esym->result)
{
gfc_symbol *sym = e->value.function.esym->result;
attr = sym->attr;
}
+/* Given an expression, figure out what the ultimate expression
+ attribute is. This routine is similar to gfc_variable_attr with
+ parts of gfc_expr_attr, but focuses more on the needs of
+ coarrays. For coarrays a codimension attribute is kind of
+ "infectious" being propagated once set and never cleared. */
+
+static symbol_attribute
+caf_variable_attr (gfc_expr *expr, bool in_allocate)
+{
+ int dimension, codimension, pointer, allocatable, target, coarray_comp,
+ alloc_comp;
+ symbol_attribute attr;
+ gfc_ref *ref;
+ gfc_symbol *sym;
+ gfc_component *comp;
+
+ if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION)
+ gfc_internal_error ("gfc_caf_attr(): Expression isn't a variable");
+
+ sym = expr->symtree->n.sym;
+ gfc_clear_attr (&attr);
+
+ if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
+ {
+ dimension = CLASS_DATA (sym)->attr.dimension;
+ codimension = CLASS_DATA (sym)->attr.codimension;
+ pointer = CLASS_DATA (sym)->attr.class_pointer;
+ allocatable = CLASS_DATA (sym)->attr.allocatable;
+ coarray_comp = CLASS_DATA (sym)->attr.coarray_comp;
+ alloc_comp = CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp;
+ }
+ else
+ {
+ dimension = sym->attr.dimension;
+ codimension = sym->attr.codimension;
+ pointer = sym->attr.pointer;
+ allocatable = sym->attr.allocatable;
+ coarray_comp = sym->attr.coarray_comp;
+ alloc_comp = sym->ts.type == BT_DERIVED
+ ? sym->ts.u.derived->attr.alloc_comp : 0;
+ }
+
+ target = attr.target;
+ if (pointer || attr.proc_pointer)
+ target = 1;
+
+ for (ref = expr->ref; ref; ref = ref->next)
+ switch (ref->type)
+ {
+ case REF_ARRAY:
+
+ switch (ref->u.ar.type)
+ {
+ case AR_FULL:
+ case AR_SECTION:
+ dimension = 1;
+ break;
+
+ case AR_ELEMENT:
+ /* Handle coarrays. */
+ if (ref->u.ar.dimen > 0 && !in_allocate)
+ allocatable = pointer = 0;
+ break;
+
+ case AR_UNKNOWN:
+ /* If any of start, end or stride is not integer, there will
+ already have been an error issued. */
+ int errors;
+ gfc_get_errors (NULL, &errors);
+ if (errors == 0)
+ gfc_internal_error ("gfc_caf_attr(): Bad array reference");
+ }
+
+ break;
+
+ case REF_COMPONENT:
+ comp = ref->u.c.component;
+
+ if (comp->ts.type == BT_CLASS)
+ {
+ codimension |= CLASS_DATA (comp)->attr.codimension;
+ pointer = CLASS_DATA (comp)->attr.class_pointer;
+ allocatable = CLASS_DATA (comp)->attr.allocatable;
+ coarray_comp |= CLASS_DATA (comp)->attr.coarray_comp;
+ }
+ else
+ {
+ codimension |= comp->attr.codimension;
+ pointer = comp->attr.pointer;
+ allocatable = comp->attr.allocatable;
+ coarray_comp |= comp->attr.coarray_comp;
+ }
+
+ if (pointer || attr.proc_pointer)
+ target = 1;
+
+ break;
+
+ case REF_SUBSTRING:
+ allocatable = pointer = 0;
+ break;
+ }
+
+ attr.dimension = dimension;
+ attr.codimension = codimension;
+ attr.pointer = pointer;
+ attr.allocatable = allocatable;
+ attr.target = target;
+ attr.save = sym->attr.save;
+ attr.coarray_comp = coarray_comp;
+ attr.alloc_comp = alloc_comp;
+
+ return attr;
+}
+
+
+symbol_attribute
+gfc_caf_attr (gfc_expr *e, bool in_allocate)
+{
+ symbol_attribute attr;
+
+ switch (e->expr_type)
+ {
+ case EXPR_VARIABLE:
+ attr = caf_variable_attr (e, in_allocate);
+ break;
+
+ case EXPR_FUNCTION:
+ gfc_clear_attr (&attr);
+
+ if (e->value.function.esym && e->value.function.esym->result)
+ {
+ 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;
+ attr.alloc_comp = CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp;
+ }
+ }
+ else if (e->symtree)
+ attr = caf_variable_attr (e, in_allocate);
+ else
+ gfc_clear_attr (&attr);
+ break;
+
+ default:
+ gfc_clear_attr (&attr);
+ break;
+ }
+
+ return attr;
+}
+
+
/* Match a structure constructor. The initial symbol has already been
seen. */
static void
gfc_free_structure_ctor_component (gfc_structure_ctor_component *comp)
{
- gfc_free (comp->name);
+ free (comp->name);
gfc_free_expr (comp->val);
+ free (comp);
}
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
+static bool
build_actual_constructor (gfc_structure_ctor_component **comp_head,
gfc_constructor_base *ctor_head, gfc_symbol *sym)
{
&gfc_current_locus);
value->ts = comp->ts;
- if (build_actual_constructor (comp_head, &value->value.constructor,
- comp->ts.u.derived) == FAILURE)
+ if (!build_actual_constructor (comp_head,
+ &value->value.constructor,
+ comp->ts.u.derived))
{
gfc_free_expr (value);
- return FAILURE;
+ return false;
}
gfc_constructor_append_expr (ctor_head, value, NULL);
}
/* If it was not found, try the default initializer if there's any;
- otherwise, it's an error. */
+ otherwise, it's an error unless this is a deferred parameter. */
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;
+ if (!gfc_notify_std (GFC_STD_F2003, "Structure constructor "
+ "with missing optional arguments at %C"))
+ return false;
value = gfc_copy_expr (comp->initializer);
}
- else
+ else if (comp->attr.allocatable
+ || (comp->ts.type == BT_CLASS
+ && CLASS_DATA (comp)->attr.allocatable))
{
- gfc_error ("No initializer for component '%s' given in the"
+ if (!gfc_notify_std (GFC_STD_F2008, "No initializer for "
+ "allocatable component '%qs' given in the "
+ "structure constructor at %C", comp->name))
+ return false;
+ }
+ else if (!comp->attr.artificial)
+ {
+ gfc_error ("No initializer for component %qs given in the"
" structure constructor at %C!", comp->name);
- return FAILURE;
+ return false;
}
}
else
gfc_free_structure_ctor_component (comp_iter);
}
}
- return SUCCESS;
+ return true;
}
-match
-gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result,
- bool parent)
+
+bool
+gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **cexpr,
+ gfc_actual_arglist **arglist,
+ bool parent)
{
+ gfc_actual_arglist *actual;
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;
+ locus old_locus;
+ gfc_expr *expr;
- comp_tail = comp_head = NULL;
-
- if (!parent && gfc_match_char ('(') != MATCH_YES)
- goto syntax;
-
- where = gfc_current_locus;
+ expr = parent ? *cexpr : e;
+ old_locus = gfc_current_locus;
+ if (parent)
+ ; /* gfc_current_locus = *arglist->expr ? ->where;*/
+ else
+ gfc_current_locus = expr->where;
- gfc_find_component (sym, NULL, false, true);
+ comp_tail = comp_head = NULL;
- /* Check that we're not about to construct an ABSTRACT type. */
if (!parent && sym->attr.abstract)
{
- gfc_error ("Can't construct ABSTRACT type '%s' at %C", sym->name);
- return MATCH_ERROR;
+ gfc_error ("Can't construct ABSTRACT type %qs at %L",
+ sym->name, &expr->where);
+ goto cleanup;
}
- /* 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;
+ actual = parent ? *arglist : expr->value.function.actual;
+ for ( ; actual; )
{
- comp = sym->components;
- do
- {
- gfc_component *this_comp = NULL;
+ 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;
+ 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;
+ }
+ if (actual->name)
+ {
+ if (!gfc_notify_std (GFC_STD_F2003, "Structure"
+ " constructor with named arguments at %C"))
+ goto cleanup;
- /* Try matching a component name. */
- if (gfc_match_name (comp_tail->name) == MATCH_YES
- && gfc_match_char ('=') == MATCH_YES)
+ comp_tail->name = xstrdup (actual->name);
+ last_name = comp_tail->name;
+ comp = NULL;
+ }
+ else
+ {
+ /* Components without name are not allowed after the first named
+ component initializer! */
+ if (!comp || comp->attr.artificial)
{
- 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;
+ if (last_name)
+ gfc_error ("Component initializer without name after component"
+ " named %s at %L!", last_name,
+ actual->expr ? &actual->expr->where
+ : &gfc_current_locus);
+ else
+ gfc_error ("Too many components in structure constructor at "
+ "%L!", actual->expr ? &actual->expr->where
+ : &gfc_current_locus);
+ goto cleanup;
}
- 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;
- }
- gfc_current_locus = comp_tail->where;
- strncpy (comp_tail->name, comp->name, GFC_MAX_SYMBOL_LEN + 1);
- }
+ comp_tail->name = xstrdup (comp->name);
+ }
- /* Find the current component in the structure definition and check
+ /* 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;
+ if (comp)
+ this_comp = gfc_find_component (sym, comp->name, false, false, NULL);
+ else
+ {
+ this_comp = gfc_find_component (sym, (const char *)comp_tail->name,
+ false, false, NULL);
+ comp = NULL; /* Reset needed! */
+ }
- /* 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;
- }
- }
+ /* 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;
- /* Match the current initializer expression. */
- m = gfc_match_expr (&comp_tail->val);
- if (m == MATCH_NO)
- goto syntax;
- if (m == MATCH_ERROR)
- goto cleanup;
+ comp_tail->val = actual->expr;
+ if (actual->expr != NULL)
+ comp_tail->where = actual->expr->where;
+ actual->expr = NULL;
- /* F2008, R457/C725, for PURE C1283. */
- if (this_comp->attr.pointer && gfc_is_coindexed (comp_tail->val))
+ /* 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 ("Coindexed expression to pointer component '%s' in "
- "structure constructor at %C!", comp_tail->name);
+ gfc_error ("Component %qs is initialized twice in the structure"
+ " constructor at %L!", comp_tail->name,
+ comp_tail->val ? &comp_tail->where
+ : &gfc_current_locus);
goto cleanup;
- }
+ }
+ }
+ /* F2008, R457/C725, for PURE C1283. */
+ if (this_comp->attr.pointer && comp_tail->val
+ && gfc_is_coindexed (comp_tail->val))
+ {
+ gfc_error ("Coindexed expression to pointer component %qs in "
+ "structure constructor at %L!", comp_tail->name,
+ &comp_tail->where);
+ 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;
+ /* If not explicitly a parent constructor, gather up the components
+ and build one. */
+ if (comp && comp == sym->components
+ && sym->attr.extension
+ && comp_tail->val
+ && (!gfc_bt_struct (comp_tail->val->ts.type)
+ ||
+ comp_tail->val->ts.u.derived != this_comp->ts.u.derived))
+ {
+ bool m;
+ gfc_actual_arglist *arg_null = 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;
- }
+ actual->expr = comp_tail->val;
+ comp_tail->val = NULL;
- if (comp)
- comp = comp->next;
+ m = gfc_convert_to_structure_constructor (NULL,
+ comp->ts.u.derived, &comp_tail->val,
+ comp->ts.u.derived->attr.zero_comp
+ ? &arg_null : &actual, true);
+ if (!m)
+ goto cleanup;
- if (parent && !comp)
- break;
- }
+ if (comp->ts.u.derived->attr.zero_comp)
+ {
+ comp = comp->next;
+ continue;
+ }
+ }
- while (gfc_match_char (',') == MATCH_YES);
+ if (comp)
+ comp = comp->next;
+ if (parent && !comp)
+ break;
- if (!parent && gfc_match_char (')') != MATCH_YES)
- goto syntax;
+ if (actual)
+ actual = actual->next;
}
- if (build_actual_constructor (&comp_head, &ctor_head, sym) == FAILURE)
+ if (!build_actual_constructor (&comp_head, &ctor_head, sym))
goto cleanup;
/* No component should be left, as this should have caused an error in the
{
for (comp_iter = comp_head; comp_iter; comp_iter = comp_iter->next)
{
- gfc_error ("component '%s' at %L has already been set by a "
+ gfc_error ("component %qs at %L has already been set by a "
"parent derived type constructor", comp_iter->name,
&comp_iter->where);
}
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;
+ if (parent)
+ {
+ expr = gfc_get_structure_constructor_expr (BT_DERIVED, 0, &gfc_current_locus);
+ expr->ts.u.derived = sym;
+ expr->value.constructor = ctor_head;
+ *cexpr = expr;
+ }
+ else
+ {
+ expr->ts.u.derived = sym;
+ expr->ts.kind = 0;
+ expr->ts.type = BT_DERIVED;
+ expr->value.constructor = ctor_head;
+ expr->expr_type = EXPR_STRUCTURE;
+ }
- *result = e;
- return MATCH_YES;
+ gfc_current_locus = old_locus;
+ if (parent)
+ *arglist = actual;
+ return true;
-syntax:
- gfc_error ("Syntax error in structure constructor at %C");
+ cleanup:
+ gfc_current_locus = old_locus;
-cleanup:
for (comp_iter = comp_head; comp_iter; )
{
gfc_structure_ctor_component *next = comp_iter->next;
comp_iter = next;
}
gfc_constructor_free (ctor_head);
- return MATCH_ERROR;
+
+ return false;
+}
+
+
+match
+gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result)
+{
+ match m;
+ gfc_expr *e;
+ gfc_symtree *symtree;
+
+ gfc_get_ha_sym_tree (sym->name, &symtree);
+
+ e = gfc_get_expr ();
+ e->symtree = symtree;
+ e->expr_type = EXPR_FUNCTION;
+
+ gcc_assert (gfc_fl_struct (sym->attr.flavor)
+ && symtree->n.sym->attr.flavor == FL_PROCEDURE);
+ e->value.function.esym = sym;
+ e->symtree->n.sym->attr.generic = 1;
+
+ m = gfc_match_actual_arglist (0, &e->value.function.actual);
+ if (m != MATCH_YES)
+ {
+ gfc_free_expr (e);
+ return m;
+ }
+
+ if (!gfc_convert_to_structure_constructor (e, sym, NULL, NULL, false))
+ {
+ gfc_free_expr (e);
+ return MATCH_ERROR;
+ }
+
+ /* If a structure constructor is in a DATA statement, then each entity
+ in the structure constructor must be a constant. Try to reduce the
+ expression here. */
+ if (gfc_in_match_data ())
+ gfc_reduce_init_expr (e);
+
+ *result = e;
+ return MATCH_YES;
}
/* Procedure pointer as function result: Replace the function symbol by the
auto-generated hidden result variable named "ppr@". */
-static gfc_try
+static bool
replace_hidden_procptr_result (gfc_symbol **sym, gfc_symtree **st)
{
/* Check for procedure pointer 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 true;
}
- return FAILURE;
+ return false;
}
if (m != MATCH_YES)
return m;
- 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);
-
- if (i)
+ /* Check if the symbol exists. */
+ if (gfc_find_sym_tree (name, NULL, 1, &symtree))
return MATCH_ERROR;
+ /* If the symbol doesn't exist, create it unless the name matches a FL_STRUCT
+ type. For derived types we create a generic symbol which links to the
+ derived type symbol; STRUCTUREs are simpler and must not conflict with
+ variables. */
+ if (!symtree)
+ if (gfc_find_sym_tree (gfc_dt_upper_string (name), NULL, 1, &symtree))
+ return MATCH_ERROR;
+ if (!symtree || symtree->n.sym->attr.flavor != FL_STRUCT)
+ {
+ if (gfc_find_state (COMP_INTERFACE)
+ && !gfc_current_ns->has_import_set)
+ i = gfc_get_sym_tree (name, NULL, &symtree, false);
+ else
+ i = gfc_get_ha_sym_tree (name, &symtree);
+ if (i)
+ return MATCH_ERROR;
+ }
+
+
sym = symtree->n.sym;
e = NULL;
where = gfc_current_locus;
&& gfc_current_ns->proc_name == sym
&& !sym->attr.dimension)
{
- gfc_error ("'%s' at %C is the name of a recursive function "
+ gfc_error ("%qs 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);
|| 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;
case FL_PARAMETER:
/* A statement of the form "REAL, parameter :: a(0:10) = 1" will
- end up here. Unfortunately, sym->value->expr_type is set to
+ 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)
break;
+ case FL_STRUCT:
case FL_DERIVED:
sym = gfc_use_derived (sym);
if (sym == NULL)
m = MATCH_ERROR;
else
- m = gfc_match_structure_constructor (sym, &e, false);
+ goto generic_function;
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. */
+ /* Procedure Pointer Assignments. */
procptr0:
if (gfc_matching_procptr_assignment)
{
/* 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);
+ if (!e->ref && sym->attr.flavor == FL_UNKNOWN
+ && sym->ts.type == BT_UNKNOWN
+ && !gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL))
+ {
+ m = MATCH_ERROR;
+ break;
+ }
break;
}
if (sym->attr.subroutine)
{
- gfc_error ("Unexpected use of subroutine name '%s' at %C",
+ gfc_error ("Unexpected use of subroutine name %qs at %C",
sym->name);
m = MATCH_ERROR;
break;
st = gfc_enclosing_unit (NULL);
- if (st != NULL && st->state == COMP_FUNCTION
+ if (st != NULL
+ && st->state == COMP_FUNCTION
&& st->sym == sym
&& !sym->attr.recursive)
{
if (m == MATCH_NO)
{
if (sym->attr.proc == PROC_ST_FUNCTION)
- gfc_error ("Statement function '%s' requires argument list at %C",
+ gfc_error ("Statement function %qs requires argument list at %C",
sym->name);
else
- gfc_error ("Function '%s' requires an argument list at %C",
+ gfc_error ("Function %qs requires an argument list at %C",
sym->name);
m = MATCH_ERROR;
e->value.function.actual = actual_arglist;
e->where = gfc_current_locus;
- if (sym->as != NULL)
+ if (sym->ts.type == BT_CLASS && sym->attr.class_ok
+ && CLASS_DATA (sym)->as)
+ e->rank = CLASS_DATA (sym)->as->rank;
+ else if (sym->as != NULL)
e->rank = sym->as->rank;
if (!sym->attr.function
- && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
+ && !gfc_add_function (&sym->attr, sym->name, NULL))
{
m = MATCH_ERROR;
break;
/* make sure we were given a param */
if (actual_arglist == NULL)
{
- gfc_error ("Missing argument to '%s' at %C", sym->name);
+ gfc_error ("Missing argument to %qs at %C", sym->name);
m = MATCH_ERROR;
break;
}
via an IMPLICIT statement. This can't wait for the
resolution phase. */
- if (gfc_peek_ascii_char () == '%'
+ old_loc = gfc_current_locus;
+ if (gfc_match_member_sep (sym) == MATCH_YES
&& sym->ts.type == BT_UNKNOWN
&& gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
gfc_set_default_type (sym, 0, sym->ns);
+ gfc_current_locus = old_loc;
- /* If the symbol has a dimension attribute, the expression is a
+ /* If the symbol has a (co)dimension attribute, the expression is a
variable. */
- if (sym->attr.dimension)
+ if (sym->attr.dimension || sym->attr.codimension)
+ {
+ if (!gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, NULL))
+ {
+ m = MATCH_ERROR;
+ break;
+ }
+
+ e = gfc_get_expr ();
+ e->symtree = symtree;
+ e->expr_type = EXPR_VARIABLE;
+ m = gfc_match_varspec (e, 0, false, true);
+ break;
+ }
+
+ if (sym->ts.type == BT_CLASS && sym->attr.class_ok
+ && (CLASS_DATA (sym)->attr.dimension
+ || CLASS_DATA (sym)->attr.codimension))
{
- if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
- sym->name, NULL) == FAILURE)
+ if (!gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, NULL))
{
m = MATCH_ERROR;
break;
e->symtree = symtree;
e->expr_type = EXPR_VARIABLE;
- if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
- sym->name, NULL) == FAILURE)
+ if (!gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, NULL))
{
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
+ 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;
that we're not sure is a variable yet. */
if ((implicit_char || sym->ts.type == BT_CHARACTER)
- && match_substring (sym->ts.u.cl, 0, &e->ref) == MATCH_YES)
+ && match_substring (sym->ts.u.cl, 0, &e->ref, false) == MATCH_YES)
{
e->expr_type = EXPR_VARIABLE;
if (sym->attr.flavor != FL_VARIABLE
- && gfc_add_flavor (&sym->attr, FL_VARIABLE,
- sym->name, NULL) == FAILURE)
+ && !gfc_add_flavor (&sym->attr, FL_VARIABLE,
+ sym->name, NULL))
{
m = MATCH_ERROR;
break;
}
if (sym->ts.type == BT_UNKNOWN
- && gfc_set_default_type (sym, 1, NULL) == FAILURE)
+ && !gfc_set_default_type (sym, 1, NULL))
{
m = MATCH_ERROR;
break;
e->expr_type = EXPR_FUNCTION;
if (!sym->attr.function
- && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
+ && !gfc_add_function (&sym->attr, sym->name, NULL))
{
m = MATCH_ERROR;
break;
m = gfc_match_actual_arglist (0, &e->value.function.actual);
if (m == MATCH_NO)
- gfc_error ("Missing argument list in function '%s' at %C", sym->name);
+ gfc_error ("Missing argument list in function %qs at %C", sym->name);
if (m != MATCH_YES)
{
break;
generic_function:
- gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */
+ /* Look for symbol first; if not found, look for STRUCTURE type symbol
+ specially. Creates a generic symbol for derived types. */
+ gfc_find_sym_tree (name, NULL, 1, &symtree);
+ if (!symtree)
+ gfc_find_sym_tree (gfc_dt_upper_string (name), NULL, 1, &symtree);
+ if (!symtree || symtree->n.sym->attr.flavor != FL_STRUCT)
+ gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */
e = gfc_get_expr ();
e->symtree = symtree;
e->expr_type = EXPR_FUNCTION;
+ if (gfc_fl_struct (sym->attr.flavor))
+ {
+ e->value.function.esym = sym;
+ e->symtree->n.sym->attr.generic = 1;
+ }
+
m = gfc_match_actual_arglist (0, &e->value.function.actual);
break;
+ case FL_NAMELIST:
+ m = MATCH_ERROR;
+ break;
+
default:
gfc_error ("Symbol at %C is not appropriate for an expression");
return MATCH_ERROR;
static match
match_variable (gfc_expr **result, int equiv_flag, int host_flag)
{
- gfc_symbol *sym;
+ gfc_symbol *sym, *dt_sym;
gfc_symtree *st;
gfc_expr *expr;
- locus where;
+ locus where, old_loc;
match m;
/* Since nothing has any business being an lvalue in a module
of keywords, such as 'end', being turned into variables by
failed matching to assignments for, e.g., END INTERFACE. */
if (gfc_current_state () == COMP_MODULE
+ || gfc_current_state () == COMP_SUBMODULE
|| gfc_current_state () == COMP_INTERFACE
|| gfc_current_state () == COMP_CONTAINS)
host_flag = 0;
sym->attr.implied_index = 0;
gfc_set_sym_referenced (sym);
+
+ /* STRUCTUREs may share names with variables, but derived types may not. */
+ if (sym->attr.flavor == FL_PROCEDURE && sym->generic
+ && (dt_sym = gfc_find_dt_in_generic (sym)))
+ {
+ if (dt_sym->attr.flavor == FL_DERIVED)
+ gfc_error ("Derived type '%s' cannot be used as a variable at %C",
+ sym->name);
+ return MATCH_ERROR;
+ }
+
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)
- {
- gfc_error ("'%s' associated to expression can't appear in a variable"
- " definition context at %C", sym->name);
- return MATCH_ERROR;
- }
+ /* Everything is alright. */
break;
case FL_UNKNOWN:
flavor = FL_VARIABLE;
if (flavor != FL_UNKNOWN
- && gfc_add_flavor (&sym->attr, flavor, sym->name, NULL) == FAILURE)
+ && !gfc_add_flavor (&sym->attr, flavor, sym->name, NULL))
return MATCH_ERROR;
}
break;
case FL_PARAMETER:
if (equiv_flag)
- gfc_error ("Named constant at %C in an EQUIVALENCE");
- else
- gfc_error ("Cannot assign to a named constant at %C");
- return MATCH_ERROR;
+ {
+ gfc_error ("Named constant at %C in an EQUIVALENCE");
+ return MATCH_ERROR;
+ }
+ /* Otherwise this is checked for and an error given in the
+ variable definition context checks. */
break;
case FL_PROCEDURE:
/* 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)))
+ && !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->attr.proc_pointer
- || replace_hidden_procptr_result (&sym, &st) == SUCCESS)
+ || replace_hidden_procptr_result (&sym, &st))
break;
/* Fall through to error */
+ gcc_fallthrough ();
default:
- gfc_error ("'%s' at %C is not a variable", sym->name);
+ gfc_error ("%qs at %C is not a variable", sym->name);
return MATCH_ERROR;
}
else
implicit_ns = sym->ns;
- if (gfc_peek_ascii_char () == '%'
+ old_loc = gfc_current_locus;
+ if (gfc_match_member_sep (sym) == MATCH_YES
&& sym->ts.type == BT_UNKNOWN
&& gfc_get_default_type (sym->name, implicit_ns)->type == BT_DERIVED)
gfc_set_default_type (sym, 0, implicit_ns);
+ gfc_current_locus = old_loc;
}
expr = gfc_get_expr ();
projects / thirdparty / gcc.git / blobdiff