aboutsummaryrefslogtreecommitdiff
path: root/gcc/fortran/primary.c
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/fortran/primary.c')
-rw-r--r--gcc/fortran/primary.c166
1 files changed, 80 insertions, 86 deletions
diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index f67500c..a2f70a0 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -1,5 +1,5 @@
/* 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
@@ -20,7 +20,6 @@ along with GCC; see the file COPYING. If not, write to the Free
Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA. */
-
#include "config.h"
#include "system.h"
#include "flags.h"
@@ -179,7 +178,7 @@ match_digits (int signflag, int radix, char *buffer)
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;
@@ -231,12 +230,12 @@ match_integer_constant (gfc_expr ** result, int signflag)
/* 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;
@@ -244,11 +243,10 @@ match_hollerith_constant (gfc_expr ** result)
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);
@@ -259,14 +257,14 @@ match_hollerith_constant (gfc_expr ** result)
}
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
@@ -277,9 +275,9 @@ match_hollerith_constant (gfc_expr ** result)
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;
@@ -305,7 +303,7 @@ cleanup:
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;
@@ -435,7 +433,7 @@ backup:
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;
@@ -472,7 +470,8 @@ match_real_constant (gfc_expr ** result, int signflag)
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 ();
@@ -500,8 +499,7 @@ match_real_constant (gfc_expr ** result, int signflag)
break;
}
- if (!seen_digits
- || (c != 'e' && c != 'd' && c != 'q'))
+ if (!seen_digits || (c != 'e' && c != 'd' && c != 'q'))
goto done;
exp_char = c;
@@ -573,8 +571,8 @@ done:
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;
@@ -605,7 +603,7 @@ done:
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;
@@ -625,7 +623,7 @@ cleanup:
/* 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;
@@ -848,7 +846,7 @@ match_charkind_name (char *name)
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;
@@ -1002,7 +1000,7 @@ no_match:
/* 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),
@@ -1043,7 +1041,7 @@ match_logical_constant (gfc_expr ** result)
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;
@@ -1101,7 +1099,7 @@ match_sym_complex_part (gfc_expr ** result)
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:
@@ -1113,7 +1111,7 @@ 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;
@@ -1132,7 +1130,7 @@ match_complex_part (gfc_expr ** result)
/* 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;
@@ -1249,7 +1247,7 @@ cleanup:
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;
@@ -1293,7 +1291,7 @@ gfc_match_literal_constant (gfc_expr ** result, int signflag)
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;
@@ -1325,18 +1323,18 @@ match_actual_arg (gfc_expr ** result)
/* 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;
@@ -1384,7 +1382,7 @@ match_actual_arg (gfc_expr ** result)
/* 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;
@@ -1413,9 +1411,8 @@ match_keyword_arg (gfc_actual_arglist * actual, gfc_actual_arglist * base)
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;
}
}
@@ -1455,19 +1452,19 @@ match_arg_list_function (gfc_actual_arglist *result)
switch (name[0])
{
case 'l':
- if (strncmp(name, "loc", 3) == 0)
+ if (strncmp (name, "loc", 3) == 0)
{
result->name = "%LOC";
break;
}
case 'r':
- if (strncmp(name, "ref", 3) == 0)
+ if (strncmp (name, "ref", 3) == 0)
{
result->name = "%REF";
break;
}
case 'v':
- if (strncmp(name, "val", 3) == 0)
+ if (strncmp (name, "val", 3) == 0)
{
result->name = "%VAL";
break;
@@ -1511,7 +1508,7 @@ cleanup:
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;
@@ -1554,7 +1551,7 @@ gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist ** argp)
}
/* 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);
@@ -1563,8 +1560,7 @@ gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist ** argp)
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;
}
@@ -1623,9 +1619,8 @@ cleanup:
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
@@ -1646,7 +1641,7 @@ extend_ref (gfc_expr * primary, gfc_ref * tail)
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;
@@ -1656,13 +1651,11 @@ match_varspec (gfc_expr * primary, int equiv_flag)
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;
@@ -1734,8 +1727,8 @@ check_substring:
{
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;
}
}
@@ -1787,7 +1780,7 @@ check_substring:
We can have at most one full array reference. */
symbol_attribute
-gfc_variable_attr (gfc_expr * expr, gfc_typespec * ts)
+gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
{
int dimension, pointer, allocatable, target;
symbol_attribute attr;
@@ -1865,7 +1858,7 @@ gfc_variable_attr (gfc_expr * expr, gfc_typespec * ts)
/* Return the attribute from a general expression. */
symbol_attribute
-gfc_expr_attr (gfc_expr * e)
+gfc_expr_attr (gfc_expr *e)
{
symbol_attribute attr;
@@ -1882,7 +1875,7 @@ gfc_expr_attr (gfc_expr * e)
attr = e->value.function.esym->result->attr;
/* TODO: NULL() returns pointers. May have to take care of this
- here. */
+ here. */
break;
@@ -1899,7 +1892,7 @@ gfc_expr_attr (gfc_expr * e)
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;
@@ -1936,8 +1929,7 @@ gfc_match_structure_constructor (gfc_symbol * sym, gfc_expr ** result)
{
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;
}
@@ -1982,7 +1974,7 @@ 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];
@@ -2020,8 +2012,8 @@ gfc_match_rvalue (gfc_expr ** result)
/* 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;
@@ -2093,7 +2085,7 @@ gfc_match_rvalue (gfc_expr ** result)
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
@@ -2108,9 +2100,9 @@ gfc_match_rvalue (gfc_expr ** result)
}
/* 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);
@@ -2176,8 +2168,8 @@ gfc_match_rvalue (gfc_expr ** result)
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
@@ -2185,7 +2177,7 @@ gfc_match_rvalue (gfc_expr ** result)
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)
{
@@ -2204,8 +2196,8 @@ gfc_match_rvalue (gfc_expr ** result)
}
/* 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 () != '(')
@@ -2310,7 +2302,7 @@ gfc_match_rvalue (gfc_expr ** result)
}
/* 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)
@@ -2357,7 +2349,7 @@ gfc_match_rvalue (gfc_expr ** result)
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;
@@ -2387,10 +2379,10 @@ match_variable (gfc_expr ** result, int equiv_flag, int host_flag)
{
case FL_VARIABLE:
if (sym->attr.protected && sym->attr.use_assoc)
- {
+ {
gfc_error ("Assigning to PROTECTED variable at %C");
- return MATCH_ERROR;
- }
+ return MATCH_ERROR;
+ }
break;
case FL_UNKNOWN:
@@ -2464,14 +2456,16 @@ match_variable (gfc_expr ** result, int equiv_flag, int host_flag)
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);
}
generated by cgit v1.1 at 2025-04-28 01:39:07 +0000