/* Primary expression subroutines
- Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006
+ Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007
Free Software Foundation, Inc.
Contributed by Andy Vaught
Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA. */
-
#include "config.h"
#include "system.h"
#include "flags.h"
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;
/* 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;
+ gfc_expr *e = NULL;
+ const char *msg;
+ char *buffer;
int num;
int i;
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[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);
+ e = gfc_constant_result (BT_HOLLERITH, gfc_default_character_kind,
+ &gfc_current_locus);
+ e->value.character.string = gfc_getmem (num + 1);
memcpy (e->value.character.string, buffer, num);
+ e->value.character.string[num] = '\0';
e->value.character.length = num;
*result = e;
return MATCH_YES;
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;
locus old_loc, start_loc;
is nonzero. Allow integer constants if allow_int is true. */
static match
-match_real_constant (gfc_expr ** result, int signflag)
+match_real_constant (gfc_expr **result, int signflag)
{
int kind, c, count, seen_dp, seen_digits, exp_char;
locus old_loc, temp_loc;
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 ();
break;
}
- if (!seen_digits
- || (c != 'e' && c != 'd' && c != 'q'))
+ if (!seen_digits || (c != 'e' && c != 'd' && c != 'q'))
goto done;
exp_char = c;
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;
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)
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;
/* 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),
symbolic constant. */
static match
-match_sym_complex_part (gfc_expr ** result)
+match_sym_complex_part (gfc_expr **result)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_symbol *sym;
return MATCH_ERROR;
}
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PARAMETER symbol in "
+ "complex constant at %C") == FAILURE)
+ return MATCH_ERROR;
+
switch (sym->value->ts.type)
{
case BT_REAL:
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;
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;
fixing things later during resolution. */
static match
-match_actual_arg (gfc_expr ** result)
+match_actual_arg (gfc_expr **result)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_symtree *symtree;
/* Handle error elsewhere. */
/* Eliminate a couple of common cases where we know we don't
- have a function argument. */
+ have a function argument. */
if (symtree == NULL)
- {
+ {
gfc_get_sym_tree (name, NULL, &symtree);
- gfc_set_sym_referenced (symtree->n.sym);
- }
+ gfc_set_sym_referenced (symtree->n.sym);
+ }
else
{
- gfc_symbol *sym;
+ gfc_symbol *sym;
- sym = symtree->n.sym;
- gfc_set_sym_referenced (sym);
+ sym = symtree->n.sym;
+ gfc_set_sym_referenced (sym);
if (sym->attr.flavor != FL_PROCEDURE
&& sym->attr.flavor != FL_UNKNOWN)
break;
/* 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
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;
element. */
static gfc_ref *
-extend_ref (gfc_expr * primary, gfc_ref * tail)
+extend_ref (gfc_expr *primary, gfc_ref *tail)
{
-
if (primary->ref == NULL)
primary->ref = tail = gfc_get_ref ();
else
statement. */
static match
-match_varspec (gfc_expr * primary, int equiv_flag)
+match_varspec (gfc_expr *primary, int equiv_flag)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_ref *substring, *tail;
tail = NULL;
- if ((equiv_flag && gfc_peek_char () == '(')
- || sym->attr.dimension)
+ if ((equiv_flag && gfc_peek_char () == '(') || sym->attr.dimension)
{
/* In EQUIVALENCE, we don't know yet whether we are seeing
an array, character variable or array of character
- variables. We'll leave the decision till resolve
- time. */
+ variables. We'll leave the decision till resolve time. */
tail = extend_ref (primary, tail);
tail->type = REF_ARRAY;
{
if (gfc_get_default_type (sym, 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;
}
}
We can have at most one full array reference. */
symbol_attribute
-gfc_variable_attr (gfc_expr * expr, gfc_typespec * ts)
+gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
{
- int dimension, pointer, target;
+ int dimension, pointer, allocatable, target;
symbol_attribute attr;
gfc_ref *ref;
dimension = attr.dimension;
pointer = attr.pointer;
+ allocatable = attr.allocatable;
target = attr.target;
if (pointer)
break;
case AR_SECTION:
- pointer = 0;
+ allocatable = pointer = 0;
dimension = 1;
break;
case AR_ELEMENT:
- pointer = 0;
+ allocatable = pointer = 0;
break;
case AR_UNKNOWN:
*ts = ref->u.c.component->ts;
pointer = ref->u.c.component->pointer;
+ allocatable = ref->u.c.component->allocatable;
if (pointer)
target = 1;
break;
case REF_SUBSTRING:
- pointer = 0;
+ allocatable = pointer = 0;
break;
}
attr.dimension = dimension;
attr.pointer = pointer;
+ attr.allocatable = allocatable;
attr.target = target;
return attr;
/* Return the attribute from a general expression. */
symbol_attribute
-gfc_expr_attr (gfc_expr * e)
+gfc_expr_attr (gfc_expr *e)
{
symbol_attribute attr;
attr = e->value.function.esym->result->attr;
/* TODO: NULL() returns pointers. May have to take care of this
- here. */
+ here. */
break;
seen. */
match
-gfc_match_structure_constructor (gfc_symbol * sym, gfc_expr ** result)
+gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result)
{
gfc_constructor *head, *tail;
gfc_component *comp;
{
if (comp->next == NULL)
{
- gfc_error
- ("Too many components in structure constructor at %C");
+ gfc_error ("Too many components in structure constructor at %C");
goto cleanup;
}
array reference, argument list of a function, etc. */
match
-gfc_match_rvalue (gfc_expr ** result)
+gfc_match_rvalue (gfc_expr **result)
{
gfc_actual_arglist *actual_arglist;
char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1];
if (m != MATCH_YES)
return m;
- if (gfc_find_state (COMP_INTERFACE) == SUCCESS)
+ if (gfc_find_state (COMP_INTERFACE) == SUCCESS
+ && !gfc_current_ns->has_import_set)
i = gfc_get_sym_tree (name, NULL, &symtree);
else
i = gfc_get_ha_sym_tree (name, &symtree);
/* 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_char () == '('
+ && gfc_current_ns->proc_name == sym)
{
if (!sym->attr.dimension)
goto function0;
if (sym == NULL)
m = MATCH_ERROR;
else
- m = gfc_match_structure_constructor (sym, &e);
+ m = gfc_match_structure_constructor (sym, &e);
break;
/* If we're here, then the name is known to be the name of a
}
/* At this point, the name has to be a non-statement function.
- If the name is the same as the current function being
- compiled, then we have a variable reference (to the function
- result) if the name is non-recursive. */
+ If the name is the same as the current function being
+ compiled, then we have a variable reference (to the function
+ result) if the name is non-recursive. */
st = gfc_enclosing_unit (NULL);
case FL_UNKNOWN:
/* Special case for derived type variables that get their types
- via an IMPLICIT statement. This can't wait for the
- resolution phase. */
+ via an IMPLICIT statement. This can't wait for the
+ resolution phase. */
if (gfc_peek_char () == '%'
&& sym->ts.type == BT_UNKNOWN
gfc_set_default_type (sym, 0, sym->ns);
/* If the symbol has a dimension attribute, the expression is a
- variable. */
+ variable. */
if (sym->attr.dimension)
{
}
/* 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 our new function returns a character, array or structure
- type, it might have subsequent references. */
+ type, it might have subsequent references. */
m = match_varspec (e, 0);
if (m == MATCH_NO)
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;
locus where;
match m;
+ /* Since nothing has any business being an lvalue in a module
+ specification block, an interface block or a contains section,
+ we force the changed_symbols mechanism to work by setting
+ host_flag to 0. This prevents valid symbols that have the name
+ of keywords, such as 'end', being turned into variables by
+ failed matching to assignments for, eg., END INTERFACE. */
+ if (gfc_current_state () == COMP_MODULE
+ || gfc_current_state () == COMP_INTERFACE
+ || gfc_current_state () == COMP_CONTAINS)
+ host_flag = 0;
+
m = gfc_match_sym_tree (&st, host_flag);
if (m != MATCH_YES)
return m;
switch (sym->attr.flavor)
{
case FL_VARIABLE:
+ if (sym->attr.protected && sym->attr.use_assoc)
+ {
+ gfc_error ("Assigning to PROTECTED variable at %C");
+ return MATCH_ERROR;
+ }
break;
case FL_UNKNOWN:
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
