/* Primary expression subroutines
|
/* Primary expression subroutines
|
Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008
|
Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008
|
Free Software Foundation, Inc.
|
Free Software Foundation, Inc.
|
Contributed by Andy Vaught
|
Contributed by Andy Vaught
|
|
|
This file is part of GCC.
|
This file is part of GCC.
|
|
|
GCC is free software; you can redistribute it and/or modify it under
|
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
|
the terms of the GNU General Public License as published by the Free
|
Software Foundation; either version 3, or (at your option) any later
|
Software Foundation; either version 3, or (at your option) any later
|
version.
|
version.
|
|
|
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
|
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
|
WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
|
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
|
for more details.
|
for more details.
|
|
|
You should have received a copy of the GNU General Public License
|
You should have received a copy of the GNU General Public License
|
along with GCC; see the file COPYING3. If not see
|
along with GCC; see the file COPYING3. If not see
|
<http://www.gnu.org/licenses/>. */
|
<http://www.gnu.org/licenses/>. */
|
|
|
#include "config.h"
|
#include "config.h"
|
#include "system.h"
|
#include "system.h"
|
#include "flags.h"
|
#include "flags.h"
|
#include "gfortran.h"
|
#include "gfortran.h"
|
#include "arith.h"
|
#include "arith.h"
|
#include "match.h"
|
#include "match.h"
|
#include "parse.h"
|
#include "parse.h"
|
#include "toplev.h"
|
#include "toplev.h"
|
|
|
/* Matches a kind-parameter expression, which is either a named
|
/* Matches a kind-parameter expression, which is either a named
|
symbolic constant or a nonnegative integer constant. If
|
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. */
|
|
|
static match
|
static match
|
match_kind_param (int *kind)
|
match_kind_param (int *kind)
|
{
|
{
|
char name[GFC_MAX_SYMBOL_LEN + 1];
|
char name[GFC_MAX_SYMBOL_LEN + 1];
|
gfc_symbol *sym;
|
gfc_symbol *sym;
|
const char *p;
|
const char *p;
|
match m;
|
match m;
|
|
|
m = gfc_match_small_literal_int (kind, NULL);
|
m = gfc_match_small_literal_int (kind, NULL);
|
if (m != MATCH_NO)
|
if (m != MATCH_NO)
|
return m;
|
return m;
|
|
|
m = gfc_match_name (name);
|
m = gfc_match_name (name);
|
if (m != MATCH_YES)
|
if (m != MATCH_YES)
|
return m;
|
return m;
|
|
|
if (gfc_find_symbol (name, NULL, 1, &sym))
|
if (gfc_find_symbol (name, NULL, 1, &sym))
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
|
|
if (sym == NULL)
|
if (sym == NULL)
|
return MATCH_NO;
|
return MATCH_NO;
|
|
|
if (sym->attr.flavor != FL_PARAMETER)
|
if (sym->attr.flavor != FL_PARAMETER)
|
return MATCH_NO;
|
return MATCH_NO;
|
|
|
if (sym->value == NULL)
|
if (sym->value == NULL)
|
return MATCH_NO;
|
return MATCH_NO;
|
|
|
p = gfc_extract_int (sym->value, kind);
|
p = gfc_extract_int (sym->value, kind);
|
if (p != NULL)
|
if (p != NULL)
|
return MATCH_NO;
|
return MATCH_NO;
|
|
|
gfc_set_sym_referenced (sym);
|
gfc_set_sym_referenced (sym);
|
|
|
if (*kind < 0)
|
if (*kind < 0)
|
return MATCH_NO;
|
return MATCH_NO;
|
|
|
return MATCH_YES;
|
return MATCH_YES;
|
}
|
}
|
|
|
|
|
/* Get a trailing kind-specification for non-character variables.
|
/* Get a trailing kind-specification for non-character variables.
|
Returns:
|
Returns:
|
the integer kind value or:
|
the integer kind value or:
|
-1 if an error was generated
|
-1 if an error was generated
|
-2 if no kind was found */
|
-2 if no kind was found */
|
|
|
static int
|
static int
|
get_kind (void)
|
get_kind (void)
|
{
|
{
|
int kind;
|
int kind;
|
match m;
|
match m;
|
|
|
if (gfc_match_char ('_') != MATCH_YES)
|
if (gfc_match_char ('_') != MATCH_YES)
|
return -2;
|
return -2;
|
|
|
m = match_kind_param (&kind);
|
m = match_kind_param (&kind);
|
if (m == MATCH_NO)
|
if (m == MATCH_NO)
|
gfc_error ("Missing kind-parameter at %C");
|
gfc_error ("Missing kind-parameter at %C");
|
|
|
return (m == MATCH_YES) ? kind : -1;
|
return (m == MATCH_YES) ? kind : -1;
|
}
|
}
|
|
|
|
|
/* Given a character and a radix, see if the character is a valid
|
/* Given a character and a radix, see if the character is a valid
|
digit in that radix. */
|
digit in that radix. */
|
|
|
int
|
int
|
gfc_check_digit (char c, int radix)
|
gfc_check_digit (char c, int radix)
|
{
|
{
|
int r;
|
int r;
|
|
|
switch (radix)
|
switch (radix)
|
{
|
{
|
case 2:
|
case 2:
|
r = ('0' <= c && c <= '1');
|
r = ('0' <= c && c <= '1');
|
break;
|
break;
|
|
|
case 8:
|
case 8:
|
r = ('0' <= c && c <= '7');
|
r = ('0' <= c && c <= '7');
|
break;
|
break;
|
|
|
case 10:
|
case 10:
|
r = ('0' <= c && c <= '9');
|
r = ('0' <= c && c <= '9');
|
break;
|
break;
|
|
|
case 16:
|
case 16:
|
r = ISXDIGIT (c);
|
r = ISXDIGIT (c);
|
break;
|
break;
|
|
|
default:
|
default:
|
gfc_internal_error ("gfc_check_digit(): bad radix");
|
gfc_internal_error ("gfc_check_digit(): bad radix");
|
}
|
}
|
|
|
return r;
|
return r;
|
}
|
}
|
|
|
|
|
/* Match the digit string part of an integer if signflag is not set,
|
/* 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
|
the signed digit string part if signflag is set. If the buffer
|
is NULL, we just count characters for the resolution pass. Returns
|
is NULL, we just count characters for the resolution pass. Returns
|
the number of characters matched, -1 for no match. */
|
the number of characters matched, -1 for no match. */
|
|
|
static int
|
static int
|
match_digits (int signflag, int radix, char *buffer)
|
match_digits (int signflag, int radix, char *buffer)
|
{
|
{
|
locus old_loc;
|
locus old_loc;
|
int length;
|
int length;
|
char c;
|
char c;
|
|
|
length = 0;
|
length = 0;
|
c = gfc_next_ascii_char ();
|
c = gfc_next_ascii_char ();
|
|
|
if (signflag && (c == '+' || c == '-'))
|
if (signflag && (c == '+' || c == '-'))
|
{
|
{
|
if (buffer != NULL)
|
if (buffer != NULL)
|
*buffer++ = c;
|
*buffer++ = c;
|
gfc_gobble_whitespace ();
|
gfc_gobble_whitespace ();
|
c = gfc_next_ascii_char ();
|
c = gfc_next_ascii_char ();
|
length++;
|
length++;
|
}
|
}
|
|
|
if (!gfc_check_digit (c, radix))
|
if (!gfc_check_digit (c, radix))
|
return -1;
|
return -1;
|
|
|
length++;
|
length++;
|
if (buffer != NULL)
|
if (buffer != NULL)
|
*buffer++ = c;
|
*buffer++ = c;
|
|
|
for (;;)
|
for (;;)
|
{
|
{
|
old_loc = gfc_current_locus;
|
old_loc = gfc_current_locus;
|
c = gfc_next_ascii_char ();
|
c = gfc_next_ascii_char ();
|
|
|
if (!gfc_check_digit (c, radix))
|
if (!gfc_check_digit (c, radix))
|
break;
|
break;
|
|
|
if (buffer != NULL)
|
if (buffer != NULL)
|
*buffer++ = c;
|
*buffer++ = c;
|
length++;
|
length++;
|
}
|
}
|
|
|
gfc_current_locus = old_loc;
|
gfc_current_locus = old_loc;
|
|
|
return length;
|
return length;
|
}
|
}
|
|
|
|
|
/* 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. */
|
A sign will be accepted if signflag is set. */
|
|
|
static match
|
static match
|
match_integer_constant (gfc_expr **result, int signflag)
|
match_integer_constant (gfc_expr **result, int signflag)
|
{
|
{
|
int length, kind;
|
int length, kind;
|
locus old_loc;
|
locus old_loc;
|
char *buffer;
|
char *buffer;
|
gfc_expr *e;
|
gfc_expr *e;
|
|
|
old_loc = gfc_current_locus;
|
old_loc = gfc_current_locus;
|
gfc_gobble_whitespace ();
|
gfc_gobble_whitespace ();
|
|
|
length = match_digits (signflag, 10, NULL);
|
length = match_digits (signflag, 10, NULL);
|
gfc_current_locus = old_loc;
|
gfc_current_locus = old_loc;
|
if (length == -1)
|
if (length == -1)
|
return MATCH_NO;
|
return MATCH_NO;
|
|
|
buffer = (char *) alloca (length + 1);
|
buffer = (char *) alloca (length + 1);
|
memset (buffer, '\0', length + 1);
|
memset (buffer, '\0', length + 1);
|
|
|
gfc_gobble_whitespace ();
|
gfc_gobble_whitespace ();
|
|
|
match_digits (signflag, 10, buffer);
|
match_digits (signflag, 10, buffer);
|
|
|
kind = get_kind ();
|
kind = get_kind ();
|
if (kind == -2)
|
if (kind == -2)
|
kind = gfc_default_integer_kind;
|
kind = gfc_default_integer_kind;
|
if (kind == -1)
|
if (kind == -1)
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
|
|
if (gfc_validate_kind (BT_INTEGER, kind, true) < 0)
|
if (gfc_validate_kind (BT_INTEGER, kind, true) < 0)
|
{
|
{
|
gfc_error ("Integer kind %d at %C not available", kind);
|
gfc_error ("Integer kind %d at %C not available", kind);
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
}
|
}
|
|
|
e = gfc_convert_integer (buffer, kind, 10, &gfc_current_locus);
|
e = gfc_convert_integer (buffer, kind, 10, &gfc_current_locus);
|
|
|
if (gfc_range_check (e) != ARITH_OK)
|
if (gfc_range_check (e) != ARITH_OK)
|
{
|
{
|
gfc_error ("Integer too big for its kind at %C. This check can be "
|
gfc_error ("Integer too big for its kind at %C. This check can be "
|
"disabled with the option -fno-range-check");
|
"disabled with the option -fno-range-check");
|
|
|
gfc_free_expr (e);
|
gfc_free_expr (e);
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
}
|
}
|
|
|
*result = e;
|
*result = e;
|
return MATCH_YES;
|
return MATCH_YES;
|
}
|
}
|
|
|
|
|
/* Match a Hollerith constant. */
|
/* Match a Hollerith constant. */
|
|
|
static match
|
static match
|
match_hollerith_constant (gfc_expr **result)
|
match_hollerith_constant (gfc_expr **result)
|
{
|
{
|
locus old_loc;
|
locus old_loc;
|
gfc_expr *e = NULL;
|
gfc_expr *e = NULL;
|
const char *msg;
|
const char *msg;
|
int num;
|
int num;
|
int i;
|
int i;
|
|
|
old_loc = gfc_current_locus;
|
old_loc = gfc_current_locus;
|
gfc_gobble_whitespace ();
|
gfc_gobble_whitespace ();
|
|
|
if (match_integer_constant (&e, 0) == MATCH_YES
|
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 "
|
if (gfc_notify_std (GFC_STD_LEGACY, "Extension: Hollerith constant "
|
"at %C") == FAILURE)
|
"at %C") == FAILURE)
|
goto cleanup;
|
goto cleanup;
|
|
|
msg = gfc_extract_int (e, &num);
|
msg = gfc_extract_int (e, &num);
|
if (msg != NULL)
|
if (msg != NULL)
|
{
|
{
|
gfc_error (msg);
|
gfc_error (msg);
|
goto cleanup;
|
goto cleanup;
|
}
|
}
|
if (num == 0)
|
if (num == 0)
|
{
|
{
|
gfc_error ("Invalid Hollerith constant: %L must contain at least "
|
gfc_error ("Invalid Hollerith constant: %L must contain at least "
|
"one character", &old_loc);
|
"one character", &old_loc);
|
goto cleanup;
|
goto cleanup;
|
}
|
}
|
if (e->ts.kind != gfc_default_integer_kind)
|
if (e->ts.kind != gfc_default_integer_kind)
|
{
|
{
|
gfc_error ("Invalid Hollerith constant: Integer kind at %L "
|
gfc_error ("Invalid Hollerith constant: Integer kind at %L "
|
"should be default", &old_loc);
|
"should be default", &old_loc);
|
goto cleanup;
|
goto cleanup;
|
}
|
}
|
else
|
else
|
{
|
{
|
gfc_free_expr (e);
|
gfc_free_expr (e);
|
e = gfc_constant_result (BT_HOLLERITH, gfc_default_character_kind,
|
e = gfc_constant_result (BT_HOLLERITH, gfc_default_character_kind,
|
&gfc_current_locus);
|
&gfc_current_locus);
|
|
|
e->representation.string = XCNEWVEC (char, num + 1);
|
e->representation.string = XCNEWVEC (char, num + 1);
|
|
|
for (i = 0; i < num; i++)
|
for (i = 0; i < num; i++)
|
{
|
{
|
gfc_char_t c = gfc_next_char_literal (1);
|
gfc_char_t c = gfc_next_char_literal (1);
|
if (! gfc_wide_fits_in_byte (c))
|
if (! gfc_wide_fits_in_byte (c))
|
{
|
{
|
gfc_error ("Invalid Hollerith constant at %L contains a "
|
gfc_error ("Invalid Hollerith constant at %L contains a "
|
"wide character", &old_loc);
|
"wide character", &old_loc);
|
goto cleanup;
|
goto cleanup;
|
}
|
}
|
|
|
e->representation.string[i] = (unsigned char) c;
|
e->representation.string[i] = (unsigned char) c;
|
}
|
}
|
|
|
e->representation.string[num] = '\0';
|
e->representation.string[num] = '\0';
|
e->representation.length = num;
|
e->representation.length = num;
|
|
|
*result = e;
|
*result = e;
|
return MATCH_YES;
|
return MATCH_YES;
|
}
|
}
|
}
|
}
|
|
|
gfc_free_expr (e);
|
gfc_free_expr (e);
|
gfc_current_locus = old_loc;
|
gfc_current_locus = old_loc;
|
return MATCH_NO;
|
return MATCH_NO;
|
|
|
cleanup:
|
cleanup:
|
gfc_free_expr (e);
|
gfc_free_expr (e);
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
}
|
}
|
|
|
|
|
/* Match a binary, octal or hexadecimal constant that can be found in
|
/* Match a binary, octal or hexadecimal constant that can be found in
|
a DATA statement. The standard permits b'010...', o'73...', and
|
a DATA statement. The standard permits b'010...', o'73...', and
|
z'a1...' where b, o, and z can be capital letters. This function
|
z'a1...' where b, o, and z can be capital letters. This function
|
also accepts postfixed forms of the constants: '01...'b, '73...'o,
|
also accepts postfixed forms of the constants: '01...'b, '73...'o,
|
and 'a1...'z. An additional extension is the use of x for z. */
|
and 'a1...'z. An additional extension is the use of x for z. */
|
|
|
static match
|
static match
|
match_boz_constant (gfc_expr **result)
|
match_boz_constant (gfc_expr **result)
|
{
|
{
|
int radix, length, x_hex, kind;
|
int radix, length, x_hex, kind;
|
locus old_loc, start_loc;
|
locus old_loc, start_loc;
|
char *buffer, post, delim;
|
char *buffer, post, delim;
|
gfc_expr *e;
|
gfc_expr *e;
|
|
|
start_loc = old_loc = gfc_current_locus;
|
start_loc = old_loc = gfc_current_locus;
|
gfc_gobble_whitespace ();
|
gfc_gobble_whitespace ();
|
|
|
x_hex = 0;
|
x_hex = 0;
|
switch (post = gfc_next_ascii_char ())
|
switch (post = gfc_next_ascii_char ())
|
{
|
{
|
case 'b':
|
case 'b':
|
radix = 2;
|
radix = 2;
|
post = 0;
|
post = 0;
|
break;
|
break;
|
case 'o':
|
case 'o':
|
radix = 8;
|
radix = 8;
|
post = 0;
|
post = 0;
|
break;
|
break;
|
case 'x':
|
case 'x':
|
x_hex = 1;
|
x_hex = 1;
|
/* Fall through. */
|
/* Fall through. */
|
case 'z':
|
case 'z':
|
radix = 16;
|
radix = 16;
|
post = 0;
|
post = 0;
|
break;
|
break;
|
case '\'':
|
case '\'':
|
/* Fall through. */
|
/* Fall through. */
|
case '\"':
|
case '\"':
|
delim = post;
|
delim = post;
|
post = 1;
|
post = 1;
|
radix = 16; /* Set to accept any valid digit string. */
|
radix = 16; /* Set to accept any valid digit string. */
|
break;
|
break;
|
default:
|
default:
|
goto backup;
|
goto backup;
|
}
|
}
|
|
|
/* No whitespace allowed here. */
|
/* No whitespace allowed here. */
|
|
|
if (post == 0)
|
if (post == 0)
|
delim = gfc_next_ascii_char ();
|
delim = gfc_next_ascii_char ();
|
|
|
if (delim != '\'' && delim != '\"')
|
if (delim != '\'' && delim != '\"')
|
goto backup;
|
goto backup;
|
|
|
if (x_hex
|
if (x_hex
|
&& (gfc_notify_std (GFC_STD_GNU, "Extension: Hexadecimal "
|
&& (gfc_notify_std (GFC_STD_GNU, "Extension: Hexadecimal "
|
"constant at %C uses non-standard syntax")
|
"constant at %C uses non-standard syntax")
|
== FAILURE))
|
== FAILURE))
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
|
|
old_loc = gfc_current_locus;
|
old_loc = gfc_current_locus;
|
|
|
length = match_digits (0, radix, NULL);
|
length = match_digits (0, radix, NULL);
|
if (length == -1)
|
if (length == -1)
|
{
|
{
|
gfc_error ("Empty set of digits in BOZ constant at %C");
|
gfc_error ("Empty set of digits in BOZ constant at %C");
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
}
|
}
|
|
|
if (gfc_next_ascii_char () != delim)
|
if (gfc_next_ascii_char () != delim)
|
{
|
{
|
gfc_error ("Illegal character in BOZ constant at %C");
|
gfc_error ("Illegal character in BOZ constant at %C");
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
}
|
}
|
|
|
if (post == 1)
|
if (post == 1)
|
{
|
{
|
switch (gfc_next_ascii_char ())
|
switch (gfc_next_ascii_char ())
|
{
|
{
|
case 'b':
|
case 'b':
|
radix = 2;
|
radix = 2;
|
break;
|
break;
|
case 'o':
|
case 'o':
|
radix = 8;
|
radix = 8;
|
break;
|
break;
|
case 'x':
|
case 'x':
|
/* Fall through. */
|
/* Fall through. */
|
case 'z':
|
case 'z':
|
radix = 16;
|
radix = 16;
|
break;
|
break;
|
default:
|
default:
|
goto backup;
|
goto backup;
|
}
|
}
|
|
|
if (gfc_notify_std (GFC_STD_GNU, "Extension: BOZ constant "
|
if (gfc_notify_std (GFC_STD_GNU, "Extension: BOZ constant "
|
"at %C uses non-standard postfix syntax")
|
"at %C uses non-standard postfix syntax")
|
== FAILURE)
|
== FAILURE)
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
}
|
}
|
|
|
gfc_current_locus = old_loc;
|
gfc_current_locus = old_loc;
|
|
|
buffer = (char *) alloca (length + 1);
|
buffer = (char *) alloca (length + 1);
|
memset (buffer, '\0', length + 1);
|
memset (buffer, '\0', length + 1);
|
|
|
match_digits (0, radix, buffer);
|
match_digits (0, radix, buffer);
|
gfc_next_ascii_char (); /* Eat delimiter. */
|
gfc_next_ascii_char (); /* Eat delimiter. */
|
if (post == 1)
|
if (post == 1)
|
gfc_next_ascii_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
|
/* 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
|
"If a data-stmt-constant is a boz-literal-constant, the corresponding
|
variable shall be of type integer. The boz-literal-constant is treated
|
variable shall be of type integer. The boz-literal-constant is treated
|
as if it were an int-literal-constant with a kind-param that specifies
|
as if it were an int-literal-constant with a kind-param that specifies
|
the representation method with the largest decimal exponent range
|
the representation method with the largest decimal exponent range
|
supported by the processor." */
|
supported by the processor." */
|
|
|
kind = gfc_max_integer_kind;
|
kind = gfc_max_integer_kind;
|
e = gfc_convert_integer (buffer, kind, radix, &gfc_current_locus);
|
e = gfc_convert_integer (buffer, kind, radix, &gfc_current_locus);
|
|
|
/* Mark as boz variable. */
|
/* Mark as boz variable. */
|
e->is_boz = 1;
|
e->is_boz = 1;
|
|
|
if (gfc_range_check (e) != ARITH_OK)
|
if (gfc_range_check (e) != ARITH_OK)
|
{
|
{
|
gfc_error ("Integer too big for integer kind %i at %C", kind);
|
gfc_error ("Integer too big for integer kind %i at %C", kind);
|
gfc_free_expr (e);
|
gfc_free_expr (e);
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
}
|
}
|
|
|
if (!gfc_in_match_data ()
|
if (!gfc_in_match_data ()
|
&& (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BOZ used outside a DATA "
|
&& (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BOZ used outside a DATA "
|
"statement at %C")
|
"statement at %C")
|
== FAILURE))
|
== FAILURE))
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
|
|
*result = e;
|
*result = e;
|
return MATCH_YES;
|
return MATCH_YES;
|
|
|
backup:
|
backup:
|
gfc_current_locus = start_loc;
|
gfc_current_locus = start_loc;
|
return MATCH_NO;
|
return MATCH_NO;
|
}
|
}
|
|
|
|
|
/* Match a real constant of some sort. Allow a signed constant if signflag
|
/* Match a real constant of some sort. Allow a signed constant if signflag
|
is nonzero. */
|
is nonzero. */
|
|
|
static match
|
static match
|
match_real_constant (gfc_expr **result, int signflag)
|
match_real_constant (gfc_expr **result, int signflag)
|
{
|
{
|
int kind, count, seen_dp, seen_digits;
|
int kind, count, seen_dp, seen_digits;
|
locus old_loc, temp_loc;
|
locus old_loc, temp_loc;
|
char *p, *buffer, c, exp_char;
|
char *p, *buffer, c, exp_char;
|
gfc_expr *e;
|
gfc_expr *e;
|
bool negate;
|
bool negate;
|
|
|
old_loc = gfc_current_locus;
|
old_loc = gfc_current_locus;
|
gfc_gobble_whitespace ();
|
gfc_gobble_whitespace ();
|
|
|
e = NULL;
|
e = NULL;
|
|
|
count = 0;
|
count = 0;
|
seen_dp = 0;
|
seen_dp = 0;
|
seen_digits = 0;
|
seen_digits = 0;
|
exp_char = ' ';
|
exp_char = ' ';
|
negate = FALSE;
|
negate = FALSE;
|
|
|
c = gfc_next_ascii_char ();
|
c = gfc_next_ascii_char ();
|
if (signflag && (c == '+' || c == '-'))
|
if (signflag && (c == '+' || c == '-'))
|
{
|
{
|
if (c == '-')
|
if (c == '-')
|
negate = TRUE;
|
negate = TRUE;
|
|
|
gfc_gobble_whitespace ();
|
gfc_gobble_whitespace ();
|
c = gfc_next_ascii_char ();
|
c = gfc_next_ascii_char ();
|
}
|
}
|
|
|
/* Scan significand. */
|
/* Scan significand. */
|
for (;; c = gfc_next_ascii_char (), count++)
|
for (;; c = gfc_next_ascii_char (), count++)
|
{
|
{
|
if (c == '.')
|
if (c == '.')
|
{
|
{
|
if (seen_dp)
|
if (seen_dp)
|
goto done;
|
goto done;
|
|
|
/* Check to see if "." goes with a following operator like
|
/* Check to see if "." goes with a following operator like
|
".eq.". */
|
".eq.". */
|
temp_loc = gfc_current_locus;
|
temp_loc = gfc_current_locus;
|
c = gfc_next_ascii_char ();
|
c = gfc_next_ascii_char ();
|
|
|
if (c == 'e' || c == 'd' || c == 'q')
|
if (c == 'e' || c == 'd' || c == 'q')
|
{
|
{
|
c = gfc_next_ascii_char ();
|
c = gfc_next_ascii_char ();
|
if (c == '.')
|
if (c == '.')
|
goto done; /* Operator named .e. or .d. */
|
goto done; /* Operator named .e. or .d. */
|
}
|
}
|
|
|
if (ISALPHA (c))
|
if (ISALPHA (c))
|
goto done; /* Distinguish 1.e9 from 1.eq.2 */
|
goto done; /* Distinguish 1.e9 from 1.eq.2 */
|
|
|
gfc_current_locus = temp_loc;
|
gfc_current_locus = temp_loc;
|
seen_dp = 1;
|
seen_dp = 1;
|
continue;
|
continue;
|
}
|
}
|
|
|
if (ISDIGIT (c))
|
if (ISDIGIT (c))
|
{
|
{
|
seen_digits = 1;
|
seen_digits = 1;
|
continue;
|
continue;
|
}
|
}
|
|
|
break;
|
break;
|
}
|
}
|
|
|
if (!seen_digits || (c != 'e' && c != 'd' && c != 'q'))
|
if (!seen_digits || (c != 'e' && c != 'd' && c != 'q'))
|
goto done;
|
goto done;
|
exp_char = c;
|
exp_char = c;
|
|
|
/* Scan exponent. */
|
/* Scan exponent. */
|
c = gfc_next_ascii_char ();
|
c = gfc_next_ascii_char ();
|
count++;
|
count++;
|
|
|
if (c == '+' || c == '-')
|
if (c == '+' || c == '-')
|
{ /* optional sign */
|
{ /* optional sign */
|
c = gfc_next_ascii_char ();
|
c = gfc_next_ascii_char ();
|
count++;
|
count++;
|
}
|
}
|
|
|
if (!ISDIGIT (c))
|
if (!ISDIGIT (c))
|
{
|
{
|
gfc_error ("Missing exponent in real number at %C");
|
gfc_error ("Missing exponent in real number at %C");
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
}
|
}
|
|
|
while (ISDIGIT (c))
|
while (ISDIGIT (c))
|
{
|
{
|
c = gfc_next_ascii_char ();
|
c = gfc_next_ascii_char ();
|
count++;
|
count++;
|
}
|
}
|
|
|
done:
|
done:
|
/* Check that we have a numeric constant. */
|
/* Check that we have a numeric constant. */
|
if (!seen_digits || (!seen_dp && exp_char == ' '))
|
if (!seen_digits || (!seen_dp && exp_char == ' '))
|
{
|
{
|
gfc_current_locus = old_loc;
|
gfc_current_locus = old_loc;
|
return MATCH_NO;
|
return MATCH_NO;
|
}
|
}
|
|
|
/* Convert the number. */
|
/* Convert the number. */
|
gfc_current_locus = old_loc;
|
gfc_current_locus = old_loc;
|
gfc_gobble_whitespace ();
|
gfc_gobble_whitespace ();
|
|
|
buffer = (char *) alloca (count + 1);
|
buffer = (char *) alloca (count + 1);
|
memset (buffer, '\0', count + 1);
|
memset (buffer, '\0', count + 1);
|
|
|
p = buffer;
|
p = buffer;
|
c = gfc_next_ascii_char ();
|
c = gfc_next_ascii_char ();
|
if (c == '+' || c == '-')
|
if (c == '+' || c == '-')
|
{
|
{
|
gfc_gobble_whitespace ();
|
gfc_gobble_whitespace ();
|
c = gfc_next_ascii_char ();
|
c = gfc_next_ascii_char ();
|
}
|
}
|
|
|
/* Hack for mpfr_set_str(). */
|
/* Hack for mpfr_set_str(). */
|
for (;;)
|
for (;;)
|
{
|
{
|
if (c == 'd' || c == 'q')
|
if (c == 'd' || c == 'q')
|
*p = 'e';
|
*p = 'e';
|
else
|
else
|
*p = c;
|
*p = c;
|
p++;
|
p++;
|
if (--count == 0)
|
if (--count == 0)
|
break;
|
break;
|
|
|
c = gfc_next_ascii_char ();
|
c = gfc_next_ascii_char ();
|
}
|
}
|
|
|
kind = get_kind ();
|
kind = get_kind ();
|
if (kind == -1)
|
if (kind == -1)
|
goto cleanup;
|
goto cleanup;
|
|
|
switch (exp_char)
|
switch (exp_char)
|
{
|
{
|
case 'd':
|
case 'd':
|
if (kind != -2)
|
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");
|
"kind");
|
goto cleanup;
|
goto cleanup;
|
}
|
}
|
kind = gfc_default_double_kind;
|
kind = gfc_default_double_kind;
|
break;
|
break;
|
|
|
default:
|
default:
|
if (kind == -2)
|
if (kind == -2)
|
kind = gfc_default_real_kind;
|
kind = gfc_default_real_kind;
|
|
|
if (gfc_validate_kind (BT_REAL, kind, true) < 0)
|
if (gfc_validate_kind (BT_REAL, kind, true) < 0)
|
{
|
{
|
gfc_error ("Invalid real kind %d at %C", kind);
|
gfc_error ("Invalid real kind %d at %C", kind);
|
goto cleanup;
|
goto cleanup;
|
}
|
}
|
}
|
}
|
|
|
e = gfc_convert_real (buffer, kind, &gfc_current_locus);
|
e = gfc_convert_real (buffer, kind, &gfc_current_locus);
|
if (negate)
|
if (negate)
|
mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE);
|
mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE);
|
|
|
switch (gfc_range_check (e))
|
switch (gfc_range_check (e))
|
{
|
{
|
case ARITH_OK:
|
case ARITH_OK:
|
break;
|
break;
|
case ARITH_OVERFLOW:
|
case ARITH_OVERFLOW:
|
gfc_error ("Real constant overflows its kind at %C");
|
gfc_error ("Real constant overflows its kind at %C");
|
goto cleanup;
|
goto cleanup;
|
|
|
case ARITH_UNDERFLOW:
|
case ARITH_UNDERFLOW:
|
if (gfc_option.warn_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);
|
mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
|
break;
|
break;
|
|
|
default:
|
default:
|
gfc_internal_error ("gfc_range_check() returned bad value");
|
gfc_internal_error ("gfc_range_check() returned bad value");
|
}
|
}
|
|
|
*result = e;
|
*result = e;
|
return MATCH_YES;
|
return MATCH_YES;
|
|
|
cleanup:
|
cleanup:
|
gfc_free_expr (e);
|
gfc_free_expr (e);
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
}
|
}
|
|
|
|
|
/* Match a substring reference. */
|
/* Match a substring reference. */
|
|
|
static match
|
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;
|
gfc_expr *start, *end;
|
locus old_loc;
|
locus old_loc;
|
gfc_ref *ref;
|
gfc_ref *ref;
|
match m;
|
match m;
|
|
|
start = NULL;
|
start = NULL;
|
end = NULL;
|
end = NULL;
|
|
|
old_loc = gfc_current_locus;
|
old_loc = gfc_current_locus;
|
|
|
m = gfc_match_char ('(');
|
m = gfc_match_char ('(');
|
if (m != MATCH_YES)
|
if (m != MATCH_YES)
|
return MATCH_NO;
|
return MATCH_NO;
|
|
|
if (gfc_match_char (':') != MATCH_YES)
|
if (gfc_match_char (':') != MATCH_YES)
|
{
|
{
|
if (init)
|
if (init)
|
m = gfc_match_init_expr (&start);
|
m = gfc_match_init_expr (&start);
|
else
|
else
|
m = gfc_match_expr (&start);
|
m = gfc_match_expr (&start);
|
|
|
if (m != MATCH_YES)
|
if (m != MATCH_YES)
|
{
|
{
|
m = MATCH_NO;
|
m = MATCH_NO;
|
goto cleanup;
|
goto cleanup;
|
}
|
}
|
|
|
m = gfc_match_char (':');
|
m = gfc_match_char (':');
|
if (m != MATCH_YES)
|
if (m != MATCH_YES)
|
goto cleanup;
|
goto cleanup;
|
}
|
}
|
|
|
if (gfc_match_char (')') != MATCH_YES)
|
if (gfc_match_char (')') != MATCH_YES)
|
{
|
{
|
if (init)
|
if (init)
|
m = gfc_match_init_expr (&end);
|
m = gfc_match_init_expr (&end);
|
else
|
else
|
m = gfc_match_expr (&end);
|
m = gfc_match_expr (&end);
|
|
|
if (m == MATCH_NO)
|
if (m == MATCH_NO)
|
goto syntax;
|
goto syntax;
|
if (m == MATCH_ERROR)
|
if (m == MATCH_ERROR)
|
goto cleanup;
|
goto cleanup;
|
|
|
m = gfc_match_char (')');
|
m = gfc_match_char (')');
|
if (m == MATCH_NO)
|
if (m == MATCH_NO)
|
goto syntax;
|
goto syntax;
|
}
|
}
|
|
|
/* Optimize away the (:) reference. */
|
/* Optimize away the (:) reference. */
|
if (start == NULL && end == NULL)
|
if (start == NULL && end == NULL)
|
ref = NULL;
|
ref = NULL;
|
else
|
else
|
{
|
{
|
ref = gfc_get_ref ();
|
ref = gfc_get_ref ();
|
|
|
ref->type = REF_SUBSTRING;
|
ref->type = REF_SUBSTRING;
|
if (start == NULL)
|
if (start == NULL)
|
start = gfc_int_expr (1);
|
start = gfc_int_expr (1);
|
ref->u.ss.start = start;
|
ref->u.ss.start = start;
|
if (end == NULL && cl)
|
if (end == NULL && cl)
|
end = gfc_copy_expr (cl->length);
|
end = gfc_copy_expr (cl->length);
|
ref->u.ss.end = end;
|
ref->u.ss.end = end;
|
ref->u.ss.length = cl;
|
ref->u.ss.length = cl;
|
}
|
}
|
|
|
*result = ref;
|
*result = ref;
|
return MATCH_YES;
|
return MATCH_YES;
|
|
|
syntax:
|
syntax:
|
gfc_error ("Syntax error in SUBSTRING specification at %C");
|
gfc_error ("Syntax error in SUBSTRING specification at %C");
|
m = MATCH_ERROR;
|
m = MATCH_ERROR;
|
|
|
cleanup:
|
cleanup:
|
gfc_free_expr (start);
|
gfc_free_expr (start);
|
gfc_free_expr (end);
|
gfc_free_expr (end);
|
|
|
gfc_current_locus = old_loc;
|
gfc_current_locus = old_loc;
|
return m;
|
return m;
|
}
|
}
|
|
|
|
|
/* Reads the next character of a string constant, taking care to
|
/* Reads the next character of a string constant, taking care to
|
return doubled delimiters on the input as a single instance of
|
return doubled delimiters on the input as a single instance of
|
the delimiter.
|
the delimiter.
|
|
|
Special return values for "ret" argument are:
|
Special return values for "ret" argument are:
|
-1 End of the string, as determined by the delimiter
|
-1 End of the string, as determined by the delimiter
|
-2 Unterminated string detected
|
-2 Unterminated string detected
|
|
|
Backslash codes are also expanded at this time. */
|
Backslash codes are also expanded at this time. */
|
|
|
static gfc_char_t
|
static gfc_char_t
|
next_string_char (gfc_char_t delimiter, int *ret)
|
next_string_char (gfc_char_t delimiter, int *ret)
|
{
|
{
|
locus old_locus;
|
locus old_locus;
|
gfc_char_t c;
|
gfc_char_t c;
|
|
|
c = gfc_next_char_literal (1);
|
c = gfc_next_char_literal (1);
|
*ret = 0;
|
*ret = 0;
|
|
|
if (c == '\n')
|
if (c == '\n')
|
{
|
{
|
*ret = -2;
|
*ret = -2;
|
return 0;
|
return 0;
|
}
|
}
|
|
|
if (gfc_option.flag_backslash && c == '\\')
|
if (gfc_option.flag_backslash && c == '\\')
|
{
|
{
|
old_locus = gfc_current_locus;
|
old_locus = gfc_current_locus;
|
|
|
if (gfc_match_special_char (&c) == MATCH_NO)
|
if (gfc_match_special_char (&c) == MATCH_NO)
|
gfc_current_locus = old_locus;
|
gfc_current_locus = old_locus;
|
|
|
if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings)
|
if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings)
|
gfc_warning ("Extension: backslash character at %C");
|
gfc_warning ("Extension: backslash character at %C");
|
}
|
}
|
|
|
if (c != delimiter)
|
if (c != delimiter)
|
return c;
|
return c;
|
|
|
old_locus = gfc_current_locus;
|
old_locus = gfc_current_locus;
|
c = gfc_next_char_literal (0);
|
c = gfc_next_char_literal (0);
|
|
|
if (c == delimiter)
|
if (c == delimiter)
|
return c;
|
return c;
|
gfc_current_locus = old_locus;
|
gfc_current_locus = old_locus;
|
|
|
*ret = -1;
|
*ret = -1;
|
return 0;
|
return 0;
|
}
|
}
|
|
|
|
|
/* Special case of gfc_match_name() that matches a parameter kind name
|
/* Special case of gfc_match_name() that matches a parameter kind name
|
before a string constant. This takes case of the weird but legal
|
before a string constant. This takes case of the weird but legal
|
case of:
|
case of:
|
|
|
kind_____'string'
|
kind_____'string'
|
|
|
where kind____ is a parameter. gfc_match_name() will happily slurp
|
where kind____ is a parameter. gfc_match_name() will happily slurp
|
up all the underscores, which leads to problems. If we return
|
up all the underscores, which leads to problems. If we return
|
MATCH_YES, the parse pointer points to the final underscore, which
|
MATCH_YES, the parse pointer points to the final underscore, which
|
is not part of the name. We never return MATCH_ERROR-- errors in
|
is not part of the name. We never return MATCH_ERROR-- errors in
|
the name will be detected later. */
|
the name will be detected later. */
|
|
|
static match
|
static match
|
match_charkind_name (char *name)
|
match_charkind_name (char *name)
|
{
|
{
|
locus old_loc;
|
locus old_loc;
|
char c, peek;
|
char c, peek;
|
int len;
|
int len;
|
|
|
gfc_gobble_whitespace ();
|
gfc_gobble_whitespace ();
|
c = gfc_next_ascii_char ();
|
c = gfc_next_ascii_char ();
|
if (!ISALPHA (c))
|
if (!ISALPHA (c))
|
return MATCH_NO;
|
return MATCH_NO;
|
|
|
*name++ = c;
|
*name++ = c;
|
len = 1;
|
len = 1;
|
|
|
for (;;)
|
for (;;)
|
{
|
{
|
old_loc = gfc_current_locus;
|
old_loc = gfc_current_locus;
|
c = gfc_next_ascii_char ();
|
c = gfc_next_ascii_char ();
|
|
|
if (c == '_')
|
if (c == '_')
|
{
|
{
|
peek = gfc_peek_ascii_char ();
|
peek = gfc_peek_ascii_char ();
|
|
|
if (peek == '\'' || peek == '\"')
|
if (peek == '\'' || peek == '\"')
|
{
|
{
|
gfc_current_locus = old_loc;
|
gfc_current_locus = old_loc;
|
*name = '\0';
|
*name = '\0';
|
return MATCH_YES;
|
return MATCH_YES;
|
}
|
}
|
}
|
}
|
|
|
if (!ISALNUM (c)
|
if (!ISALNUM (c)
|
&& c != '_'
|
&& c != '_'
|
&& (c != '$' || !gfc_option.flag_dollar_ok))
|
&& (c != '$' || !gfc_option.flag_dollar_ok))
|
break;
|
break;
|
|
|
*name++ = c;
|
*name++ = c;
|
if (++len > GFC_MAX_SYMBOL_LEN)
|
if (++len > GFC_MAX_SYMBOL_LEN)
|
break;
|
break;
|
}
|
}
|
|
|
return MATCH_NO;
|
return MATCH_NO;
|
}
|
}
|
|
|
|
|
/* See if the current input matches a character constant. Lots of
|
/* See if the current input matches a character constant. Lots of
|
contortions have to be done to match the kind parameter which comes
|
contortions have to be done to match the kind parameter which comes
|
before the actual string. The main consideration is that we don't
|
before the actual string. The main consideration is that we don't
|
want to error out too quickly. For example, we don't actually do
|
want to error out too quickly. For example, we don't actually do
|
any validation of the kinds until we have actually seen a legal
|
any validation of the kinds until we have actually seen a legal
|
delimiter. Using match_kind_param() generates errors too quickly. */
|
delimiter. Using match_kind_param() generates errors too quickly. */
|
|
|
static match
|
static match
|
match_string_constant (gfc_expr **result)
|
match_string_constant (gfc_expr **result)
|
{
|
{
|
char name[GFC_MAX_SYMBOL_LEN + 1], peek;
|
char name[GFC_MAX_SYMBOL_LEN + 1], peek;
|
int i, kind, length, warn_ampersand, ret;
|
int i, kind, length, warn_ampersand, ret;
|
locus old_locus, start_locus;
|
locus old_locus, start_locus;
|
gfc_symbol *sym;
|
gfc_symbol *sym;
|
gfc_expr *e;
|
gfc_expr *e;
|
const char *q;
|
const char *q;
|
match m;
|
match m;
|
gfc_char_t c, delimiter, *p;
|
gfc_char_t c, delimiter, *p;
|
|
|
old_locus = gfc_current_locus;
|
old_locus = gfc_current_locus;
|
|
|
gfc_gobble_whitespace ();
|
gfc_gobble_whitespace ();
|
|
|
start_locus = gfc_current_locus;
|
start_locus = gfc_current_locus;
|
|
|
c = gfc_next_char ();
|
c = gfc_next_char ();
|
if (c == '\'' || c == '"')
|
if (c == '\'' || c == '"')
|
{
|
{
|
kind = gfc_default_character_kind;
|
kind = gfc_default_character_kind;
|
goto got_delim;
|
goto got_delim;
|
}
|
}
|
|
|
if (gfc_wide_is_digit (c))
|
if (gfc_wide_is_digit (c))
|
{
|
{
|
kind = 0;
|
kind = 0;
|
|
|
while (gfc_wide_is_digit (c))
|
while (gfc_wide_is_digit (c))
|
{
|
{
|
kind = kind * 10 + c - '0';
|
kind = kind * 10 + c - '0';
|
if (kind > 9999999)
|
if (kind > 9999999)
|
goto no_match;
|
goto no_match;
|
c = gfc_next_char ();
|
c = gfc_next_char ();
|
}
|
}
|
|
|
}
|
}
|
else
|
else
|
{
|
{
|
gfc_current_locus = old_locus;
|
gfc_current_locus = old_locus;
|
|
|
m = match_charkind_name (name);
|
m = match_charkind_name (name);
|
if (m != MATCH_YES)
|
if (m != MATCH_YES)
|
goto no_match;
|
goto no_match;
|
|
|
if (gfc_find_symbol (name, NULL, 1, &sym)
|
if (gfc_find_symbol (name, NULL, 1, &sym)
|
|| sym == NULL
|
|| sym == NULL
|
|| sym->attr.flavor != FL_PARAMETER)
|
|| sym->attr.flavor != FL_PARAMETER)
|
goto no_match;
|
goto no_match;
|
|
|
kind = -1;
|
kind = -1;
|
c = gfc_next_char ();
|
c = gfc_next_char ();
|
}
|
}
|
|
|
if (c == ' ')
|
if (c == ' ')
|
{
|
{
|
gfc_gobble_whitespace ();
|
gfc_gobble_whitespace ();
|
c = gfc_next_char ();
|
c = gfc_next_char ();
|
}
|
}
|
|
|
if (c != '_')
|
if (c != '_')
|
goto no_match;
|
goto no_match;
|
|
|
gfc_gobble_whitespace ();
|
gfc_gobble_whitespace ();
|
start_locus = gfc_current_locus;
|
start_locus = gfc_current_locus;
|
|
|
c = gfc_next_char ();
|
c = gfc_next_char ();
|
if (c != '\'' && c != '"')
|
if (c != '\'' && c != '"')
|
goto no_match;
|
goto no_match;
|
|
|
if (kind == -1)
|
if (kind == -1)
|
{
|
{
|
q = gfc_extract_int (sym->value, &kind);
|
q = gfc_extract_int (sym->value, &kind);
|
if (q != NULL)
|
if (q != NULL)
|
{
|
{
|
gfc_error (q);
|
gfc_error (q);
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
}
|
}
|
gfc_set_sym_referenced (sym);
|
gfc_set_sym_referenced (sym);
|
}
|
}
|
|
|
if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
|
if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
|
{
|
{
|
gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind);
|
gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind);
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
}
|
}
|
|
|
got_delim:
|
got_delim:
|
/* Scan the string into a block of memory by first figuring out how
|
/* Scan the string into a block of memory by first figuring out how
|
long it is, allocating the structure, then re-reading it. This
|
long it is, allocating the structure, then re-reading it. This
|
isn't particularly efficient, but string constants aren't that
|
isn't particularly efficient, but string constants aren't that
|
common in most code. TODO: Use obstacks? */
|
common in most code. TODO: Use obstacks? */
|
|
|
delimiter = c;
|
delimiter = c;
|
length = 0;
|
length = 0;
|
|
|
for (;;)
|
for (;;)
|
{
|
{
|
c = next_string_char (delimiter, &ret);
|
c = next_string_char (delimiter, &ret);
|
if (ret == -1)
|
if (ret == -1)
|
break;
|
break;
|
if (ret == -2)
|
if (ret == -2)
|
{
|
{
|
gfc_current_locus = start_locus;
|
gfc_current_locus = start_locus;
|
gfc_error ("Unterminated character constant beginning at %C");
|
gfc_error ("Unterminated character constant beginning at %C");
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
}
|
}
|
|
|
length++;
|
length++;
|
}
|
}
|
|
|
/* Peek at the next character to see if it is a b, o, z, or x for the
|
/* Peek at the next character to see if it is a b, o, z, or x for the
|
postfixed BOZ literal constants. */
|
postfixed BOZ literal constants. */
|
peek = gfc_peek_ascii_char ();
|
peek = gfc_peek_ascii_char ();
|
if (peek == 'b' || peek == 'o' || peek =='z' || peek == 'x')
|
if (peek == 'b' || peek == 'o' || peek =='z' || peek == 'x')
|
goto no_match;
|
goto no_match;
|
|
|
|
|
e = gfc_get_expr ();
|
e = gfc_get_expr ();
|
|
|
e->expr_type = EXPR_CONSTANT;
|
e->expr_type = EXPR_CONSTANT;
|
e->ref = NULL;
|
e->ref = NULL;
|
e->ts.type = BT_CHARACTER;
|
e->ts.type = BT_CHARACTER;
|
e->ts.kind = kind;
|
e->ts.kind = kind;
|
e->ts.is_c_interop = 0;
|
e->ts.is_c_interop = 0;
|
e->ts.is_iso_c = 0;
|
e->ts.is_iso_c = 0;
|
e->where = start_locus;
|
e->where = start_locus;
|
|
|
e->value.character.string = p = gfc_get_wide_string (length + 1);
|
e->value.character.string = p = gfc_get_wide_string (length + 1);
|
e->value.character.length = length;
|
e->value.character.length = length;
|
|
|
gfc_current_locus = start_locus;
|
gfc_current_locus = start_locus;
|
gfc_next_char (); /* Skip delimiter */
|
gfc_next_char (); /* Skip delimiter */
|
|
|
/* We disable the warning for the following loop as the warning has already
|
/* We disable the warning for the following loop as the warning has already
|
been printed in the loop above. */
|
been printed in the loop above. */
|
warn_ampersand = gfc_option.warn_ampersand;
|
warn_ampersand = gfc_option.warn_ampersand;
|
gfc_option.warn_ampersand = 0;
|
gfc_option.warn_ampersand = 0;
|
|
|
for (i = 0; i < length; i++)
|
for (i = 0; i < length; i++)
|
{
|
{
|
c = next_string_char (delimiter, &ret);
|
c = next_string_char (delimiter, &ret);
|
|
|
if (!gfc_check_character_range (c, kind))
|
if (!gfc_check_character_range (c, kind))
|
{
|
{
|
gfc_error ("Character '%s' in string at %C is not representable "
|
gfc_error ("Character '%s' in string at %C is not representable "
|
"in character kind %d", gfc_print_wide_char (c), kind);
|
"in character kind %d", gfc_print_wide_char (c), kind);
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
}
|
}
|
|
|
*p++ = c;
|
*p++ = c;
|
}
|
}
|
|
|
*p = '\0'; /* TODO: C-style string is for development/debug purposes. */
|
*p = '\0'; /* TODO: C-style string is for development/debug purposes. */
|
gfc_option.warn_ampersand = warn_ampersand;
|
gfc_option.warn_ampersand = warn_ampersand;
|
|
|
next_string_char (delimiter, &ret);
|
next_string_char (delimiter, &ret);
|
if (ret != -1)
|
if (ret != -1)
|
gfc_internal_error ("match_string_constant(): Delimiter not found");
|
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) != MATCH_NO)
|
e->expr_type = EXPR_SUBSTRING;
|
e->expr_type = EXPR_SUBSTRING;
|
|
|
*result = e;
|
*result = e;
|
|
|
return MATCH_YES;
|
return MATCH_YES;
|
|
|
no_match:
|
no_match:
|
gfc_current_locus = old_locus;
|
gfc_current_locus = old_locus;
|
return MATCH_NO;
|
return MATCH_NO;
|
}
|
}
|
|
|
|
|
/* Match a .true. or .false. Returns 1 if a .true. was found,
|
/* Match a .true. or .false. Returns 1 if a .true. was found,
|
0 if a .false. was found, and -1 otherwise. */
|
0 if a .false. was found, and -1 otherwise. */
|
static int
|
static int
|
match_logical_constant_string (void)
|
match_logical_constant_string (void)
|
{
|
{
|
locus orig_loc = gfc_current_locus;
|
locus orig_loc = gfc_current_locus;
|
|
|
gfc_gobble_whitespace ();
|
gfc_gobble_whitespace ();
|
if (gfc_next_ascii_char () == '.')
|
if (gfc_next_ascii_char () == '.')
|
{
|
{
|
char ch = gfc_next_ascii_char ();
|
char ch = gfc_next_ascii_char ();
|
if (ch == 'f')
|
if (ch == 'f')
|
{
|
{
|
if (gfc_next_ascii_char () == 'a'
|
if (gfc_next_ascii_char () == 'a'
|
&& gfc_next_ascii_char () == 'l'
|
&& gfc_next_ascii_char () == 'l'
|
&& gfc_next_ascii_char () == 's'
|
&& gfc_next_ascii_char () == 's'
|
&& gfc_next_ascii_char () == 'e'
|
&& gfc_next_ascii_char () == 'e'
|
&& gfc_next_ascii_char () == '.')
|
&& gfc_next_ascii_char () == '.')
|
/* Matched ".false.". */
|
/* Matched ".false.". */
|
return 0;
|
return 0;
|
}
|
}
|
else if (ch == 't')
|
else if (ch == 't')
|
{
|
{
|
if (gfc_next_ascii_char () == 'r'
|
if (gfc_next_ascii_char () == 'r'
|
&& gfc_next_ascii_char () == 'u'
|
&& gfc_next_ascii_char () == 'u'
|
&& gfc_next_ascii_char () == 'e'
|
&& gfc_next_ascii_char () == 'e'
|
&& gfc_next_ascii_char () == '.')
|
&& gfc_next_ascii_char () == '.')
|
/* Matched ".true.". */
|
/* Matched ".true.". */
|
return 1;
|
return 1;
|
}
|
}
|
}
|
}
|
gfc_current_locus = orig_loc;
|
gfc_current_locus = orig_loc;
|
return -1;
|
return -1;
|
}
|
}
|
|
|
/* Match a .true. or .false. */
|
/* Match a .true. or .false. */
|
|
|
static match
|
static match
|
match_logical_constant (gfc_expr **result)
|
match_logical_constant (gfc_expr **result)
|
{
|
{
|
gfc_expr *e;
|
gfc_expr *e;
|
int i, kind;
|
int i, kind;
|
|
|
i = match_logical_constant_string ();
|
i = match_logical_constant_string ();
|
if (i == -1)
|
if (i == -1)
|
return MATCH_NO;
|
return MATCH_NO;
|
|
|
kind = get_kind ();
|
kind = get_kind ();
|
if (kind == -1)
|
if (kind == -1)
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
if (kind == -2)
|
if (kind == -2)
|
kind = gfc_default_logical_kind;
|
kind = gfc_default_logical_kind;
|
|
|
if (gfc_validate_kind (BT_LOGICAL, kind, true) < 0)
|
if (gfc_validate_kind (BT_LOGICAL, kind, true) < 0)
|
{
|
{
|
gfc_error ("Bad kind for logical constant at %C");
|
gfc_error ("Bad kind for logical constant at %C");
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
}
|
}
|
|
|
e = gfc_get_expr ();
|
e = gfc_get_expr ();
|
|
|
e->expr_type = EXPR_CONSTANT;
|
e->expr_type = EXPR_CONSTANT;
|
e->value.logical = i;
|
e->value.logical = i;
|
e->ts.type = BT_LOGICAL;
|
e->ts.type = BT_LOGICAL;
|
e->ts.kind = kind;
|
e->ts.kind = kind;
|
e->ts.is_c_interop = 0;
|
e->ts.is_c_interop = 0;
|
e->ts.is_iso_c = 0;
|
e->ts.is_iso_c = 0;
|
e->where = gfc_current_locus;
|
e->where = gfc_current_locus;
|
|
|
*result = e;
|
*result = e;
|
return MATCH_YES;
|
return MATCH_YES;
|
}
|
}
|
|
|
|
|
/* Match a real or imaginary part of a complex constant that is a
|
/* Match a real or imaginary part of a complex constant that is a
|
symbolic constant. */
|
symbolic constant. */
|
|
|
static match
|
static match
|
match_sym_complex_part (gfc_expr **result)
|
match_sym_complex_part (gfc_expr **result)
|
{
|
{
|
char name[GFC_MAX_SYMBOL_LEN + 1];
|
char name[GFC_MAX_SYMBOL_LEN + 1];
|
gfc_symbol *sym;
|
gfc_symbol *sym;
|
gfc_expr *e;
|
gfc_expr *e;
|
match m;
|
match m;
|
|
|
m = gfc_match_name (name);
|
m = gfc_match_name (name);
|
if (m != MATCH_YES)
|
if (m != MATCH_YES)
|
return m;
|
return m;
|
|
|
if (gfc_find_symbol (name, NULL, 1, &sym) || sym == NULL)
|
if (gfc_find_symbol (name, NULL, 1, &sym) || sym == NULL)
|
return MATCH_NO;
|
return MATCH_NO;
|
|
|
if (sym->attr.flavor != FL_PARAMETER)
|
if (sym->attr.flavor != FL_PARAMETER)
|
{
|
{
|
gfc_error ("Expected PARAMETER symbol in complex constant at %C");
|
gfc_error ("Expected PARAMETER symbol in complex constant at %C");
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
}
|
}
|
|
|
if (!gfc_numeric_ts (&sym->value->ts))
|
if (!gfc_numeric_ts (&sym->value->ts))
|
{
|
{
|
gfc_error ("Numeric PARAMETER required in complex constant at %C");
|
gfc_error ("Numeric PARAMETER required in complex constant at %C");
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
}
|
}
|
|
|
if (sym->value->rank != 0)
|
if (sym->value->rank != 0)
|
{
|
{
|
gfc_error ("Scalar PARAMETER required in complex constant at %C");
|
gfc_error ("Scalar PARAMETER required in complex constant at %C");
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
}
|
}
|
|
|
if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PARAMETER symbol in "
|
if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PARAMETER symbol in "
|
"complex constant at %C") == FAILURE)
|
"complex constant at %C") == FAILURE)
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
|
|
switch (sym->value->ts.type)
|
switch (sym->value->ts.type)
|
{
|
{
|
case BT_REAL:
|
case BT_REAL:
|
e = gfc_copy_expr (sym->value);
|
e = gfc_copy_expr (sym->value);
|
break;
|
break;
|
|
|
case BT_COMPLEX:
|
case BT_COMPLEX:
|
e = gfc_complex2real (sym->value, sym->value->ts.kind);
|
e = gfc_complex2real (sym->value, sym->value->ts.kind);
|
if (e == NULL)
|
if (e == NULL)
|
goto error;
|
goto error;
|
break;
|
break;
|
|
|
case BT_INTEGER:
|
case BT_INTEGER:
|
e = gfc_int2real (sym->value, gfc_default_real_kind);
|
e = gfc_int2real (sym->value, gfc_default_real_kind);
|
if (e == NULL)
|
if (e == NULL)
|
goto error;
|
goto error;
|
break;
|
break;
|
|
|
default:
|
default:
|
gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
|
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;
|
return MATCH_YES;
|
|
|
error:
|
error:
|
gfc_error ("Error converting PARAMETER constant in complex constant at %C");
|
gfc_error ("Error converting PARAMETER constant in complex constant at %C");
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
}
|
}
|
|
|
|
|
/* Match a real or imaginary part of a complex number. */
|
/* Match a real or imaginary part of a complex number. */
|
|
|
static match
|
static match
|
match_complex_part (gfc_expr **result)
|
match_complex_part (gfc_expr **result)
|
{
|
{
|
match m;
|
match m;
|
|
|
m = match_sym_complex_part (result);
|
m = match_sym_complex_part (result);
|
if (m != MATCH_NO)
|
if (m != MATCH_NO)
|
return m;
|
return m;
|
|
|
m = match_real_constant (result, 1);
|
m = match_real_constant (result, 1);
|
if (m != MATCH_NO)
|
if (m != MATCH_NO)
|
return m;
|
return m;
|
|
|
return match_integer_constant (result, 1);
|
return match_integer_constant (result, 1);
|
}
|
}
|
|
|
|
|
/* Try to match a complex constant. */
|
/* Try to match a complex constant. */
|
|
|
static match
|
static match
|
match_complex_constant (gfc_expr **result)
|
match_complex_constant (gfc_expr **result)
|
{
|
{
|
gfc_expr *e, *real, *imag;
|
gfc_expr *e, *real, *imag;
|
gfc_error_buf old_error;
|
gfc_error_buf old_error;
|
gfc_typespec target;
|
gfc_typespec target;
|
locus old_loc;
|
locus old_loc;
|
int kind;
|
int kind;
|
match m;
|
match m;
|
|
|
old_loc = gfc_current_locus;
|
old_loc = gfc_current_locus;
|
real = imag = e = NULL;
|
real = imag = e = NULL;
|
|
|
m = gfc_match_char ('(');
|
m = gfc_match_char ('(');
|
if (m != MATCH_YES)
|
if (m != MATCH_YES)
|
return m;
|
return m;
|
|
|
gfc_push_error (&old_error);
|
gfc_push_error (&old_error);
|
|
|
m = match_complex_part (&real);
|
m = match_complex_part (&real);
|
if (m == MATCH_NO)
|
if (m == MATCH_NO)
|
{
|
{
|
gfc_free_error (&old_error);
|
gfc_free_error (&old_error);
|
goto cleanup;
|
goto cleanup;
|
}
|
}
|
|
|
if (gfc_match_char (',') == MATCH_NO)
|
if (gfc_match_char (',') == MATCH_NO)
|
{
|
{
|
gfc_pop_error (&old_error);
|
gfc_pop_error (&old_error);
|
m = MATCH_NO;
|
m = MATCH_NO;
|
goto cleanup;
|
goto cleanup;
|
}
|
}
|
|
|
/* If m is error, then something was wrong with the real part and we
|
/* If m is error, then something was wrong with the real part and we
|
assume we have a complex constant because we've seen the ','. An
|
assume we have a complex constant because we've seen the ','. An
|
ambiguous case here is the start of an iterator list of some
|
ambiguous case here is the start of an iterator list of some
|
sort. These sort of lists are matched prior to coming here. */
|
sort. These sort of lists are matched prior to coming here. */
|
|
|
if (m == MATCH_ERROR)
|
if (m == MATCH_ERROR)
|
{
|
{
|
gfc_free_error (&old_error);
|
gfc_free_error (&old_error);
|
goto cleanup;
|
goto cleanup;
|
}
|
}
|
gfc_pop_error (&old_error);
|
gfc_pop_error (&old_error);
|
|
|
m = match_complex_part (&imag);
|
m = match_complex_part (&imag);
|
if (m == MATCH_NO)
|
if (m == MATCH_NO)
|
goto syntax;
|
goto syntax;
|
if (m == MATCH_ERROR)
|
if (m == MATCH_ERROR)
|
goto cleanup;
|
goto cleanup;
|
|
|
m = gfc_match_char (')');
|
m = gfc_match_char (')');
|
if (m == MATCH_NO)
|
if (m == MATCH_NO)
|
{
|
{
|
/* Give the matcher for implied do-loops a chance to run. This
|
/* Give the matcher for implied do-loops a chance to run. This
|
yields a much saner error message for (/ (i, 4=i, 6) /). */
|
yields a much saner error message for (/ (i, 4=i, 6) /). */
|
if (gfc_peek_ascii_char () == '=')
|
if (gfc_peek_ascii_char () == '=')
|
{
|
{
|
m = MATCH_ERROR;
|
m = MATCH_ERROR;
|
goto cleanup;
|
goto cleanup;
|
}
|
}
|
else
|
else
|
goto syntax;
|
goto syntax;
|
}
|
}
|
|
|
if (m == MATCH_ERROR)
|
if (m == MATCH_ERROR)
|
goto cleanup;
|
goto cleanup;
|
|
|
/* Decide on the kind of this complex number. */
|
/* Decide on the kind of this complex number. */
|
if (real->ts.type == BT_REAL)
|
if (real->ts.type == BT_REAL)
|
{
|
{
|
if (imag->ts.type == BT_REAL)
|
if (imag->ts.type == BT_REAL)
|
kind = gfc_kind_max (real, imag);
|
kind = gfc_kind_max (real, imag);
|
else
|
else
|
kind = real->ts.kind;
|
kind = real->ts.kind;
|
}
|
}
|
else
|
else
|
{
|
{
|
if (imag->ts.type == BT_REAL)
|
if (imag->ts.type == BT_REAL)
|
kind = imag->ts.kind;
|
kind = imag->ts.kind;
|
else
|
else
|
kind = gfc_default_real_kind;
|
kind = gfc_default_real_kind;
|
}
|
}
|
target.type = BT_REAL;
|
target.type = BT_REAL;
|
target.kind = kind;
|
target.kind = kind;
|
target.is_c_interop = 0;
|
target.is_c_interop = 0;
|
target.is_iso_c = 0;
|
target.is_iso_c = 0;
|
|
|
if (real->ts.type != BT_REAL || kind != real->ts.kind)
|
if (real->ts.type != BT_REAL || kind != real->ts.kind)
|
gfc_convert_type (real, &target, 2);
|
gfc_convert_type (real, &target, 2);
|
if (imag->ts.type != BT_REAL || kind != imag->ts.kind)
|
if (imag->ts.type != BT_REAL || kind != imag->ts.kind)
|
gfc_convert_type (imag, &target, 2);
|
gfc_convert_type (imag, &target, 2);
|
|
|
e = gfc_convert_complex (real, imag, kind);
|
e = gfc_convert_complex (real, imag, kind);
|
e->where = gfc_current_locus;
|
e->where = gfc_current_locus;
|
|
|
gfc_free_expr (real);
|
gfc_free_expr (real);
|
gfc_free_expr (imag);
|
gfc_free_expr (imag);
|
|
|
*result = e;
|
*result = e;
|
return MATCH_YES;
|
return MATCH_YES;
|
|
|
syntax:
|
syntax:
|
gfc_error ("Syntax error in COMPLEX constant at %C");
|
gfc_error ("Syntax error in COMPLEX constant at %C");
|
m = MATCH_ERROR;
|
m = MATCH_ERROR;
|
|
|
cleanup:
|
cleanup:
|
gfc_free_expr (e);
|
gfc_free_expr (e);
|
gfc_free_expr (real);
|
gfc_free_expr (real);
|
gfc_free_expr (imag);
|
gfc_free_expr (imag);
|
gfc_current_locus = old_loc;
|
gfc_current_locus = old_loc;
|
|
|
return m;
|
return m;
|
}
|
}
|
|
|
|
|
/* Match constants in any of several forms. Returns nonzero for a
|
/* Match constants in any of several forms. Returns nonzero for a
|
match, zero for no match. */
|
match, zero for no match. */
|
|
|
match
|
match
|
gfc_match_literal_constant (gfc_expr **result, int signflag)
|
gfc_match_literal_constant (gfc_expr **result, int signflag)
|
{
|
{
|
match m;
|
match m;
|
|
|
m = match_complex_constant (result);
|
m = match_complex_constant (result);
|
if (m != MATCH_NO)
|
if (m != MATCH_NO)
|
return m;
|
return m;
|
|
|
m = match_string_constant (result);
|
m = match_string_constant (result);
|
if (m != MATCH_NO)
|
if (m != MATCH_NO)
|
return m;
|
return m;
|
|
|
m = match_boz_constant (result);
|
m = match_boz_constant (result);
|
if (m != MATCH_NO)
|
if (m != MATCH_NO)
|
return m;
|
return m;
|
|
|
m = match_real_constant (result, signflag);
|
m = match_real_constant (result, signflag);
|
if (m != MATCH_NO)
|
if (m != MATCH_NO)
|
return m;
|
return m;
|
|
|
m = match_hollerith_constant (result);
|
m = match_hollerith_constant (result);
|
if (m != MATCH_NO)
|
if (m != MATCH_NO)
|
return m;
|
return m;
|
|
|
m = match_integer_constant (result, signflag);
|
m = match_integer_constant (result, signflag);
|
if (m != MATCH_NO)
|
if (m != MATCH_NO)
|
return m;
|
return m;
|
|
|
m = match_logical_constant (result);
|
m = match_logical_constant (result);
|
if (m != MATCH_NO)
|
if (m != MATCH_NO)
|
return m;
|
return m;
|
|
|
return MATCH_NO;
|
return MATCH_NO;
|
}
|
}
|
|
|
|
|
/* This checks if a symbol is the return value of an encompassing function.
|
/* This checks if a symbol is the return value of an encompassing function.
|
Function nesting can be maximally two levels deep, but we may have
|
Function nesting can be maximally two levels deep, but we may have
|
additional local namespaces like BLOCK etc. */
|
additional local namespaces like BLOCK etc. */
|
|
|
bool
|
bool
|
gfc_is_function_return_value (gfc_symbol *sym, gfc_namespace *ns)
|
gfc_is_function_return_value (gfc_symbol *sym, gfc_namespace *ns)
|
{
|
{
|
if (!sym->attr.function || (sym->result != sym))
|
if (!sym->attr.function || (sym->result != sym))
|
return false;
|
return false;
|
while (ns)
|
while (ns)
|
{
|
{
|
if (ns->proc_name == sym)
|
if (ns->proc_name == sym)
|
return true;
|
return true;
|
ns = ns->parent;
|
ns = ns->parent;
|
}
|
}
|
return false;
|
return false;
|
}
|
}
|
|
|
|
|
/* Match a single actual argument value. An actual argument is
|
/* Match a single actual argument value. An actual argument is
|
usually an expression, but can also be a procedure name. If the
|
usually an expression, but can also be a procedure name. If the
|
argument is a single name, it is not always possible to tell
|
argument is a single name, it is not always possible to tell
|
whether the name is a dummy procedure or not. We treat these cases
|
whether the name is a dummy procedure or not. We treat these cases
|
by creating an argument that looks like a dummy procedure and
|
by creating an argument that looks like a dummy procedure and
|
fixing things later during resolution. */
|
fixing things later during resolution. */
|
|
|
static match
|
static match
|
match_actual_arg (gfc_expr **result)
|
match_actual_arg (gfc_expr **result)
|
{
|
{
|
char name[GFC_MAX_SYMBOL_LEN + 1];
|
char name[GFC_MAX_SYMBOL_LEN + 1];
|
gfc_symtree *symtree;
|
gfc_symtree *symtree;
|
locus where, w;
|
locus where, w;
|
gfc_expr *e;
|
gfc_expr *e;
|
char c;
|
char c;
|
|
|
gfc_gobble_whitespace ();
|
gfc_gobble_whitespace ();
|
where = gfc_current_locus;
|
where = gfc_current_locus;
|
|
|
switch (gfc_match_name (name))
|
switch (gfc_match_name (name))
|
{
|
{
|
case MATCH_ERROR:
|
case MATCH_ERROR:
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
|
|
case MATCH_NO:
|
case MATCH_NO:
|
break;
|
break;
|
|
|
case MATCH_YES:
|
case MATCH_YES:
|
w = gfc_current_locus;
|
w = gfc_current_locus;
|
gfc_gobble_whitespace ();
|
gfc_gobble_whitespace ();
|
c = gfc_next_ascii_char ();
|
c = gfc_next_ascii_char ();
|
gfc_current_locus = w;
|
gfc_current_locus = w;
|
|
|
if (c != ',' && c != ')')
|
if (c != ',' && c != ')')
|
break;
|
break;
|
|
|
if (gfc_find_sym_tree (name, NULL, 1, &symtree))
|
if (gfc_find_sym_tree (name, NULL, 1, &symtree))
|
break;
|
break;
|
/* Handle error elsewhere. */
|
/* Handle error elsewhere. */
|
|
|
/* Eliminate a couple of common cases where we know we don't
|
/* Eliminate a couple of common cases where we know we don't
|
have a function argument. */
|
have a function argument. */
|
if (symtree == NULL)
|
if (symtree == NULL)
|
{
|
{
|
gfc_get_sym_tree (name, NULL, &symtree, false);
|
gfc_get_sym_tree (name, NULL, &symtree, false);
|
gfc_set_sym_referenced (symtree->n.sym);
|
gfc_set_sym_referenced (symtree->n.sym);
|
}
|
}
|
else
|
else
|
{
|
{
|
gfc_symbol *sym;
|
gfc_symbol *sym;
|
|
|
sym = symtree->n.sym;
|
sym = symtree->n.sym;
|
gfc_set_sym_referenced (sym);
|
gfc_set_sym_referenced (sym);
|
if (sym->attr.flavor != FL_PROCEDURE
|
if (sym->attr.flavor != FL_PROCEDURE
|
&& sym->attr.flavor != FL_UNKNOWN)
|
&& sym->attr.flavor != FL_UNKNOWN)
|
break;
|
break;
|
|
|
if (sym->attr.in_common && !sym->attr.proc_pointer)
|
if (sym->attr.in_common && !sym->attr.proc_pointer)
|
{
|
{
|
gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name,
|
gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name,
|
&sym->declared_at);
|
&sym->declared_at);
|
break;
|
break;
|
}
|
}
|
|
|
/* If the symbol is a function with itself as the result and
|
/* If the symbol is a function with itself as the result and
|
is being defined, then we have a variable. */
|
is being defined, then we have a variable. */
|
if (sym->attr.function && sym->result == sym)
|
if (sym->attr.function && sym->result == sym)
|
{
|
{
|
if (gfc_is_function_return_value (sym, gfc_current_ns))
|
if (gfc_is_function_return_value (sym, gfc_current_ns))
|
break;
|
break;
|
|
|
if (sym->attr.entry
|
if (sym->attr.entry
|
&& (sym->ns == gfc_current_ns
|
&& (sym->ns == gfc_current_ns
|
|| sym->ns == gfc_current_ns->parent))
|
|| sym->ns == gfc_current_ns->parent))
|
{
|
{
|
gfc_entry_list *el = NULL;
|
gfc_entry_list *el = NULL;
|
|
|
for (el = sym->ns->entries; el; el = el->next)
|
for (el = sym->ns->entries; el; el = el->next)
|
if (sym == el->sym)
|
if (sym == el->sym)
|
break;
|
break;
|
|
|
if (el)
|
if (el)
|
break;
|
break;
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
e = gfc_get_expr (); /* Leave it unknown for now */
|
e = gfc_get_expr (); /* Leave it unknown for now */
|
e->symtree = symtree;
|
e->symtree = symtree;
|
e->expr_type = EXPR_VARIABLE;
|
e->expr_type = EXPR_VARIABLE;
|
e->ts.type = BT_PROCEDURE;
|
e->ts.type = BT_PROCEDURE;
|
e->where = where;
|
e->where = where;
|
|
|
*result = e;
|
*result = e;
|
return MATCH_YES;
|
return MATCH_YES;
|
}
|
}
|
|
|
gfc_current_locus = where;
|
gfc_current_locus = where;
|
return gfc_match_expr (result);
|
return gfc_match_expr (result);
|
}
|
}
|
|
|
|
|
/* Match a keyword argument. */
|
/* Match a keyword argument. */
|
|
|
static match
|
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];
|
char name[GFC_MAX_SYMBOL_LEN + 1];
|
gfc_actual_arglist *a;
|
gfc_actual_arglist *a;
|
locus name_locus;
|
locus name_locus;
|
match m;
|
match m;
|
|
|
name_locus = gfc_current_locus;
|
name_locus = gfc_current_locus;
|
m = gfc_match_name (name);
|
m = gfc_match_name (name);
|
|
|
if (m != MATCH_YES)
|
if (m != MATCH_YES)
|
goto cleanup;
|
goto cleanup;
|
if (gfc_match_char ('=') != MATCH_YES)
|
if (gfc_match_char ('=') != MATCH_YES)
|
{
|
{
|
m = MATCH_NO;
|
m = MATCH_NO;
|
goto cleanup;
|
goto cleanup;
|
}
|
}
|
|
|
m = match_actual_arg (&actual->expr);
|
m = match_actual_arg (&actual->expr);
|
if (m != MATCH_YES)
|
if (m != MATCH_YES)
|
goto cleanup;
|
goto cleanup;
|
|
|
/* Make sure this name has not appeared yet. */
|
/* Make sure this name has not appeared yet. */
|
|
|
if (name[0] != '\0')
|
if (name[0] != '\0')
|
{
|
{
|
for (a = base; a; a = a->next)
|
for (a = base; a; a = a->next)
|
if (a->name != NULL && strcmp (a->name, name) == 0)
|
if (a->name != NULL && strcmp (a->name, name) == 0)
|
{
|
{
|
gfc_error ("Keyword '%s' at %C has already appeared in the "
|
gfc_error ("Keyword '%s' at %C has already appeared in the "
|
"current argument list", name);
|
"current argument list", name);
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
}
|
}
|
}
|
}
|
|
|
actual->name = gfc_get_string (name);
|
actual->name = gfc_get_string (name);
|
return MATCH_YES;
|
return MATCH_YES;
|
|
|
cleanup:
|
cleanup:
|
gfc_current_locus = name_locus;
|
gfc_current_locus = name_locus;
|
return m;
|
return m;
|
}
|
}
|
|
|
|
|
/* Match an argument list function, such as %VAL. */
|
/* Match an argument list function, such as %VAL. */
|
|
|
static match
|
static match
|
match_arg_list_function (gfc_actual_arglist *result)
|
match_arg_list_function (gfc_actual_arglist *result)
|
{
|
{
|
char name[GFC_MAX_SYMBOL_LEN + 1];
|
char name[GFC_MAX_SYMBOL_LEN + 1];
|
locus old_locus;
|
locus old_locus;
|
match m;
|
match m;
|
|
|
old_locus = gfc_current_locus;
|
old_locus = gfc_current_locus;
|
|
|
if (gfc_match_char ('%') != MATCH_YES)
|
if (gfc_match_char ('%') != MATCH_YES)
|
{
|
{
|
m = MATCH_NO;
|
m = MATCH_NO;
|
goto cleanup;
|
goto cleanup;
|
}
|
}
|
|
|
m = gfc_match ("%n (", name);
|
m = gfc_match ("%n (", name);
|
if (m != MATCH_YES)
|
if (m != MATCH_YES)
|
goto cleanup;
|
goto cleanup;
|
|
|
if (name[0] != '\0')
|
if (name[0] != '\0')
|
{
|
{
|
switch (name[0])
|
switch (name[0])
|
{
|
{
|
case 'l':
|
case 'l':
|
if (strncmp (name, "loc", 3) == 0)
|
if (strncmp (name, "loc", 3) == 0)
|
{
|
{
|
result->name = "%LOC";
|
result->name = "%LOC";
|
break;
|
break;
|
}
|
}
|
case 'r':
|
case 'r':
|
if (strncmp (name, "ref", 3) == 0)
|
if (strncmp (name, "ref", 3) == 0)
|
{
|
{
|
result->name = "%REF";
|
result->name = "%REF";
|
break;
|
break;
|
}
|
}
|
case 'v':
|
case 'v':
|
if (strncmp (name, "val", 3) == 0)
|
if (strncmp (name, "val", 3) == 0)
|
{
|
{
|
result->name = "%VAL";
|
result->name = "%VAL";
|
break;
|
break;
|
}
|
}
|
default:
|
default:
|
m = MATCH_ERROR;
|
m = MATCH_ERROR;
|
goto cleanup;
|
goto cleanup;
|
}
|
}
|
}
|
}
|
|
|
if (gfc_notify_std (GFC_STD_GNU, "Extension: argument list "
|
if (gfc_notify_std (GFC_STD_GNU, "Extension: argument list "
|
"function at %C") == FAILURE)
|
"function at %C") == FAILURE)
|
{
|
{
|
m = MATCH_ERROR;
|
m = MATCH_ERROR;
|
goto cleanup;
|
goto cleanup;
|
}
|
}
|
|
|
m = match_actual_arg (&result->expr);
|
m = match_actual_arg (&result->expr);
|
if (m != MATCH_YES)
|
if (m != MATCH_YES)
|
goto cleanup;
|
goto cleanup;
|
|
|
if (gfc_match_char (')') != MATCH_YES)
|
if (gfc_match_char (')') != MATCH_YES)
|
{
|
{
|
m = MATCH_NO;
|
m = MATCH_NO;
|
goto cleanup;
|
goto cleanup;
|
}
|
}
|
|
|
return MATCH_YES;
|
return MATCH_YES;
|
|
|
cleanup:
|
cleanup:
|
gfc_current_locus = old_locus;
|
gfc_current_locus = old_locus;
|
return m;
|
return m;
|
}
|
}
|
|
|
|
|
/* Matches an actual argument list of a function or subroutine, from
|
/* Matches an actual argument list of a function or subroutine, from
|
the opening parenthesis to the closing parenthesis. The argument
|
the opening parenthesis to the closing parenthesis. The argument
|
list is assumed to allow keyword arguments because we don't know if
|
list is assumed to allow keyword arguments because we don't know if
|
the symbol associated with the procedure has an implicit interface
|
the symbol associated with the procedure has an implicit interface
|
or not. We make sure keywords are unique. If sub_flag is set,
|
or not. We make sure keywords are unique. If sub_flag is set,
|
we're matching the argument list of a subroutine. */
|
we're matching the argument list of a subroutine. */
|
|
|
match
|
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;
|
gfc_actual_arglist *head, *tail;
|
int seen_keyword;
|
int seen_keyword;
|
gfc_st_label *label;
|
gfc_st_label *label;
|
locus old_loc;
|
locus old_loc;
|
match m;
|
match m;
|
|
|
*argp = tail = NULL;
|
*argp = tail = NULL;
|
old_loc = gfc_current_locus;
|
old_loc = gfc_current_locus;
|
|
|
seen_keyword = 0;
|
seen_keyword = 0;
|
|
|
if (gfc_match_char ('(') == MATCH_NO)
|
if (gfc_match_char ('(') == MATCH_NO)
|
return (sub_flag) ? MATCH_YES : MATCH_NO;
|
return (sub_flag) ? MATCH_YES : MATCH_NO;
|
|
|
if (gfc_match_char (')') == MATCH_YES)
|
if (gfc_match_char (')') == MATCH_YES)
|
return MATCH_YES;
|
return MATCH_YES;
|
head = NULL;
|
head = NULL;
|
|
|
for (;;)
|
for (;;)
|
{
|
{
|
if (head == NULL)
|
if (head == NULL)
|
head = tail = gfc_get_actual_arglist ();
|
head = tail = gfc_get_actual_arglist ();
|
else
|
else
|
{
|
{
|
tail->next = gfc_get_actual_arglist ();
|
tail->next = gfc_get_actual_arglist ();
|
tail = tail->next;
|
tail = tail->next;
|
}
|
}
|
|
|
if (sub_flag && gfc_match_char ('*') == MATCH_YES)
|
if (sub_flag && gfc_match_char ('*') == MATCH_YES)
|
{
|
{
|
m = gfc_match_st_label (&label);
|
m = gfc_match_st_label (&label);
|
if (m == MATCH_NO)
|
if (m == MATCH_NO)
|
gfc_error ("Expected alternate return label at %C");
|
gfc_error ("Expected alternate return label at %C");
|
if (m != MATCH_YES)
|
if (m != MATCH_YES)
|
goto cleanup;
|
goto cleanup;
|
|
|
tail->label = label;
|
tail->label = label;
|
goto next;
|
goto next;
|
}
|
}
|
|
|
/* After the first keyword argument is seen, the following
|
/* After the first keyword argument is seen, the following
|
arguments must also have keywords. */
|
arguments must also have keywords. */
|
if (seen_keyword)
|
if (seen_keyword)
|
{
|
{
|
m = match_keyword_arg (tail, head);
|
m = match_keyword_arg (tail, head);
|
|
|
if (m == MATCH_ERROR)
|
if (m == MATCH_ERROR)
|
goto cleanup;
|
goto cleanup;
|
if (m == MATCH_NO)
|
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;
|
goto cleanup;
|
}
|
}
|
|
|
}
|
}
|
else
|
else
|
{
|
{
|
/* Try an argument list function, like %VAL. */
|
/* Try an argument list function, like %VAL. */
|
m = match_arg_list_function (tail);
|
m = match_arg_list_function (tail);
|
if (m == MATCH_ERROR)
|
if (m == MATCH_ERROR)
|
goto cleanup;
|
goto cleanup;
|
|
|
/* See if we have the first keyword argument. */
|
/* See if we have the first keyword argument. */
|
if (m == MATCH_NO)
|
if (m == MATCH_NO)
|
{
|
{
|
m = match_keyword_arg (tail, head);
|
m = match_keyword_arg (tail, head);
|
if (m == MATCH_YES)
|
if (m == MATCH_YES)
|
seen_keyword = 1;
|
seen_keyword = 1;
|
if (m == MATCH_ERROR)
|
if (m == MATCH_ERROR)
|
goto cleanup;
|
goto cleanup;
|
}
|
}
|
|
|
if (m == MATCH_NO)
|
if (m == MATCH_NO)
|
{
|
{
|
/* Try for a non-keyword argument. */
|
/* Try for a non-keyword argument. */
|
m = match_actual_arg (&tail->expr);
|
m = match_actual_arg (&tail->expr);
|
if (m == MATCH_ERROR)
|
if (m == MATCH_ERROR)
|
goto cleanup;
|
goto cleanup;
|
if (m == MATCH_NO)
|
if (m == MATCH_NO)
|
goto syntax;
|
goto syntax;
|
}
|
}
|
}
|
}
|
|
|
|
|
next:
|
next:
|
if (gfc_match_char (')') == MATCH_YES)
|
if (gfc_match_char (')') == MATCH_YES)
|
break;
|
break;
|
if (gfc_match_char (',') != MATCH_YES)
|
if (gfc_match_char (',') != MATCH_YES)
|
goto syntax;
|
goto syntax;
|
}
|
}
|
|
|
*argp = head;
|
*argp = head;
|
return MATCH_YES;
|
return MATCH_YES;
|
|
|
syntax:
|
syntax:
|
gfc_error ("Syntax error in argument list at %C");
|
gfc_error ("Syntax error in argument list at %C");
|
|
|
cleanup:
|
cleanup:
|
gfc_free_actual_arglist (head);
|
gfc_free_actual_arglist (head);
|
gfc_current_locus = old_loc;
|
gfc_current_locus = old_loc;
|
|
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
}
|
}
|
|
|
|
|
/* Used by gfc_match_varspec() to extend the reference list by one
|
/* Used by gfc_match_varspec() to extend the reference list by one
|
element. */
|
element. */
|
|
|
static gfc_ref *
|
static gfc_ref *
|
extend_ref (gfc_expr *primary, gfc_ref *tail)
|
extend_ref (gfc_expr *primary, gfc_ref *tail)
|
{
|
{
|
if (primary->ref == NULL)
|
if (primary->ref == NULL)
|
primary->ref = tail = gfc_get_ref ();
|
primary->ref = tail = gfc_get_ref ();
|
else
|
else
|
{
|
{
|
if (tail == NULL)
|
if (tail == NULL)
|
gfc_internal_error ("extend_ref(): Bad tail");
|
gfc_internal_error ("extend_ref(): Bad tail");
|
tail->next = gfc_get_ref ();
|
tail->next = gfc_get_ref ();
|
tail = tail->next;
|
tail = tail->next;
|
}
|
}
|
|
|
return tail;
|
return tail;
|
}
|
}
|
|
|
|
|
/* Match any additional specifications associated with the current
|
/* Match any additional specifications associated with the current
|
variable like member references or substrings. If equiv_flag is
|
variable like member references or substrings. If equiv_flag is
|
set we only match stuff that is allowed inside an EQUIVALENCE
|
set we only match stuff that is allowed inside an EQUIVALENCE
|
statement. sub_flag tells whether we expect a type-bound procedure found
|
statement. sub_flag tells whether we expect a type-bound procedure found
|
to be a subroutine as part of CALL or a FUNCTION. For procedure pointer
|
to be a subroutine as part of CALL or a FUNCTION. For procedure pointer
|
components, 'ppc_arg' determines whether the PPC may be called (with an
|
components, 'ppc_arg' determines whether the PPC may be called (with an
|
argument list), or whether it may just be referred to as a pointer. */
|
argument list), or whether it may just be referred to as a pointer. */
|
|
|
match
|
match
|
gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
|
gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
|
bool ppc_arg)
|
bool ppc_arg)
|
{
|
{
|
char name[GFC_MAX_SYMBOL_LEN + 1];
|
char name[GFC_MAX_SYMBOL_LEN + 1];
|
gfc_ref *substring, *tail;
|
gfc_ref *substring, *tail;
|
gfc_component *component;
|
gfc_component *component;
|
gfc_symbol *sym = primary->symtree->n.sym;
|
gfc_symbol *sym = primary->symtree->n.sym;
|
match m;
|
match m;
|
bool unknown;
|
bool unknown;
|
|
|
tail = NULL;
|
tail = NULL;
|
|
|
gfc_gobble_whitespace ();
|
gfc_gobble_whitespace ();
|
if ((equiv_flag && gfc_peek_ascii_char () == '(')
|
if ((equiv_flag && gfc_peek_ascii_char () == '(')
|
|| (sym->attr.dimension && !sym->attr.proc_pointer
|
|| (sym->attr.dimension && !sym->attr.proc_pointer
|
&& !gfc_is_proc_ptr_comp (primary, NULL)
|
&& !gfc_is_proc_ptr_comp (primary, NULL)
|
&& !(gfc_matching_procptr_assignment
|
&& !(gfc_matching_procptr_assignment
|
&& sym->attr.flavor == FL_PROCEDURE))
|
&& sym->attr.flavor == FL_PROCEDURE))
|
|| (sym->ts.type == BT_CLASS
|
|| (sym->ts.type == BT_CLASS
|
&& sym->ts.u.derived->components->attr.dimension))
|
&& sym->ts.u.derived->components->attr.dimension))
|
{
|
{
|
/* In EQUIVALENCE, we don't know yet whether we are seeing
|
/* In EQUIVALENCE, we don't know yet whether we are seeing
|
an array, character variable or array of character
|
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 = extend_ref (primary, tail);
|
tail->type = REF_ARRAY;
|
tail->type = REF_ARRAY;
|
|
|
m = gfc_match_array_ref (&tail->u.ar, equiv_flag ? NULL : sym->as,
|
m = gfc_match_array_ref (&tail->u.ar, equiv_flag ? NULL : sym->as,
|
equiv_flag);
|
equiv_flag);
|
if (m != MATCH_YES)
|
if (m != MATCH_YES)
|
return m;
|
return m;
|
|
|
gfc_gobble_whitespace ();
|
gfc_gobble_whitespace ();
|
if (equiv_flag && gfc_peek_ascii_char () == '(')
|
if (equiv_flag && gfc_peek_ascii_char () == '(')
|
{
|
{
|
tail = extend_ref (primary, tail);
|
tail = extend_ref (primary, tail);
|
tail->type = REF_ARRAY;
|
tail->type = REF_ARRAY;
|
|
|
m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag);
|
m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag);
|
if (m != MATCH_YES)
|
if (m != MATCH_YES)
|
return m;
|
return m;
|
}
|
}
|
}
|
}
|
|
|
primary->ts = sym->ts;
|
primary->ts = sym->ts;
|
|
|
if (equiv_flag)
|
if (equiv_flag)
|
return MATCH_YES;
|
return MATCH_YES;
|
|
|
if (sym->ts.type == BT_UNKNOWN && gfc_peek_ascii_char () == '%'
|
if (sym->ts.type == BT_UNKNOWN && gfc_peek_ascii_char () == '%'
|
&& gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
|
&& gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
|
gfc_set_default_type (sym, 0, sym->ns);
|
gfc_set_default_type (sym, 0, sym->ns);
|
|
|
if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
|
if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
|
|| gfc_match_char ('%') != MATCH_YES)
|
|| gfc_match_char ('%') != MATCH_YES)
|
goto check_substring;
|
goto check_substring;
|
|
|
sym = sym->ts.u.derived;
|
sym = sym->ts.u.derived;
|
|
|
for (;;)
|
for (;;)
|
{
|
{
|
gfc_try t;
|
gfc_try t;
|
gfc_symtree *tbp;
|
gfc_symtree *tbp;
|
|
|
m = gfc_match_name (name);
|
m = gfc_match_name (name);
|
if (m == MATCH_NO)
|
if (m == MATCH_NO)
|
gfc_error ("Expected structure component name at %C");
|
gfc_error ("Expected structure component name at %C");
|
if (m != MATCH_YES)
|
if (m != MATCH_YES)
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
|
|
if (sym->f2k_derived)
|
if (sym->f2k_derived)
|
tbp = gfc_find_typebound_proc (sym, &t, name, false, &gfc_current_locus);
|
tbp = gfc_find_typebound_proc (sym, &t, name, false, &gfc_current_locus);
|
else
|
else
|
tbp = NULL;
|
tbp = NULL;
|
|
|
if (tbp)
|
if (tbp)
|
{
|
{
|
gfc_symbol* tbp_sym;
|
gfc_symbol* tbp_sym;
|
|
|
if (t == FAILURE)
|
if (t == FAILURE)
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
|
|
gcc_assert (!tail || !tail->next);
|
gcc_assert (!tail || !tail->next);
|
gcc_assert (primary->expr_type == EXPR_VARIABLE);
|
gcc_assert (primary->expr_type == EXPR_VARIABLE);
|
|
|
if (tbp->n.tb->is_generic)
|
if (tbp->n.tb->is_generic)
|
tbp_sym = NULL;
|
tbp_sym = NULL;
|
else
|
else
|
tbp_sym = tbp->n.tb->u.specific->n.sym;
|
tbp_sym = tbp->n.tb->u.specific->n.sym;
|
|
|
primary->expr_type = EXPR_COMPCALL;
|
primary->expr_type = EXPR_COMPCALL;
|
primary->value.compcall.tbp = tbp->n.tb;
|
primary->value.compcall.tbp = tbp->n.tb;
|
primary->value.compcall.name = tbp->name;
|
primary->value.compcall.name = tbp->name;
|
primary->value.compcall.ignore_pass = 0;
|
primary->value.compcall.ignore_pass = 0;
|
primary->value.compcall.assign = 0;
|
primary->value.compcall.assign = 0;
|
primary->value.compcall.base_object = NULL;
|
primary->value.compcall.base_object = NULL;
|
gcc_assert (primary->symtree->n.sym->attr.referenced);
|
gcc_assert (primary->symtree->n.sym->attr.referenced);
|
if (tbp_sym)
|
if (tbp_sym)
|
primary->ts = tbp_sym->ts;
|
primary->ts = tbp_sym->ts;
|
|
|
m = gfc_match_actual_arglist (tbp->n.tb->subroutine,
|
m = gfc_match_actual_arglist (tbp->n.tb->subroutine,
|
&primary->value.compcall.actual);
|
&primary->value.compcall.actual);
|
if (m == MATCH_ERROR)
|
if (m == MATCH_ERROR)
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
if (m == MATCH_NO)
|
if (m == MATCH_NO)
|
{
|
{
|
if (sub_flag)
|
if (sub_flag)
|
primary->value.compcall.actual = NULL;
|
primary->value.compcall.actual = NULL;
|
else
|
else
|
{
|
{
|
gfc_error ("Expected argument list at %C");
|
gfc_error ("Expected argument list at %C");
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
}
|
}
|
}
|
}
|
|
|
break;
|
break;
|
}
|
}
|
|
|
component = gfc_find_component (sym, name, false, false);
|
component = gfc_find_component (sym, name, false, false);
|
if (component == NULL)
|
if (component == NULL)
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
|
|
tail = extend_ref (primary, tail);
|
tail = extend_ref (primary, tail);
|
tail->type = REF_COMPONENT;
|
tail->type = REF_COMPONENT;
|
|
|
tail->u.c.component = component;
|
tail->u.c.component = component;
|
tail->u.c.sym = sym;
|
tail->u.c.sym = sym;
|
|
|
primary->ts = component->ts;
|
primary->ts = component->ts;
|
|
|
if (component->attr.proc_pointer && ppc_arg
|
if (component->attr.proc_pointer && ppc_arg
|
&& !gfc_matching_procptr_assignment)
|
&& !gfc_matching_procptr_assignment)
|
{
|
{
|
m = gfc_match_actual_arglist (sub_flag,
|
m = gfc_match_actual_arglist (sub_flag,
|
&primary->value.compcall.actual);
|
&primary->value.compcall.actual);
|
if (m == MATCH_ERROR)
|
if (m == MATCH_ERROR)
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
if (m == MATCH_YES)
|
if (m == MATCH_YES)
|
primary->expr_type = EXPR_PPC;
|
primary->expr_type = EXPR_PPC;
|
|
|
break;
|
break;
|
}
|
}
|
|
|
if (component->as != NULL && !component->attr.proc_pointer)
|
if (component->as != NULL && !component->attr.proc_pointer)
|
{
|
{
|
tail = extend_ref (primary, tail);
|
tail = extend_ref (primary, tail);
|
tail->type = REF_ARRAY;
|
tail->type = REF_ARRAY;
|
|
|
m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag);
|
m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag);
|
if (m != MATCH_YES)
|
if (m != MATCH_YES)
|
return m;
|
return m;
|
}
|
}
|
else if (component->ts.type == BT_CLASS
|
else if (component->ts.type == BT_CLASS
|
&& component->ts.u.derived->components->as != NULL
|
&& component->ts.u.derived->components->as != NULL
|
&& !component->attr.proc_pointer)
|
&& !component->attr.proc_pointer)
|
{
|
{
|
tail = extend_ref (primary, tail);
|
tail = extend_ref (primary, tail);
|
tail->type = REF_ARRAY;
|
tail->type = REF_ARRAY;
|
|
|
m = gfc_match_array_ref (&tail->u.ar,
|
m = gfc_match_array_ref (&tail->u.ar,
|
component->ts.u.derived->components->as,
|
component->ts.u.derived->components->as,
|
equiv_flag);
|
equiv_flag);
|
if (m != MATCH_YES)
|
if (m != MATCH_YES)
|
return m;
|
return m;
|
}
|
}
|
|
|
if ((component->ts.type != BT_DERIVED && component->ts.type != BT_CLASS)
|
if ((component->ts.type != BT_DERIVED && component->ts.type != BT_CLASS)
|
|| gfc_match_char ('%') != MATCH_YES)
|
|| gfc_match_char ('%') != MATCH_YES)
|
break;
|
break;
|
|
|
sym = component->ts.u.derived;
|
sym = component->ts.u.derived;
|
}
|
}
|
|
|
check_substring:
|
check_substring:
|
unknown = false;
|
unknown = false;
|
if (primary->ts.type == BT_UNKNOWN && sym->attr.flavor != FL_DERIVED)
|
if (primary->ts.type == BT_UNKNOWN && sym->attr.flavor != FL_DERIVED)
|
{
|
{
|
if (gfc_get_default_type (sym->name, sym->ns)->type == BT_CHARACTER)
|
if (gfc_get_default_type (sym->name, sym->ns)->type == BT_CHARACTER)
|
{
|
{
|
gfc_set_default_type (sym, 0, sym->ns);
|
gfc_set_default_type (sym, 0, sym->ns);
|
primary->ts = sym->ts;
|
primary->ts = sym->ts;
|
unknown = true;
|
unknown = true;
|
}
|
}
|
}
|
}
|
|
|
if (primary->ts.type == BT_CHARACTER)
|
if (primary->ts.type == BT_CHARACTER)
|
{
|
{
|
switch (match_substring (primary->ts.u.cl, equiv_flag, &substring))
|
switch (match_substring (primary->ts.u.cl, equiv_flag, &substring))
|
{
|
{
|
case MATCH_YES:
|
case MATCH_YES:
|
if (tail == NULL)
|
if (tail == NULL)
|
primary->ref = substring;
|
primary->ref = substring;
|
else
|
else
|
tail->next = substring;
|
tail->next = substring;
|
|
|
if (primary->expr_type == EXPR_CONSTANT)
|
if (primary->expr_type == EXPR_CONSTANT)
|
primary->expr_type = EXPR_SUBSTRING;
|
primary->expr_type = EXPR_SUBSTRING;
|
|
|
if (substring)
|
if (substring)
|
primary->ts.u.cl = NULL;
|
primary->ts.u.cl = NULL;
|
|
|
break;
|
break;
|
|
|
case MATCH_NO:
|
case MATCH_NO:
|
if (unknown)
|
if (unknown)
|
{
|
{
|
gfc_clear_ts (&primary->ts);
|
gfc_clear_ts (&primary->ts);
|
gfc_clear_ts (&sym->ts);
|
gfc_clear_ts (&sym->ts);
|
}
|
}
|
break;
|
break;
|
|
|
case MATCH_ERROR:
|
case MATCH_ERROR:
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
}
|
}
|
}
|
}
|
|
|
return MATCH_YES;
|
return MATCH_YES;
|
}
|
}
|
|
|
|
|
/* Given an expression that is a variable, figure out what the
|
/* Given an expression that is a variable, figure out what the
|
ultimate variable's type and attribute is, traversing the reference
|
ultimate variable's type and attribute is, traversing the reference
|
structures if necessary.
|
structures if necessary.
|
|
|
This subroutine is trickier than it looks. We start at the base
|
This subroutine is trickier than it looks. We start at the base
|
symbol and store the attribute. Component references load a
|
symbol and store the attribute. Component references load a
|
completely new attribute.
|
completely new attribute.
|
|
|
A couple of rules come into play. Subobjects of targets are always
|
A couple of rules come into play. Subobjects of targets are always
|
targets themselves. If we see a component that goes through a
|
targets themselves. If we see a component that goes through a
|
pointer, then the expression must also be a target, since the
|
pointer, then the expression must also be a target, since the
|
pointer is associated with something (if it isn't core will soon be
|
pointer is associated with something (if it isn't core will soon be
|
dumped). If we see a full part or section of an array, the
|
dumped). If we see a full part or section of an array, the
|
expression is also an array.
|
expression is also an array.
|
|
|
We can have at most one full array reference. */
|
We can have at most one full array reference. */
|
|
|
symbol_attribute
|
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;
|
int dimension, pointer, allocatable, target;
|
symbol_attribute attr;
|
symbol_attribute attr;
|
gfc_ref *ref;
|
gfc_ref *ref;
|
gfc_symbol *sym;
|
gfc_symbol *sym;
|
gfc_component *comp;
|
gfc_component *comp;
|
|
|
if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION)
|
if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION)
|
gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
|
gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
|
|
|
ref = expr->ref;
|
ref = expr->ref;
|
sym = expr->symtree->n.sym;
|
sym = expr->symtree->n.sym;
|
attr = sym->attr;
|
attr = sym->attr;
|
|
|
if (sym->ts.type == BT_CLASS)
|
if (sym->ts.type == BT_CLASS)
|
{
|
{
|
dimension = sym->ts.u.derived->components->attr.dimension;
|
dimension = sym->ts.u.derived->components->attr.dimension;
|
pointer = sym->ts.u.derived->components->attr.pointer;
|
pointer = sym->ts.u.derived->components->attr.pointer;
|
allocatable = sym->ts.u.derived->components->attr.allocatable;
|
allocatable = sym->ts.u.derived->components->attr.allocatable;
|
}
|
}
|
else
|
else
|
{
|
{
|
dimension = attr.dimension;
|
dimension = attr.dimension;
|
pointer = attr.pointer;
|
pointer = attr.pointer;
|
allocatable = attr.allocatable;
|
allocatable = attr.allocatable;
|
}
|
}
|
|
|
target = attr.target;
|
target = attr.target;
|
if (pointer || attr.proc_pointer)
|
if (pointer || attr.proc_pointer)
|
target = 1;
|
target = 1;
|
|
|
if (ts != NULL && expr->ts.type == BT_UNKNOWN)
|
if (ts != NULL && expr->ts.type == BT_UNKNOWN)
|
*ts = sym->ts;
|
*ts = sym->ts;
|
|
|
for (; ref; ref = ref->next)
|
for (; ref; ref = ref->next)
|
switch (ref->type)
|
switch (ref->type)
|
{
|
{
|
case REF_ARRAY:
|
case REF_ARRAY:
|
|
|
switch (ref->u.ar.type)
|
switch (ref->u.ar.type)
|
{
|
{
|
case AR_FULL:
|
case AR_FULL:
|
dimension = 1;
|
dimension = 1;
|
break;
|
break;
|
|
|
case AR_SECTION:
|
case AR_SECTION:
|
allocatable = pointer = 0;
|
allocatable = pointer = 0;
|
dimension = 1;
|
dimension = 1;
|
break;
|
break;
|
|
|
case AR_ELEMENT:
|
case AR_ELEMENT:
|
allocatable = pointer = 0;
|
allocatable = pointer = 0;
|
break;
|
break;
|
|
|
case AR_UNKNOWN:
|
case AR_UNKNOWN:
|
gfc_internal_error ("gfc_variable_attr(): Bad array reference");
|
gfc_internal_error ("gfc_variable_attr(): Bad array reference");
|
}
|
}
|
|
|
break;
|
break;
|
|
|
case REF_COMPONENT:
|
case REF_COMPONENT:
|
comp = ref->u.c.component;
|
comp = ref->u.c.component;
|
attr = comp->attr;
|
attr = comp->attr;
|
if (ts != NULL)
|
if (ts != NULL)
|
{
|
{
|
*ts = comp->ts;
|
*ts = comp->ts;
|
/* Don't set the string length if a substring reference
|
/* Don't set the string length if a substring reference
|
follows. */
|
follows. */
|
if (ts->type == BT_CHARACTER
|
if (ts->type == BT_CHARACTER
|
&& ref->next && ref->next->type == REF_SUBSTRING)
|
&& ref->next && ref->next->type == REF_SUBSTRING)
|
ts->u.cl = NULL;
|
ts->u.cl = NULL;
|
}
|
}
|
|
|
if (comp->ts.type == BT_CLASS)
|
if (comp->ts.type == BT_CLASS)
|
{
|
{
|
pointer = comp->ts.u.derived->components->attr.pointer;
|
pointer = comp->ts.u.derived->components->attr.pointer;
|
allocatable = comp->ts.u.derived->components->attr.allocatable;
|
allocatable = comp->ts.u.derived->components->attr.allocatable;
|
}
|
}
|
else
|
else
|
{
|
{
|
pointer = comp->attr.pointer;
|
pointer = comp->attr.pointer;
|
allocatable = comp->attr.allocatable;
|
allocatable = comp->attr.allocatable;
|
}
|
}
|
if (pointer || attr.proc_pointer)
|
if (pointer || attr.proc_pointer)
|
target = 1;
|
target = 1;
|
|
|
break;
|
break;
|
|
|
case REF_SUBSTRING:
|
case REF_SUBSTRING:
|
allocatable = pointer = 0;
|
allocatable = pointer = 0;
|
break;
|
break;
|
}
|
}
|
|
|
attr.dimension = dimension;
|
attr.dimension = dimension;
|
attr.pointer = pointer;
|
attr.pointer = pointer;
|
attr.allocatable = allocatable;
|
attr.allocatable = allocatable;
|
attr.target = target;
|
attr.target = target;
|
|
|
return attr;
|
return attr;
|
}
|
}
|
|
|
|
|
/* Return the attribute from a general expression. */
|
/* Return the attribute from a general expression. */
|
|
|
symbol_attribute
|
symbol_attribute
|
gfc_expr_attr (gfc_expr *e)
|
gfc_expr_attr (gfc_expr *e)
|
{
|
{
|
symbol_attribute attr;
|
symbol_attribute attr;
|
|
|
switch (e->expr_type)
|
switch (e->expr_type)
|
{
|
{
|
case EXPR_VARIABLE:
|
case EXPR_VARIABLE:
|
attr = gfc_variable_attr (e, NULL);
|
attr = gfc_variable_attr (e, NULL);
|
break;
|
break;
|
|
|
case EXPR_FUNCTION:
|
case EXPR_FUNCTION:
|
gfc_clear_attr (&attr);
|
gfc_clear_attr (&attr);
|
|
|
if (e->value.function.esym != NULL)
|
if (e->value.function.esym != NULL)
|
{
|
{
|
gfc_symbol *sym = e->value.function.esym->result;
|
gfc_symbol *sym = e->value.function.esym->result;
|
attr = sym->attr;
|
attr = sym->attr;
|
if (sym->ts.type == BT_CLASS)
|
if (sym->ts.type == BT_CLASS)
|
{
|
{
|
attr.dimension = sym->ts.u.derived->components->attr.dimension;
|
attr.dimension = sym->ts.u.derived->components->attr.dimension;
|
attr.pointer = sym->ts.u.derived->components->attr.pointer;
|
attr.pointer = sym->ts.u.derived->components->attr.pointer;
|
attr.allocatable = sym->ts.u.derived->components->attr.allocatable;
|
attr.allocatable = sym->ts.u.derived->components->attr.allocatable;
|
}
|
}
|
}
|
}
|
else
|
else
|
attr = gfc_variable_attr (e, NULL);
|
attr = gfc_variable_attr (e, NULL);
|
|
|
/* TODO: NULL() returns pointers. May have to take care of this
|
/* TODO: NULL() returns pointers. May have to take care of this
|
here. */
|
here. */
|
|
|
break;
|
break;
|
|
|
default:
|
default:
|
gfc_clear_attr (&attr);
|
gfc_clear_attr (&attr);
|
break;
|
break;
|
}
|
}
|
|
|
return attr;
|
return attr;
|
}
|
}
|
|
|
|
|
/* Match a structure constructor. The initial symbol has already been
|
/* Match a structure constructor. The initial symbol has already been
|
seen. */
|
seen. */
|
|
|
typedef struct gfc_structure_ctor_component
|
typedef struct gfc_structure_ctor_component
|
{
|
{
|
char* name;
|
char* name;
|
gfc_expr* val;
|
gfc_expr* val;
|
locus where;
|
locus where;
|
struct gfc_structure_ctor_component* next;
|
struct gfc_structure_ctor_component* next;
|
}
|
}
|
gfc_structure_ctor_component;
|
gfc_structure_ctor_component;
|
|
|
#define gfc_get_structure_ctor_component() XCNEW (gfc_structure_ctor_component)
|
#define gfc_get_structure_ctor_component() XCNEW (gfc_structure_ctor_component)
|
|
|
static void
|
static void
|
gfc_free_structure_ctor_component (gfc_structure_ctor_component *comp)
|
gfc_free_structure_ctor_component (gfc_structure_ctor_component *comp)
|
{
|
{
|
gfc_free (comp->name);
|
gfc_free (comp->name);
|
gfc_free_expr (comp->val);
|
gfc_free_expr (comp->val);
|
}
|
}
|
|
|
|
|
/* Translate the component list into the actual constructor by sorting it in
|
/* 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
|
the order required; this also checks along the way that each and every
|
component actually has an initializer and handles default initializers
|
component actually has an initializer and handles default initializers
|
for components without explicit value given. */
|
for components without explicit value given. */
|
static gfc_try
|
static gfc_try
|
build_actual_constructor (gfc_structure_ctor_component **comp_head,
|
build_actual_constructor (gfc_structure_ctor_component **comp_head,
|
gfc_constructor **ctor_head, gfc_symbol *sym)
|
gfc_constructor **ctor_head, gfc_symbol *sym)
|
{
|
{
|
gfc_structure_ctor_component *comp_iter;
|
gfc_structure_ctor_component *comp_iter;
|
gfc_constructor *ctor_tail = NULL;
|
gfc_constructor *ctor_tail = NULL;
|
gfc_component *comp;
|
gfc_component *comp;
|
|
|
for (comp = sym->components; comp; comp = comp->next)
|
for (comp = sym->components; comp; comp = comp->next)
|
{
|
{
|
gfc_structure_ctor_component **next_ptr;
|
gfc_structure_ctor_component **next_ptr;
|
gfc_expr *value = NULL;
|
gfc_expr *value = NULL;
|
|
|
/* Try to find the initializer for the current component by name. */
|
/* Try to find the initializer for the current component by name. */
|
next_ptr = comp_head;
|
next_ptr = comp_head;
|
for (comp_iter = *comp_head; comp_iter; comp_iter = comp_iter->next)
|
for (comp_iter = *comp_head; comp_iter; comp_iter = comp_iter->next)
|
{
|
{
|
if (!strcmp (comp_iter->name, comp->name))
|
if (!strcmp (comp_iter->name, comp->name))
|
break;
|
break;
|
next_ptr = &comp_iter->next;
|
next_ptr = &comp_iter->next;
|
}
|
}
|
|
|
/* If an extension, try building the parent derived type by building
|
/* If an extension, try building the parent derived type by building
|
a value expression for the parent derived type and calling self. */
|
a value expression for the parent derived type and calling self. */
|
if (!comp_iter && comp == sym->components && sym->attr.extension)
|
if (!comp_iter && comp == sym->components && sym->attr.extension)
|
{
|
{
|
value = gfc_get_expr ();
|
value = gfc_get_expr ();
|
value->expr_type = EXPR_STRUCTURE;
|
value->expr_type = EXPR_STRUCTURE;
|
value->value.constructor = NULL;
|
value->value.constructor = NULL;
|
value->ts = comp->ts;
|
value->ts = comp->ts;
|
value->where = gfc_current_locus;
|
value->where = gfc_current_locus;
|
|
|
if (build_actual_constructor (comp_head, &value->value.constructor,
|
if (build_actual_constructor (comp_head, &value->value.constructor,
|
comp->ts.u.derived) == FAILURE)
|
comp->ts.u.derived) == FAILURE)
|
{
|
{
|
gfc_free_expr (value);
|
gfc_free_expr (value);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
*ctor_head = ctor_tail = gfc_get_constructor ();
|
*ctor_head = ctor_tail = gfc_get_constructor ();
|
ctor_tail->expr = value;
|
ctor_tail->expr = value;
|
continue;
|
continue;
|
}
|
}
|
|
|
/* If it was not found, try the default initializer if there's any;
|
/* If it was not found, try the default initializer if there's any;
|
otherwise, it's an error. */
|
otherwise, it's an error. */
|
if (!comp_iter)
|
if (!comp_iter)
|
{
|
{
|
if (comp->initializer)
|
if (comp->initializer)
|
{
|
{
|
if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure"
|
if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure"
|
" constructor with missing optional arguments"
|
" constructor with missing optional arguments"
|
" at %C") == FAILURE)
|
" at %C") == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
value = gfc_copy_expr (comp->initializer);
|
value = gfc_copy_expr (comp->initializer);
|
}
|
}
|
else
|
else
|
{
|
{
|
gfc_error ("No initializer for component '%s' given in the"
|
gfc_error ("No initializer for component '%s' given in the"
|
" structure constructor at %C!", comp->name);
|
" structure constructor at %C!", comp->name);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
}
|
}
|
else
|
else
|
value = comp_iter->val;
|
value = comp_iter->val;
|
|
|
/* Add the value to the constructor chain built. */
|
/* Add the value to the constructor chain built. */
|
if (ctor_tail)
|
if (ctor_tail)
|
{
|
{
|
ctor_tail->next = gfc_get_constructor ();
|
ctor_tail->next = gfc_get_constructor ();
|
ctor_tail = ctor_tail->next;
|
ctor_tail = ctor_tail->next;
|
}
|
}
|
else
|
else
|
*ctor_head = ctor_tail = gfc_get_constructor ();
|
*ctor_head = ctor_tail = gfc_get_constructor ();
|
gcc_assert (value);
|
gcc_assert (value);
|
ctor_tail->expr = value;
|
ctor_tail->expr = value;
|
|
|
/* Remove the entry from the component list. We don't want the expression
|
/* Remove the entry from the component list. We don't want the expression
|
value to be free'd, so set it to NULL. */
|
value to be free'd, so set it to NULL. */
|
if (comp_iter)
|
if (comp_iter)
|
{
|
{
|
*next_ptr = comp_iter->next;
|
*next_ptr = comp_iter->next;
|
comp_iter->val = NULL;
|
comp_iter->val = NULL;
|
gfc_free_structure_ctor_component (comp_iter);
|
gfc_free_structure_ctor_component (comp_iter);
|
}
|
}
|
}
|
}
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
match
|
match
|
gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result,
|
gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result,
|
bool parent)
|
bool parent)
|
{
|
{
|
gfc_structure_ctor_component *comp_tail, *comp_head, *comp_iter;
|
gfc_structure_ctor_component *comp_tail, *comp_head, *comp_iter;
|
gfc_constructor *ctor_head, *ctor_tail;
|
gfc_constructor *ctor_head, *ctor_tail;
|
gfc_component *comp; /* Is set NULL when named component is first seen */
|
gfc_component *comp; /* Is set NULL when named component is first seen */
|
gfc_expr *e;
|
gfc_expr *e;
|
locus where;
|
locus where;
|
match m;
|
match m;
|
const char* last_name = NULL;
|
const char* last_name = NULL;
|
|
|
comp_tail = comp_head = NULL;
|
comp_tail = comp_head = NULL;
|
ctor_head = ctor_tail = NULL;
|
ctor_head = ctor_tail = NULL;
|
|
|
if (!parent && gfc_match_char ('(') != MATCH_YES)
|
if (!parent && gfc_match_char ('(') != MATCH_YES)
|
goto syntax;
|
goto syntax;
|
|
|
where = gfc_current_locus;
|
where = gfc_current_locus;
|
|
|
gfc_find_component (sym, NULL, false, true);
|
gfc_find_component (sym, NULL, false, true);
|
|
|
/* Check that we're not about to construct an ABSTRACT type. */
|
/* Check that we're not about to construct an ABSTRACT type. */
|
if (!parent && sym->attr.abstract)
|
if (!parent && sym->attr.abstract)
|
{
|
{
|
gfc_error ("Can't construct ABSTRACT type '%s' at %C", sym->name);
|
gfc_error ("Can't construct ABSTRACT type '%s' at %C", sym->name);
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
}
|
}
|
|
|
/* Match the component list and store it in a list together with the
|
/* Match the component list and store it in a list together with the
|
corresponding component names. Check for empty argument list first. */
|
corresponding component names. Check for empty argument list first. */
|
if (gfc_match_char (')') != MATCH_YES)
|
if (gfc_match_char (')') != MATCH_YES)
|
{
|
{
|
comp = sym->components;
|
comp = sym->components;
|
do
|
do
|
{
|
{
|
gfc_component *this_comp = NULL;
|
gfc_component *this_comp = NULL;
|
|
|
if (!comp_head)
|
if (!comp_head)
|
comp_tail = comp_head = gfc_get_structure_ctor_component ();
|
comp_tail = comp_head = gfc_get_structure_ctor_component ();
|
else
|
else
|
{
|
{
|
comp_tail->next = gfc_get_structure_ctor_component ();
|
comp_tail->next = gfc_get_structure_ctor_component ();
|
comp_tail = comp_tail->next;
|
comp_tail = comp_tail->next;
|
}
|
}
|
comp_tail->name = XCNEWVEC (char, GFC_MAX_SYMBOL_LEN + 1);
|
comp_tail->name = XCNEWVEC (char, GFC_MAX_SYMBOL_LEN + 1);
|
comp_tail->val = NULL;
|
comp_tail->val = NULL;
|
comp_tail->where = gfc_current_locus;
|
comp_tail->where = gfc_current_locus;
|
|
|
/* Try matching a component name. */
|
/* Try matching a component name. */
|
if (gfc_match_name (comp_tail->name) == MATCH_YES
|
if (gfc_match_name (comp_tail->name) == MATCH_YES
|
&& gfc_match_char ('=') == MATCH_YES)
|
&& gfc_match_char ('=') == MATCH_YES)
|
{
|
{
|
if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure"
|
if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure"
|
" constructor with named arguments at %C")
|
" constructor with named arguments at %C")
|
== FAILURE)
|
== FAILURE)
|
goto cleanup;
|
goto cleanup;
|
|
|
last_name = comp_tail->name;
|
last_name = comp_tail->name;
|
comp = NULL;
|
comp = NULL;
|
}
|
}
|
else
|
else
|
{
|
{
|
/* Components without name are not allowed after the first named
|
/* Components without name are not allowed after the first named
|
component initializer! */
|
component initializer! */
|
if (!comp)
|
if (!comp)
|
{
|
{
|
if (last_name)
|
if (last_name)
|
gfc_error ("Component initializer without name after"
|
gfc_error ("Component initializer without name after"
|
" component named %s at %C!", last_name);
|
" component named %s at %C!", last_name);
|
else if (!parent)
|
else if (!parent)
|
gfc_error ("Too many components in structure constructor at"
|
gfc_error ("Too many components in structure constructor at"
|
" %C!");
|
" %C!");
|
goto cleanup;
|
goto cleanup;
|
}
|
}
|
|
|
gfc_current_locus = comp_tail->where;
|
gfc_current_locus = comp_tail->where;
|
strncpy (comp_tail->name, comp->name, GFC_MAX_SYMBOL_LEN + 1);
|
strncpy (comp_tail->name, comp->name, GFC_MAX_SYMBOL_LEN + 1);
|
}
|
}
|
|
|
/* 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. */
|
its access is not private. */
|
if (comp)
|
if (comp)
|
this_comp = gfc_find_component (sym, comp->name, false, false);
|
this_comp = gfc_find_component (sym, comp->name, false, false);
|
else
|
else
|
{
|
{
|
this_comp = gfc_find_component (sym,
|
this_comp = gfc_find_component (sym,
|
(const char *)comp_tail->name,
|
(const char *)comp_tail->name,
|
false, false);
|
false, false);
|
comp = NULL; /* Reset needed! */
|
comp = NULL; /* Reset needed! */
|
}
|
}
|
|
|
/* Here we can check if a component name is given which does not
|
/* Here we can check if a component name is given which does not
|
correspond to any component of the defined structure. */
|
correspond to any component of the defined structure. */
|
if (!this_comp)
|
if (!this_comp)
|
goto cleanup;
|
goto cleanup;
|
|
|
/* Check if this component is already given a value. */
|
/* Check if this component is already given a value. */
|
for (comp_iter = comp_head; comp_iter != comp_tail;
|
for (comp_iter = comp_head; comp_iter != comp_tail;
|
comp_iter = comp_iter->next)
|
comp_iter = comp_iter->next)
|
{
|
{
|
gcc_assert (comp_iter);
|
gcc_assert (comp_iter);
|
if (!strcmp (comp_iter->name, comp_tail->name))
|
if (!strcmp (comp_iter->name, comp_tail->name))
|
{
|
{
|
gfc_error ("Component '%s' is initialized twice in the"
|
gfc_error ("Component '%s' is initialized twice in the"
|
" structure constructor at %C!", comp_tail->name);
|
" structure constructor at %C!", comp_tail->name);
|
goto cleanup;
|
goto cleanup;
|
}
|
}
|
}
|
}
|
|
|
/* Match the current initializer expression. */
|
/* Match the current initializer expression. */
|
m = gfc_match_expr (&comp_tail->val);
|
m = gfc_match_expr (&comp_tail->val);
|
if (m == MATCH_NO)
|
if (m == MATCH_NO)
|
goto syntax;
|
goto syntax;
|
if (m == MATCH_ERROR)
|
if (m == MATCH_ERROR)
|
goto cleanup;
|
goto cleanup;
|
|
|
/* If not explicitly a parent constructor, gather up the components
|
/* If not explicitly a parent constructor, gather up the components
|
and build one. */
|
and build one. */
|
if (comp && comp == sym->components
|
if (comp && comp == sym->components
|
&& sym->attr.extension
|
&& sym->attr.extension
|
&& (comp_tail->val->ts.type != BT_DERIVED
|
&& (comp_tail->val->ts.type != BT_DERIVED
|
||
|
||
|
comp_tail->val->ts.u.derived != this_comp->ts.u.derived))
|
comp_tail->val->ts.u.derived != this_comp->ts.u.derived))
|
{
|
{
|
gfc_current_locus = where;
|
gfc_current_locus = where;
|
gfc_free_expr (comp_tail->val);
|
gfc_free_expr (comp_tail->val);
|
comp_tail->val = NULL;
|
comp_tail->val = NULL;
|
|
|
m = gfc_match_structure_constructor (comp->ts.u.derived,
|
m = gfc_match_structure_constructor (comp->ts.u.derived,
|
&comp_tail->val, true);
|
&comp_tail->val, true);
|
if (m == MATCH_NO)
|
if (m == MATCH_NO)
|
goto syntax;
|
goto syntax;
|
if (m == MATCH_ERROR)
|
if (m == MATCH_ERROR)
|
goto cleanup;
|
goto cleanup;
|
}
|
}
|
|
|
if (comp)
|
if (comp)
|
comp = comp->next;
|
comp = comp->next;
|
|
|
if (parent && !comp)
|
if (parent && !comp)
|
break;
|
break;
|
}
|
}
|
|
|
while (gfc_match_char (',') == MATCH_YES);
|
while (gfc_match_char (',') == MATCH_YES);
|
|
|
if (!parent && gfc_match_char (')') != MATCH_YES)
|
if (!parent && gfc_match_char (')') != MATCH_YES)
|
goto syntax;
|
goto syntax;
|
}
|
}
|
|
|
if (build_actual_constructor (&comp_head, &ctor_head, sym) == FAILURE)
|
if (build_actual_constructor (&comp_head, &ctor_head, sym) == FAILURE)
|
goto cleanup;
|
goto cleanup;
|
|
|
/* No component should be left, as this should have caused an error in the
|
/* 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
|
loop constructing the component-list (name that does not correspond to any
|
component in the structure definition). */
|
component in the structure definition). */
|
if (comp_head && sym->attr.extension)
|
if (comp_head && sym->attr.extension)
|
{
|
{
|
for (comp_iter = comp_head; comp_iter; comp_iter = comp_iter->next)
|
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 '%s' at %L has already been set by a "
|
"parent derived type constructor", comp_iter->name,
|
"parent derived type constructor", comp_iter->name,
|
&comp_iter->where);
|
&comp_iter->where);
|
}
|
}
|
goto cleanup;
|
goto cleanup;
|
}
|
}
|
else
|
else
|
gcc_assert (!comp_head);
|
gcc_assert (!comp_head);
|
|
|
e = gfc_get_expr ();
|
e = gfc_get_expr ();
|
|
|
e->expr_type = EXPR_STRUCTURE;
|
e->expr_type = EXPR_STRUCTURE;
|
|
|
e->ts.type = BT_DERIVED;
|
e->ts.type = BT_DERIVED;
|
e->ts.u.derived = sym;
|
e->ts.u.derived = sym;
|
e->where = where;
|
e->where = where;
|
|
|
e->value.constructor = ctor_head;
|
e->value.constructor = ctor_head;
|
|
|
*result = e;
|
*result = e;
|
return MATCH_YES;
|
return MATCH_YES;
|
|
|
syntax:
|
syntax:
|
gfc_error ("Syntax error in structure constructor at %C");
|
gfc_error ("Syntax error in structure constructor at %C");
|
|
|
cleanup:
|
cleanup:
|
for (comp_iter = comp_head; comp_iter; )
|
for (comp_iter = comp_head; comp_iter; )
|
{
|
{
|
gfc_structure_ctor_component *next = comp_iter->next;
|
gfc_structure_ctor_component *next = comp_iter->next;
|
gfc_free_structure_ctor_component (comp_iter);
|
gfc_free_structure_ctor_component (comp_iter);
|
comp_iter = next;
|
comp_iter = next;
|
}
|
}
|
gfc_free_constructor (ctor_head);
|
gfc_free_constructor (ctor_head);
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
}
|
}
|
|
|
|
|
/* If the symbol is an implicit do loop index and implicitly typed,
|
/* If the symbol is an implicit do loop index and implicitly typed,
|
it should not be host associated. Provide a symtree from the
|
it should not be host associated. Provide a symtree from the
|
current namespace. */
|
current namespace. */
|
static match
|
static match
|
check_for_implicit_index (gfc_symtree **st, gfc_symbol **sym)
|
check_for_implicit_index (gfc_symtree **st, gfc_symbol **sym)
|
{
|
{
|
if ((*sym)->attr.flavor == FL_VARIABLE
|
if ((*sym)->attr.flavor == FL_VARIABLE
|
&& (*sym)->ns != gfc_current_ns
|
&& (*sym)->ns != gfc_current_ns
|
&& (*sym)->attr.implied_index
|
&& (*sym)->attr.implied_index
|
&& (*sym)->attr.implicit_type
|
&& (*sym)->attr.implicit_type
|
&& !(*sym)->attr.use_assoc)
|
&& !(*sym)->attr.use_assoc)
|
{
|
{
|
int i;
|
int i;
|
i = gfc_get_sym_tree ((*sym)->name, NULL, st, false);
|
i = gfc_get_sym_tree ((*sym)->name, NULL, st, false);
|
if (i)
|
if (i)
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
*sym = (*st)->n.sym;
|
*sym = (*st)->n.sym;
|
}
|
}
|
return MATCH_YES;
|
return MATCH_YES;
|
}
|
}
|
|
|
|
|
/* Procedure pointer as function result: Replace the function symbol by the
|
/* Procedure pointer as function result: Replace the function symbol by the
|
auto-generated hidden result variable named "ppr@". */
|
auto-generated hidden result variable named "ppr@". */
|
|
|
static gfc_try
|
static gfc_try
|
replace_hidden_procptr_result (gfc_symbol **sym, gfc_symtree **st)
|
replace_hidden_procptr_result (gfc_symbol **sym, gfc_symtree **st)
|
{
|
{
|
/* Check for procedure pointer result variable. */
|
/* Check for procedure pointer result variable. */
|
if ((*sym)->attr.function && !(*sym)->attr.external
|
if ((*sym)->attr.function && !(*sym)->attr.external
|
&& (*sym)->result && (*sym)->result != *sym
|
&& (*sym)->result && (*sym)->result != *sym
|
&& (*sym)->result->attr.proc_pointer
|
&& (*sym)->result->attr.proc_pointer
|
&& (*sym) == gfc_current_ns->proc_name
|
&& (*sym) == gfc_current_ns->proc_name
|
&& (*sym) == (*sym)->result->ns->proc_name
|
&& (*sym) == (*sym)->result->ns->proc_name
|
&& strcmp ("ppr@", (*sym)->result->name) == 0)
|
&& strcmp ("ppr@", (*sym)->result->name) == 0)
|
{
|
{
|
/* Automatic replacement with "hidden" result variable. */
|
/* Automatic replacement with "hidden" result variable. */
|
(*sym)->result->attr.referenced = (*sym)->attr.referenced;
|
(*sym)->result->attr.referenced = (*sym)->attr.referenced;
|
*sym = (*sym)->result;
|
*sym = (*sym)->result;
|
*st = gfc_find_symtree ((*sym)->ns->sym_root, (*sym)->name);
|
*st = gfc_find_symtree ((*sym)->ns->sym_root, (*sym)->name);
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
|
|
/* Matches a variable name followed by anything that might follow it--
|
/* Matches a variable name followed by anything that might follow it--
|
array reference, argument list of a function, etc. */
|
array reference, argument list of a function, etc. */
|
|
|
match
|
match
|
gfc_match_rvalue (gfc_expr **result)
|
gfc_match_rvalue (gfc_expr **result)
|
{
|
{
|
gfc_actual_arglist *actual_arglist;
|
gfc_actual_arglist *actual_arglist;
|
char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1];
|
char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1];
|
gfc_state_data *st;
|
gfc_state_data *st;
|
gfc_symbol *sym;
|
gfc_symbol *sym;
|
gfc_symtree *symtree;
|
gfc_symtree *symtree;
|
locus where, old_loc;
|
locus where, old_loc;
|
gfc_expr *e;
|
gfc_expr *e;
|
match m, m2;
|
match m, m2;
|
int i;
|
int i;
|
gfc_typespec *ts;
|
gfc_typespec *ts;
|
bool implicit_char;
|
bool implicit_char;
|
gfc_ref *ref;
|
gfc_ref *ref;
|
|
|
m = gfc_match_name (name);
|
m = gfc_match_name (name);
|
if (m != MATCH_YES)
|
if (m != MATCH_YES)
|
return m;
|
return m;
|
|
|
if (gfc_find_state (COMP_INTERFACE) == SUCCESS
|
if (gfc_find_state (COMP_INTERFACE) == SUCCESS
|
&& !gfc_current_ns->has_import_set)
|
&& !gfc_current_ns->has_import_set)
|
i = gfc_get_sym_tree (name, NULL, &symtree, false);
|
i = gfc_get_sym_tree (name, NULL, &symtree, false);
|
else
|
else
|
i = gfc_get_ha_sym_tree (name, &symtree);
|
i = gfc_get_ha_sym_tree (name, &symtree);
|
|
|
if (i)
|
if (i)
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
|
|
sym = symtree->n.sym;
|
sym = symtree->n.sym;
|
e = NULL;
|
e = NULL;
|
where = gfc_current_locus;
|
where = gfc_current_locus;
|
|
|
replace_hidden_procptr_result (&sym, &symtree);
|
replace_hidden_procptr_result (&sym, &symtree);
|
|
|
/* If this is an implicit do loop index and implicitly typed,
|
/* If this is an implicit do loop index and implicitly typed,
|
it should not be host associated. */
|
it should not be host associated. */
|
m = check_for_implicit_index (&symtree, &sym);
|
m = check_for_implicit_index (&symtree, &sym);
|
if (m != MATCH_YES)
|
if (m != MATCH_YES)
|
return m;
|
return m;
|
|
|
gfc_set_sym_referenced (sym);
|
gfc_set_sym_referenced (sym);
|
sym->attr.implied_index = 0;
|
sym->attr.implied_index = 0;
|
|
|
if (sym->attr.function && sym->result == sym)
|
if (sym->attr.function && sym->result == sym)
|
{
|
{
|
/* See if this is a directly recursive function call. */
|
/* See if this is a directly recursive function call. */
|
gfc_gobble_whitespace ();
|
gfc_gobble_whitespace ();
|
if (sym->attr.recursive
|
if (sym->attr.recursive
|
&& gfc_peek_ascii_char () == '('
|
&& gfc_peek_ascii_char () == '('
|
&& gfc_current_ns->proc_name == sym
|
&& gfc_current_ns->proc_name == sym
|
&& !sym->attr.dimension)
|
&& !sym->attr.dimension)
|
{
|
{
|
gfc_error ("'%s' at %C is the name of a recursive function "
|
gfc_error ("'%s' at %C is the name of a recursive function "
|
"and so refers to the result variable. Use an "
|
"and so refers to the result variable. Use an "
|
"explicit RESULT variable for direct recursion "
|
"explicit RESULT variable for direct recursion "
|
"(12.5.2.1)", sym->name);
|
"(12.5.2.1)", sym->name);
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
}
|
}
|
|
|
if (gfc_is_function_return_value (sym, gfc_current_ns))
|
if (gfc_is_function_return_value (sym, gfc_current_ns))
|
goto variable;
|
goto variable;
|
|
|
if (sym->attr.entry
|
if (sym->attr.entry
|
&& (sym->ns == gfc_current_ns
|
&& (sym->ns == gfc_current_ns
|
|| sym->ns == gfc_current_ns->parent))
|
|| sym->ns == gfc_current_ns->parent))
|
{
|
{
|
gfc_entry_list *el = NULL;
|
gfc_entry_list *el = NULL;
|
|
|
for (el = sym->ns->entries; el; el = el->next)
|
for (el = sym->ns->entries; el; el = el->next)
|
if (sym == el->sym)
|
if (sym == el->sym)
|
goto variable;
|
goto variable;
|
}
|
}
|
}
|
}
|
|
|
if (gfc_matching_procptr_assignment)
|
if (gfc_matching_procptr_assignment)
|
goto procptr0;
|
goto procptr0;
|
|
|
if (sym->attr.function || sym->attr.external || sym->attr.intrinsic)
|
if (sym->attr.function || sym->attr.external || sym->attr.intrinsic)
|
goto function0;
|
goto function0;
|
|
|
if (sym->attr.generic)
|
if (sym->attr.generic)
|
goto generic_function;
|
goto generic_function;
|
|
|
switch (sym->attr.flavor)
|
switch (sym->attr.flavor)
|
{
|
{
|
case FL_VARIABLE:
|
case FL_VARIABLE:
|
variable:
|
variable:
|
e = gfc_get_expr ();
|
e = gfc_get_expr ();
|
|
|
e->expr_type = EXPR_VARIABLE;
|
e->expr_type = EXPR_VARIABLE;
|
e->symtree = symtree;
|
e->symtree = symtree;
|
|
|
m = gfc_match_varspec (e, 0, false, true);
|
m = gfc_match_varspec (e, 0, false, true);
|
break;
|
break;
|
|
|
case FL_PARAMETER:
|
case FL_PARAMETER:
|
/* A statement of the form "REAL, parameter :: a(0:10) = 1" will
|
/* 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
|
EXPR_CONSTANT, and so the if () branch would be followed without
|
the !sym->as check. */
|
the !sym->as check. */
|
if (sym->value && sym->value->expr_type != EXPR_ARRAY && !sym->as)
|
if (sym->value && sym->value->expr_type != EXPR_ARRAY && !sym->as)
|
e = gfc_copy_expr (sym->value);
|
e = gfc_copy_expr (sym->value);
|
else
|
else
|
{
|
{
|
e = gfc_get_expr ();
|
e = gfc_get_expr ();
|
e->expr_type = EXPR_VARIABLE;
|
e->expr_type = EXPR_VARIABLE;
|
}
|
}
|
|
|
e->symtree = symtree;
|
e->symtree = symtree;
|
m = gfc_match_varspec (e, 0, false, true);
|
m = gfc_match_varspec (e, 0, false, true);
|
|
|
if (sym->ts.is_c_interop || sym->ts.is_iso_c)
|
if (sym->ts.is_c_interop || sym->ts.is_iso_c)
|
break;
|
break;
|
|
|
/* Variable array references to derived type parameters cause
|
/* Variable array references to derived type parameters cause
|
all sorts of headaches in simplification. Treating such
|
all sorts of headaches in simplification. Treating such
|
expressions as variable works just fine for all array
|
expressions as variable works just fine for all array
|
references. */
|
references. */
|
if (sym->value && sym->ts.type == BT_DERIVED && e->ref)
|
if (sym->value && sym->ts.type == BT_DERIVED && e->ref)
|
{
|
{
|
for (ref = e->ref; ref; ref = ref->next)
|
for (ref = e->ref; ref; ref = ref->next)
|
if (ref->type == REF_ARRAY)
|
if (ref->type == REF_ARRAY)
|
break;
|
break;
|
|
|
if (ref == NULL || ref->u.ar.type == AR_FULL)
|
if (ref == NULL || ref->u.ar.type == AR_FULL)
|
break;
|
break;
|
|
|
ref = e->ref;
|
ref = e->ref;
|
e->ref = NULL;
|
e->ref = NULL;
|
gfc_free_expr (e);
|
gfc_free_expr (e);
|
e = gfc_get_expr ();
|
e = gfc_get_expr ();
|
e->expr_type = EXPR_VARIABLE;
|
e->expr_type = EXPR_VARIABLE;
|
e->symtree = symtree;
|
e->symtree = symtree;
|
e->ref = ref;
|
e->ref = ref;
|
}
|
}
|
|
|
break;
|
break;
|
|
|
case FL_DERIVED:
|
case FL_DERIVED:
|
sym = gfc_use_derived (sym);
|
sym = gfc_use_derived (sym);
|
if (sym == NULL)
|
if (sym == NULL)
|
m = MATCH_ERROR;
|
m = MATCH_ERROR;
|
else
|
else
|
m = gfc_match_structure_constructor (sym, &e, false);
|
m = gfc_match_structure_constructor (sym, &e, false);
|
break;
|
break;
|
|
|
/* If we're here, then the name is known to be the name of a
|
/* 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. */
|
procedure, yet it is not sure to be the name of a function. */
|
case FL_PROCEDURE:
|
case FL_PROCEDURE:
|
|
|
/* Procedure Pointer Assignments. */
|
/* Procedure Pointer Assignments. */
|
procptr0:
|
procptr0:
|
if (gfc_matching_procptr_assignment)
|
if (gfc_matching_procptr_assignment)
|
{
|
{
|
gfc_gobble_whitespace ();
|
gfc_gobble_whitespace ();
|
if (!sym->attr.dimension && gfc_peek_ascii_char () == '(')
|
if (!sym->attr.dimension && gfc_peek_ascii_char () == '(')
|
/* Parse functions returning a procptr. */
|
/* Parse functions returning a procptr. */
|
goto function0;
|
goto function0;
|
|
|
if (gfc_is_intrinsic (sym, 0, gfc_current_locus)
|
if (gfc_is_intrinsic (sym, 0, gfc_current_locus)
|
|| gfc_is_intrinsic (sym, 1, gfc_current_locus))
|
|| gfc_is_intrinsic (sym, 1, gfc_current_locus))
|
sym->attr.intrinsic = 1;
|
sym->attr.intrinsic = 1;
|
e = gfc_get_expr ();
|
e = gfc_get_expr ();
|
e->expr_type = EXPR_VARIABLE;
|
e->expr_type = EXPR_VARIABLE;
|
e->symtree = symtree;
|
e->symtree = symtree;
|
m = gfc_match_varspec (e, 0, false, true);
|
m = gfc_match_varspec (e, 0, false, true);
|
break;
|
break;
|
}
|
}
|
|
|
if (sym->attr.subroutine)
|
if (sym->attr.subroutine)
|
{
|
{
|
gfc_error ("Unexpected use of subroutine name '%s' at %C",
|
gfc_error ("Unexpected use of subroutine name '%s' at %C",
|
sym->name);
|
sym->name);
|
m = MATCH_ERROR;
|
m = MATCH_ERROR;
|
break;
|
break;
|
}
|
}
|
|
|
/* At this point, the name has to be a non-statement function.
|
/* At this point, the name has to be a non-statement function.
|
If the name is the same as the current function being
|
If the name is the same as the current function being
|
compiled, then we have a variable reference (to the function
|
compiled, then we have a variable reference (to the function
|
result) if the name is non-recursive. */
|
result) if the name is non-recursive. */
|
|
|
st = gfc_enclosing_unit (NULL);
|
st = gfc_enclosing_unit (NULL);
|
|
|
if (st != NULL && st->state == COMP_FUNCTION
|
if (st != NULL && st->state == COMP_FUNCTION
|
&& st->sym == sym
|
&& st->sym == sym
|
&& !sym->attr.recursive)
|
&& !sym->attr.recursive)
|
{
|
{
|
e = gfc_get_expr ();
|
e = gfc_get_expr ();
|
e->symtree = symtree;
|
e->symtree = symtree;
|
e->expr_type = EXPR_VARIABLE;
|
e->expr_type = EXPR_VARIABLE;
|
|
|
m = gfc_match_varspec (e, 0, false, true);
|
m = gfc_match_varspec (e, 0, false, true);
|
break;
|
break;
|
}
|
}
|
|
|
/* Match a function reference. */
|
/* Match a function reference. */
|
function0:
|
function0:
|
m = gfc_match_actual_arglist (0, &actual_arglist);
|
m = gfc_match_actual_arglist (0, &actual_arglist);
|
if (m == MATCH_NO)
|
if (m == MATCH_NO)
|
{
|
{
|
if (sym->attr.proc == PROC_ST_FUNCTION)
|
if (sym->attr.proc == PROC_ST_FUNCTION)
|
gfc_error ("Statement function '%s' requires argument list at %C",
|
gfc_error ("Statement function '%s' requires argument list at %C",
|
sym->name);
|
sym->name);
|
else
|
else
|
gfc_error ("Function '%s' requires an argument list at %C",
|
gfc_error ("Function '%s' requires an argument list at %C",
|
sym->name);
|
sym->name);
|
|
|
m = MATCH_ERROR;
|
m = MATCH_ERROR;
|
break;
|
break;
|
}
|
}
|
|
|
if (m != MATCH_YES)
|
if (m != MATCH_YES)
|
{
|
{
|
m = MATCH_ERROR;
|
m = MATCH_ERROR;
|
break;
|
break;
|
}
|
}
|
|
|
gfc_get_ha_sym_tree (name, &symtree); /* Can't fail */
|
gfc_get_ha_sym_tree (name, &symtree); /* Can't fail */
|
sym = symtree->n.sym;
|
sym = symtree->n.sym;
|
|
|
replace_hidden_procptr_result (&sym, &symtree);
|
replace_hidden_procptr_result (&sym, &symtree);
|
|
|
e = gfc_get_expr ();
|
e = gfc_get_expr ();
|
e->symtree = symtree;
|
e->symtree = symtree;
|
e->expr_type = EXPR_FUNCTION;
|
e->expr_type = EXPR_FUNCTION;
|
e->value.function.actual = actual_arglist;
|
e->value.function.actual = actual_arglist;
|
e->where = gfc_current_locus;
|
e->where = gfc_current_locus;
|
|
|
if (sym->as != NULL)
|
if (sym->as != NULL)
|
e->rank = sym->as->rank;
|
e->rank = sym->as->rank;
|
|
|
if (!sym->attr.function
|
if (!sym->attr.function
|
&& gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
|
&& gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
|
{
|
{
|
m = MATCH_ERROR;
|
m = MATCH_ERROR;
|
break;
|
break;
|
}
|
}
|
|
|
/* Check here for the existence of at least one argument for the
|
/* Check here for the existence of at least one argument for the
|
iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED. 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,
|
argument(s) given will be checked in gfc_iso_c_func_interface,
|
during resolution of the function call. */
|
during resolution of the function call. */
|
if (sym->attr.is_iso_c == 1
|
if (sym->attr.is_iso_c == 1
|
&& (sym->from_intmod == INTMOD_ISO_C_BINDING
|
&& (sym->from_intmod == INTMOD_ISO_C_BINDING
|
&& (sym->intmod_sym_id == ISOCBINDING_LOC
|
&& (sym->intmod_sym_id == ISOCBINDING_LOC
|
|| sym->intmod_sym_id == ISOCBINDING_FUNLOC
|
|| sym->intmod_sym_id == ISOCBINDING_FUNLOC
|
|| sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)))
|
|| sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)))
|
{
|
{
|
/* make sure we were given a param */
|
/* make sure we were given a param */
|
if (actual_arglist == NULL)
|
if (actual_arglist == NULL)
|
{
|
{
|
gfc_error ("Missing argument to '%s' at %C", sym->name);
|
gfc_error ("Missing argument to '%s' at %C", sym->name);
|
m = MATCH_ERROR;
|
m = MATCH_ERROR;
|
break;
|
break;
|
}
|
}
|
}
|
}
|
|
|
if (sym->result == NULL)
|
if (sym->result == NULL)
|
sym->result = sym;
|
sym->result = sym;
|
|
|
m = MATCH_YES;
|
m = MATCH_YES;
|
break;
|
break;
|
|
|
case FL_UNKNOWN:
|
case FL_UNKNOWN:
|
|
|
/* Special case for derived type variables that get their types
|
/* Special case for derived type variables that get their types
|
via an IMPLICIT statement. This can't wait for the
|
via an IMPLICIT statement. This can't wait for the
|
resolution phase. */
|
resolution phase. */
|
|
|
if (gfc_peek_ascii_char () == '%'
|
if (gfc_peek_ascii_char () == '%'
|
&& sym->ts.type == BT_UNKNOWN
|
&& sym->ts.type == BT_UNKNOWN
|
&& gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
|
&& gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
|
gfc_set_default_type (sym, 0, sym->ns);
|
gfc_set_default_type (sym, 0, sym->ns);
|
|
|
/* If the symbol has a dimension attribute, the expression is a
|
/* If the symbol has a dimension attribute, the expression is a
|
variable. */
|
variable. */
|
|
|
if (sym->attr.dimension)
|
if (sym->attr.dimension)
|
{
|
{
|
if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
|
if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
|
sym->name, NULL) == FAILURE)
|
sym->name, NULL) == FAILURE)
|
{
|
{
|
m = MATCH_ERROR;
|
m = MATCH_ERROR;
|
break;
|
break;
|
}
|
}
|
|
|
e = gfc_get_expr ();
|
e = gfc_get_expr ();
|
e->symtree = symtree;
|
e->symtree = symtree;
|
e->expr_type = EXPR_VARIABLE;
|
e->expr_type = EXPR_VARIABLE;
|
m = gfc_match_varspec (e, 0, false, true);
|
m = gfc_match_varspec (e, 0, false, true);
|
break;
|
break;
|
}
|
}
|
|
|
/* Name is not an array, so we peek to see if a '(' implies a
|
/* Name is not an array, so we peek to see if a '(' implies a
|
function call or a substring reference. Otherwise the
|
function call or a substring reference. Otherwise the
|
variable is just a scalar. */
|
variable is just a scalar. */
|
|
|
gfc_gobble_whitespace ();
|
gfc_gobble_whitespace ();
|
if (gfc_peek_ascii_char () != '(')
|
if (gfc_peek_ascii_char () != '(')
|
{
|
{
|
/* Assume a scalar variable */
|
/* Assume a scalar variable */
|
e = gfc_get_expr ();
|
e = gfc_get_expr ();
|
e->symtree = symtree;
|
e->symtree = symtree;
|
e->expr_type = EXPR_VARIABLE;
|
e->expr_type = EXPR_VARIABLE;
|
|
|
if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
|
if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
|
sym->name, NULL) == FAILURE)
|
sym->name, NULL) == FAILURE)
|
{
|
{
|
m = MATCH_ERROR;
|
m = MATCH_ERROR;
|
break;
|
break;
|
}
|
}
|
|
|
/*FIXME:??? gfc_match_varspec does set this for us: */
|
/*FIXME:??? gfc_match_varspec does set this for us: */
|
e->ts = sym->ts;
|
e->ts = sym->ts;
|
m = gfc_match_varspec (e, 0, false, true);
|
m = gfc_match_varspec (e, 0, false, true);
|
break;
|
break;
|
}
|
}
|
|
|
/* See if this is a function reference with a keyword argument
|
/* See if this is a function reference with a keyword argument
|
as first argument. We do this because otherwise a spurious
|
as first argument. We do this because otherwise a spurious
|
symbol would end up in the symbol table. */
|
symbol would end up in the symbol table. */
|
|
|
old_loc = gfc_current_locus;
|
old_loc = gfc_current_locus;
|
m2 = gfc_match (" ( %n =", argname);
|
m2 = gfc_match (" ( %n =", argname);
|
gfc_current_locus = old_loc;
|
gfc_current_locus = old_loc;
|
|
|
e = gfc_get_expr ();
|
e = gfc_get_expr ();
|
e->symtree = symtree;
|
e->symtree = symtree;
|
|
|
if (m2 != MATCH_YES)
|
if (m2 != MATCH_YES)
|
{
|
{
|
/* Try to figure out whether we're dealing with a character type.
|
/* 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
|
match_substring if we're dealing with an implicitly typed
|
non-character variable. */
|
non-character variable. */
|
implicit_char = false;
|
implicit_char = false;
|
if (sym->ts.type == BT_UNKNOWN)
|
if (sym->ts.type == BT_UNKNOWN)
|
{
|
{
|
ts = gfc_get_default_type (sym->name, NULL);
|
ts = gfc_get_default_type (sym->name, NULL);
|
if (ts->type == BT_CHARACTER)
|
if (ts->type == BT_CHARACTER)
|
implicit_char = true;
|
implicit_char = true;
|
}
|
}
|
|
|
/* See if this could possibly be a substring reference of a name
|
/* See if this could possibly be a substring reference of a name
|
that we're not sure is a variable yet. */
|
that we're not sure is a variable yet. */
|
|
|
if ((implicit_char || sym->ts.type == BT_CHARACTER)
|
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) == MATCH_YES)
|
{
|
{
|
|
|
e->expr_type = EXPR_VARIABLE;
|
e->expr_type = EXPR_VARIABLE;
|
|
|
if (sym->attr.flavor != FL_VARIABLE
|
if (sym->attr.flavor != FL_VARIABLE
|
&& gfc_add_flavor (&sym->attr, FL_VARIABLE,
|
&& gfc_add_flavor (&sym->attr, FL_VARIABLE,
|
sym->name, NULL) == FAILURE)
|
sym->name, NULL) == FAILURE)
|
{
|
{
|
m = MATCH_ERROR;
|
m = MATCH_ERROR;
|
break;
|
break;
|
}
|
}
|
|
|
if (sym->ts.type == BT_UNKNOWN
|
if (sym->ts.type == BT_UNKNOWN
|
&& gfc_set_default_type (sym, 1, NULL) == FAILURE)
|
&& gfc_set_default_type (sym, 1, NULL) == FAILURE)
|
{
|
{
|
m = MATCH_ERROR;
|
m = MATCH_ERROR;
|
break;
|
break;
|
}
|
}
|
|
|
e->ts = sym->ts;
|
e->ts = sym->ts;
|
if (e->ref)
|
if (e->ref)
|
e->ts.u.cl = NULL;
|
e->ts.u.cl = NULL;
|
m = MATCH_YES;
|
m = MATCH_YES;
|
break;
|
break;
|
}
|
}
|
}
|
}
|
|
|
/* Give up, assume we have a function. */
|
/* Give up, assume we have a function. */
|
|
|
gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */
|
gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */
|
sym = symtree->n.sym;
|
sym = symtree->n.sym;
|
e->expr_type = EXPR_FUNCTION;
|
e->expr_type = EXPR_FUNCTION;
|
|
|
if (!sym->attr.function
|
if (!sym->attr.function
|
&& gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
|
&& gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
|
{
|
{
|
m = MATCH_ERROR;
|
m = MATCH_ERROR;
|
break;
|
break;
|
}
|
}
|
|
|
sym->result = sym;
|
sym->result = sym;
|
|
|
m = gfc_match_actual_arglist (0, &e->value.function.actual);
|
m = gfc_match_actual_arglist (0, &e->value.function.actual);
|
if (m == MATCH_NO)
|
if (m == MATCH_NO)
|
gfc_error ("Missing argument list in function '%s' at %C", sym->name);
|
gfc_error ("Missing argument list in function '%s' at %C", sym->name);
|
|
|
if (m != MATCH_YES)
|
if (m != MATCH_YES)
|
{
|
{
|
m = MATCH_ERROR;
|
m = MATCH_ERROR;
|
break;
|
break;
|
}
|
}
|
|
|
/* If our new function returns a character, array or structure
|
/* If our new function returns a character, array or structure
|
type, it might have subsequent references. */
|
type, it might have subsequent references. */
|
|
|
m = gfc_match_varspec (e, 0, false, true);
|
m = gfc_match_varspec (e, 0, false, true);
|
if (m == MATCH_NO)
|
if (m == MATCH_NO)
|
m = MATCH_YES;
|
m = MATCH_YES;
|
|
|
break;
|
break;
|
|
|
generic_function:
|
generic_function:
|
gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */
|
gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */
|
|
|
e = gfc_get_expr ();
|
e = gfc_get_expr ();
|
e->symtree = symtree;
|
e->symtree = symtree;
|
e->expr_type = EXPR_FUNCTION;
|
e->expr_type = EXPR_FUNCTION;
|
|
|
m = gfc_match_actual_arglist (0, &e->value.function.actual);
|
m = gfc_match_actual_arglist (0, &e->value.function.actual);
|
break;
|
break;
|
|
|
default:
|
default:
|
gfc_error ("Symbol at %C is not appropriate for an expression");
|
gfc_error ("Symbol at %C is not appropriate for an expression");
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
}
|
}
|
|
|
if (m == MATCH_YES)
|
if (m == MATCH_YES)
|
{
|
{
|
e->where = where;
|
e->where = where;
|
*result = e;
|
*result = e;
|
}
|
}
|
else
|
else
|
gfc_free_expr (e);
|
gfc_free_expr (e);
|
|
|
return m;
|
return m;
|
}
|
}
|
|
|
|
|
/* Match a variable, i.e. 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
|
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
|
reference. It can be a function if the function doesn't have a
|
separate RESULT variable. If the symbol has not been previously
|
separate RESULT variable. If the symbol has not been previously
|
seen, we assume it is a variable.
|
seen, we assume it is a variable.
|
|
|
This function is called by two interface functions:
|
This function is called by two interface functions:
|
gfc_match_variable, which has host_flag = 1, and
|
gfc_match_variable, which has host_flag = 1, and
|
gfc_match_equiv_variable, with host_flag = 0, to restrict the
|
gfc_match_equiv_variable, with host_flag = 0, to restrict the
|
match of the symbol to the local scope. */
|
match of the symbol to the local scope. */
|
|
|
static match
|
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_symbol *sym;
|
gfc_symtree *st;
|
gfc_symtree *st;
|
gfc_expr *expr;
|
gfc_expr *expr;
|
locus where;
|
locus where;
|
match m;
|
match m;
|
|
|
/* Since nothing has any business being an lvalue in a module
|
/* Since nothing has any business being an lvalue in a module
|
specification block, an interface block or a contains section,
|
specification block, an interface block or a contains section,
|
we force the changed_symbols mechanism to work by setting
|
we force the changed_symbols mechanism to work by setting
|
host_flag to 0. This prevents valid symbols that have the name
|
host_flag to 0. This prevents valid symbols that have the name
|
of keywords, such as 'end', being turned into variables by
|
of keywords, such as 'end', being turned into variables by
|
failed matching to assignments for, e.g., END INTERFACE. */
|
failed matching to assignments for, e.g., END INTERFACE. */
|
if (gfc_current_state () == COMP_MODULE
|
if (gfc_current_state () == COMP_MODULE
|
|| gfc_current_state () == COMP_INTERFACE
|
|| gfc_current_state () == COMP_INTERFACE
|
|| gfc_current_state () == COMP_CONTAINS)
|
|| gfc_current_state () == COMP_CONTAINS)
|
host_flag = 0;
|
host_flag = 0;
|
|
|
where = gfc_current_locus;
|
where = gfc_current_locus;
|
m = gfc_match_sym_tree (&st, host_flag);
|
m = gfc_match_sym_tree (&st, host_flag);
|
if (m != MATCH_YES)
|
if (m != MATCH_YES)
|
return m;
|
return m;
|
|
|
sym = st->n.sym;
|
sym = st->n.sym;
|
|
|
/* If this is an implicit do loop index and implicitly typed,
|
/* If this is an implicit do loop index and implicitly typed,
|
it should not be host associated. */
|
it should not be host associated. */
|
m = check_for_implicit_index (&st, &sym);
|
m = check_for_implicit_index (&st, &sym);
|
if (m != MATCH_YES)
|
if (m != MATCH_YES)
|
return m;
|
return m;
|
|
|
sym->attr.implied_index = 0;
|
sym->attr.implied_index = 0;
|
|
|
gfc_set_sym_referenced (sym);
|
gfc_set_sym_referenced (sym);
|
switch (sym->attr.flavor)
|
switch (sym->attr.flavor)
|
{
|
{
|
case FL_VARIABLE:
|
case FL_VARIABLE:
|
if (sym->attr.is_protected && sym->attr.use_assoc)
|
if (sym->attr.is_protected && sym->attr.use_assoc)
|
{
|
{
|
gfc_error ("Assigning to PROTECTED variable at %C");
|
gfc_error ("Assigning to PROTECTED variable at %C");
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
}
|
}
|
break;
|
break;
|
|
|
case FL_UNKNOWN:
|
case FL_UNKNOWN:
|
{
|
{
|
sym_flavor flavor = FL_UNKNOWN;
|
sym_flavor flavor = FL_UNKNOWN;
|
|
|
gfc_gobble_whitespace ();
|
gfc_gobble_whitespace ();
|
|
|
if (sym->attr.external || sym->attr.procedure
|
if (sym->attr.external || sym->attr.procedure
|
|| sym->attr.function || sym->attr.subroutine)
|
|| sym->attr.function || sym->attr.subroutine)
|
flavor = FL_PROCEDURE;
|
flavor = FL_PROCEDURE;
|
|
|
/* If it is not a procedure, is not typed and is host associated,
|
/* If it is not a procedure, is not typed and is host associated,
|
we cannot give it a flavor yet. */
|
we cannot give it a flavor yet. */
|
else if (sym->ns == gfc_current_ns->parent
|
else if (sym->ns == gfc_current_ns->parent
|
&& sym->ts.type == BT_UNKNOWN)
|
&& sym->ts.type == BT_UNKNOWN)
|
break;
|
break;
|
|
|
/* These are definitive indicators that this is a variable. */
|
/* These are definitive indicators that this is a variable. */
|
else if (gfc_peek_ascii_char () != '(' || sym->ts.type != BT_UNKNOWN
|
else if (gfc_peek_ascii_char () != '(' || sym->ts.type != BT_UNKNOWN
|
|| sym->attr.pointer || sym->as != NULL)
|
|| sym->attr.pointer || sym->as != NULL)
|
flavor = FL_VARIABLE;
|
flavor = FL_VARIABLE;
|
|
|
if (flavor != FL_UNKNOWN
|
if (flavor != FL_UNKNOWN
|
&& gfc_add_flavor (&sym->attr, flavor, sym->name, NULL) == FAILURE)
|
&& gfc_add_flavor (&sym->attr, flavor, sym->name, NULL) == FAILURE)
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
}
|
}
|
break;
|
break;
|
|
|
case FL_PARAMETER:
|
case FL_PARAMETER:
|
if (equiv_flag)
|
if (equiv_flag)
|
gfc_error ("Named constant at %C in an EQUIVALENCE");
|
gfc_error ("Named constant at %C in an EQUIVALENCE");
|
else
|
else
|
gfc_error ("Cannot assign to a named constant at %C");
|
gfc_error ("Cannot assign to a named constant at %C");
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
break;
|
break;
|
|
|
case FL_PROCEDURE:
|
case FL_PROCEDURE:
|
/* Check for a nonrecursive function result variable. */
|
/* Check for a nonrecursive function result variable. */
|
if (sym->attr.function
|
if (sym->attr.function
|
&& !sym->attr.external
|
&& !sym->attr.external
|
&& sym->result == sym
|
&& sym->result == sym
|
&& (gfc_is_function_return_value (sym, gfc_current_ns)
|
&& (gfc_is_function_return_value (sym, gfc_current_ns)
|
|| (sym->attr.entry
|
|| (sym->attr.entry
|
&& sym->ns == gfc_current_ns)
|
&& sym->ns == gfc_current_ns)
|
|| (sym->attr.entry
|
|| (sym->attr.entry
|
&& sym->ns == gfc_current_ns->parent)))
|
&& sym->ns == gfc_current_ns->parent)))
|
{
|
{
|
/* If a function result is a derived type, then the derived
|
/* If a function result is a derived type, then the derived
|
type may still have to be resolved. */
|
type may still have to be resolved. */
|
|
|
if (sym->ts.type == BT_DERIVED
|
if (sym->ts.type == BT_DERIVED
|
&& gfc_use_derived (sym->ts.u.derived) == NULL)
|
&& gfc_use_derived (sym->ts.u.derived) == NULL)
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
break;
|
break;
|
}
|
}
|
|
|
if (sym->attr.proc_pointer
|
if (sym->attr.proc_pointer
|
|| replace_hidden_procptr_result (&sym, &st) == SUCCESS)
|
|| replace_hidden_procptr_result (&sym, &st) == SUCCESS)
|
break;
|
break;
|
|
|
/* Fall through to error */
|
/* Fall through to error */
|
|
|
default:
|
default:
|
gfc_error ("'%s' at %C is not a variable", sym->name);
|
gfc_error ("'%s' at %C is not a variable", sym->name);
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
}
|
}
|
|
|
/* Special case for derived type variables that get their types
|
/* Special case for derived type variables that get their types
|
via an IMPLICIT statement. This can't wait for the
|
via an IMPLICIT statement. This can't wait for the
|
resolution phase. */
|
resolution phase. */
|
|
|
{
|
{
|
gfc_namespace * implicit_ns;
|
gfc_namespace * implicit_ns;
|
|
|
if (gfc_current_ns->proc_name == sym)
|
if (gfc_current_ns->proc_name == sym)
|
implicit_ns = gfc_current_ns;
|
implicit_ns = gfc_current_ns;
|
else
|
else
|
implicit_ns = sym->ns;
|
implicit_ns = sym->ns;
|
|
|
if (gfc_peek_ascii_char () == '%'
|
if (gfc_peek_ascii_char () == '%'
|
&& sym->ts.type == BT_UNKNOWN
|
&& sym->ts.type == BT_UNKNOWN
|
&& gfc_get_default_type (sym->name, implicit_ns)->type == BT_DERIVED)
|
&& gfc_get_default_type (sym->name, implicit_ns)->type == BT_DERIVED)
|
gfc_set_default_type (sym, 0, implicit_ns);
|
gfc_set_default_type (sym, 0, implicit_ns);
|
}
|
}
|
|
|
expr = gfc_get_expr ();
|
expr = gfc_get_expr ();
|
|
|
expr->expr_type = EXPR_VARIABLE;
|
expr->expr_type = EXPR_VARIABLE;
|
expr->symtree = st;
|
expr->symtree = st;
|
expr->ts = sym->ts;
|
expr->ts = sym->ts;
|
expr->where = where;
|
expr->where = where;
|
|
|
/* Now see if we have to do more. */
|
/* Now see if we have to do more. */
|
m = gfc_match_varspec (expr, equiv_flag, false, false);
|
m = gfc_match_varspec (expr, equiv_flag, false, false);
|
if (m != MATCH_YES)
|
if (m != MATCH_YES)
|
{
|
{
|
gfc_free_expr (expr);
|
gfc_free_expr (expr);
|
return m;
|
return m;
|
}
|
}
|
|
|
*result = expr;
|
*result = expr;
|
return MATCH_YES;
|
return MATCH_YES;
|
}
|
}
|
|
|
|
|
match
|
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);
|
return match_variable (result, equiv_flag, 1);
|
}
|
}
|
|
|
|
|
match
|
match
|
gfc_match_equiv_variable (gfc_expr **result)
|
gfc_match_equiv_variable (gfc_expr **result)
|
{
|
{
|
return match_variable (result, 1, 0);
|
return match_variable (result, 1, 0);
|
}
|
}
|
|
|
|
|
