/* Declaration statement matcher
- Copyright (C) 2002, 2004 Free Software Foundation, Inc.
+ Copyright (C) 2002, 2004, 2005 Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING. If not, write to the Free
-Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA. */
+Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
+02110-1301, USA. */
#include "config.h"
+#include "system.h"
#include "gfortran.h"
#include "match.h"
#include "parse.h"
-#include <string.h>
-/* This flag is set if a an old-style length selector is matched
+/* This flag is set if an old-style length selector is matched
during a type-declaration statement. */
static int old_char_selector;
-/* When variables aquire types and attributes from a declaration
+/* When variables acquire types and attributes from a declaration
statement, they get them from the following static variables. The
first part of a declaration sets these variables and the second
part copies these into symbol structures. */
return MATCH_ERROR;
}
-#if 0 // TODO: Find out where to move this message
+#if 0 /* TODO: Find out where to move this message */
if (sym->attr.in_common)
/* See if sym is in the blank common block. */
for (t = &sym->ns->blank_common; t; t = t->common_next)
}
#endif
- if (gfc_add_data (&sym->attr, &new->expr->where) == FAILURE)
+ if (gfc_add_data (&sym->attr, sym->name, &new->expr->where) == FAILURE)
return MATCH_ERROR;
return MATCH_YES;
/* Match the stuff following a DATA statement. If ERROR_FLAG is set,
we are matching a DATA statement and are therefore issuing an error
if we encounter something unexpected, if not, we're trying to match
- an old-style intialization expression of the form INTEGER I /2/. */
+ an old-style initialization expression of the form INTEGER I /2/. */
match
gfc_match_data (void)
}
-/* Special subroutine for finding a symbol. If we're compiling a
- function or subroutine and the parent compilation unit is an
- interface, then check to see if the name we've been given is the
- name of the interface (located in another namespace). If so,
- return that symbol. If not, use gfc_get_symbol(). */
+/* Special subroutine for finding a symbol. Check if the name is found
+ in the current name space. If not, and we're compiling a function or
+ subroutine and the parent compilation unit is an interface, then check
+ to see if the name we've been given is the name of the interface
+ (located in another namespace). */
static int
find_special (const char *name, gfc_symbol ** result)
{
gfc_state_data *s;
+ int i;
+ i = gfc_get_symbol (name, NULL, result);
+ if (i==0)
+ goto end;
+
if (gfc_current_state () != COMP_SUBROUTINE
&& gfc_current_state () != COMP_FUNCTION)
- goto normal;
+ goto end;
s = gfc_state_stack->previous;
if (s == NULL)
- goto normal;
+ goto end;
if (s->state != COMP_INTERFACE)
- goto normal;
+ goto end;
if (s->sym == NULL)
- goto normal; /* Nameless interface */
+ goto end; /* Nameless interface */
if (strcmp (name, s->sym->name) == 0)
{
return 0;
}
-normal:
- return gfc_get_symbol (name, NULL, result);
+end:
+ return i;
}
if (sym->ns->proc_name != NULL
&& sym->ns->proc_name->attr.flavor == FL_MODULE
&& sym->attr.proc != PROC_MODULE
- && gfc_add_procedure (&sym->attr, PROC_MODULE, NULL) == FAILURE)
+ && gfc_add_procedure (&sym->attr, PROC_MODULE,
+ sym->name, NULL) == FAILURE)
rc = 2;
return rc;
symbol_attribute attr;
gfc_symbol *sym;
- if (find_special (name, &sym))
+ /* if (find_special (name, &sym)) */
+ if (gfc_get_symbol (name, NULL, &sym))
return FAILURE;
/* Start updating the symbol table. Add basic type attribute
return SUCCESS;
}
+/* Set character constant to the given length. The constant will be padded or
+ truncated. */
+
+void
+gfc_set_constant_character_len (int len, gfc_expr * expr)
+{
+ char * s;
+ int slen;
+
+ gcc_assert (expr->expr_type == EXPR_CONSTANT);
+ gcc_assert (expr->ts.type == BT_CHARACTER && expr->ts.kind == 1);
+
+ slen = expr->value.character.length;
+ if (len != slen)
+ {
+ s = gfc_getmem (len);
+ memcpy (s, expr->value.character.string, MIN (len, slen));
+ if (len > slen)
+ memset (&s[slen], ' ', len - slen);
+ gfc_free (expr->value.character.string);
+ expr->value.character.string = s;
+ expr->value.character.length = len;
+ }
+}
/* Function called by variable_decl() that adds an initialization
expression to a symbol. */
&& gfc_check_assign_symbol (sym, init) == FAILURE)
return FAILURE;
+ if (sym->ts.type == BT_CHARACTER && sym->ts.cl)
+ {
+ /* Update symbol character length according initializer. */
+ if (sym->ts.cl->length == NULL)
+ {
+ /* If there are multiple CHARACTER variables declared on
+ the same line, we don't want them to share the same
+ length. */
+ sym->ts.cl = gfc_get_charlen ();
+ sym->ts.cl->next = gfc_current_ns->cl_list;
+ gfc_current_ns->cl_list = sym->ts.cl;
+
+ if (init->expr_type == EXPR_CONSTANT)
+ sym->ts.cl->length =
+ gfc_int_expr (init->value.character.length);
+ else if (init->expr_type == EXPR_ARRAY)
+ sym->ts.cl->length = gfc_copy_expr (init->ts.cl->length);
+ }
+ /* Update initializer character length according symbol. */
+ else if (sym->ts.cl->length->expr_type == EXPR_CONSTANT)
+ {
+ int len = mpz_get_si (sym->ts.cl->length->value.integer);
+ gfc_constructor * p;
+
+ if (init->expr_type == EXPR_CONSTANT)
+ gfc_set_constant_character_len (len, init);
+ else if (init->expr_type == EXPR_ARRAY)
+ {
+ gfc_free_expr (init->ts.cl->length);
+ init->ts.cl->length = gfc_copy_expr (sym->ts.cl->length);
+ for (p = init->value.constructor; p; p = p->next)
+ gfc_set_constant_character_len (len, p->expr);
+ }
+ }
+ }
+
/* Add initializer. Make sure we keep the ranks sane. */
if (sym->attr.dimension && init->rank == 0)
init->rank = sym->as->rank;
gfc_intrinsic_symbol (sym);
if (sym->attr.proc != PROC_INTRINSIC
- && (gfc_add_procedure (&sym->attr, PROC_INTRINSIC, NULL) == FAILURE
- || gfc_add_function (&sym->attr, NULL) == FAILURE))
+ && (gfc_add_procedure (&sym->attr, PROC_INTRINSIC,
+ sym->name, NULL) == FAILURE
+ || gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE))
return MATCH_ERROR;
e = gfc_get_expr ();
symbol table or the current interface. */
static match
-variable_decl (void)
+variable_decl (int elem)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_expr *initializer, *char_len;
cl->length = char_len;
break;
+ /* Non-constant lengths need to be copied after the first
+ element. */
case MATCH_NO:
- cl = current_ts.cl;
+ if (elem > 1 && current_ts.cl->length
+ && current_ts.cl->length->expr_type != EXPR_CONSTANT)
+ {
+ cl = gfc_get_charlen ();
+ cl->next = gfc_current_ns->cl_list;
+ gfc_current_ns->cl_list = cl;
+ cl->length = gfc_copy_expr (current_ts.cl->length);
+ }
+ else
+ cl = current_ts.cl;
+
break;
case MATCH_ERROR:
/* OK, we've successfully matched the declaration. Now put the
symbol in the current namespace, because it might be used in the
- optional intialization expression for this symbol, e.g. this is
+ optional initialization expression for this symbol, e.g. this is
perfectly legal:
integer, parameter :: i = huge(i)
t = add_init_expr_to_sym (name, &initializer, &var_locus);
else
{
- if (current_ts.type == BT_DERIVED && !initializer)
+ if (current_ts.type == BT_DERIVED && !current_attr.pointer && !initializer)
initializer = gfc_default_initializer (¤t_ts);
t = build_struct (name, cl, &initializer, &as);
}
gfc_clear_ts (ts);
+ if (gfc_match (" byte") == MATCH_YES)
+ {
+ if (gfc_notify_std(GFC_STD_GNU, "Extension: BYTE type at %C")
+ == FAILURE)
+ return MATCH_ERROR;
+
+ if (gfc_validate_kind (BT_INTEGER, 1, true) < 0)
+ {
+ gfc_error ("BYTE type used at %C "
+ "is not available on the target machine");
+ return MATCH_ERROR;
+ }
+
+ ts->type = BT_INTEGER;
+ ts->kind = 1;
+ return MATCH_YES;
+ }
+
if (gfc_match (" integer") == MATCH_YES)
{
ts->type = BT_INTEGER;
}
if (sym->attr.flavor != FL_DERIVED
- && gfc_add_flavor (&sym->attr, FL_DERIVED, NULL) == FAILURE)
+ && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
return MATCH_ERROR;
ts->type = BT_DERIVED;
goto cleanup;
}
+ if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
+ && gfc_current_state () != COMP_MODULE)
+ {
+ if (d == DECL_PRIVATE)
+ attr = "PRIVATE";
+ else
+ attr = "PUBLIC";
+
+ gfc_error ("%s attribute at %L is not allowed outside of a MODULE",
+ attr, &seen_at[d]);
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+
switch (d)
{
case DECL_ALLOCATABLE:
break;
case DECL_DIMENSION:
- t = gfc_add_dimension (¤t_attr, &seen_at[d]);
+ t = gfc_add_dimension (¤t_attr, NULL, &seen_at[d]);
break;
case DECL_EXTERNAL:
break;
case DECL_PARAMETER:
- t = gfc_add_flavor (¤t_attr, FL_PARAMETER, &seen_at[d]);
+ t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, &seen_at[d]);
break;
case DECL_POINTER:
break;
case DECL_PRIVATE:
- t = gfc_add_access (¤t_attr, ACCESS_PRIVATE, &seen_at[d]);
+ t = gfc_add_access (¤t_attr, ACCESS_PRIVATE, NULL,
+ &seen_at[d]);
break;
case DECL_PUBLIC:
- t = gfc_add_access (¤t_attr, ACCESS_PUBLIC, &seen_at[d]);
+ t = gfc_add_access (¤t_attr, ACCESS_PUBLIC, NULL,
+ &seen_at[d]);
break;
case DECL_SAVE:
- t = gfc_add_save (¤t_attr, &seen_at[d]);
+ t = gfc_add_save (¤t_attr, NULL, &seen_at[d]);
break;
case DECL_TARGET:
{
gfc_symbol *sym;
match m;
+ int elem;
m = match_type_spec (¤t_ts, 0);
if (m != MATCH_YES)
if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector)
gfc_match_char (',');
- /* Give the types/attributes to symbols that follow. */
+ /* Give the types/attributes to symbols that follow. Give the element
+ a number so that repeat character length expressions can be copied. */
+ elem = 1;
for (;;)
{
- m = variable_decl ();
+ m = variable_decl (elem++);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_NO)
dummy procedure. We don't apply these attributes to formal
arguments of statement functions. */
if (sym != NULL && !st_flag
- && (gfc_add_dummy (&sym->attr, NULL) == FAILURE
+ && (gfc_add_dummy (&sym->attr, sym->name, NULL) == FAILURE
|| gfc_missing_attr (&sym->attr, NULL) == FAILURE))
{
m = MATCH_ERROR;
if (gfc_get_symbol (name, NULL, &r))
return MATCH_ERROR;
- if (gfc_add_flavor (&r->attr, FL_VARIABLE, NULL) == FAILURE
- || gfc_add_result (&r->attr, NULL) == FAILURE)
+ if (gfc_add_flavor (&r->attr, FL_VARIABLE, r->name, NULL) == FAILURE
+ || gfc_add_result (&r->attr, r->name, NULL) == FAILURE)
return MATCH_ERROR;
*result = r;
/* Make changes to the symbol. */
m = MATCH_ERROR;
- if (gfc_add_function (&sym->attr, NULL) == FAILURE)
+ if (gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
goto cleanup;
if (gfc_missing_attr (&sym->attr, NULL) == FAILURE
return m;
state = gfc_current_state ();
- if (state != COMP_SUBROUTINE
- && state != COMP_FUNCTION)
+ if (state != COMP_SUBROUTINE && state != COMP_FUNCTION)
{
- gfc_error ("ENTRY statement at %C cannot appear within %s",
- gfc_state_name (gfc_current_state ()));
+ switch (state)
+ {
+ case COMP_PROGRAM:
+ gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
+ break;
+ case COMP_MODULE:
+ gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
+ break;
+ case COMP_BLOCK_DATA:
+ gfc_error
+ ("ENTRY statement at %C cannot appear within a BLOCK DATA");
+ break;
+ case COMP_INTERFACE:
+ gfc_error
+ ("ENTRY statement at %C cannot appear within an INTERFACE");
+ break;
+ case COMP_DERIVED:
+ gfc_error
+ ("ENTRY statement at %C cannot appear "
+ "within a DERIVED TYPE block");
+ break;
+ case COMP_IF:
+ gfc_error
+ ("ENTRY statement at %C cannot appear within an IF-THEN block");
+ break;
+ case COMP_DO:
+ gfc_error
+ ("ENTRY statement at %C cannot appear within a DO block");
+ break;
+ case COMP_SELECT:
+ gfc_error
+ ("ENTRY statement at %C cannot appear within a SELECT block");
+ break;
+ case COMP_FORALL:
+ gfc_error
+ ("ENTRY statement at %C cannot appear within a FORALL block");
+ break;
+ case COMP_WHERE:
+ gfc_error
+ ("ENTRY statement at %C cannot appear within a WHERE block");
+ break;
+ case COMP_CONTAINS:
+ gfc_error
+ ("ENTRY statement at %C cannot appear "
+ "within a contained subprogram");
+ break;
+ default:
+ gfc_internal_error ("gfc_match_entry(): Bad state");
+ }
return MATCH_ERROR;
}
if (state == COMP_SUBROUTINE)
{
- /* And entry in a subroutine. */
+ /* An entry in a subroutine. */
m = gfc_match_formal_arglist (entry, 0, 1);
if (m != MATCH_YES)
return MATCH_ERROR;
- if (gfc_add_entry (&entry->attr, NULL) == FAILURE
- || gfc_add_subroutine (&entry->attr, NULL) == FAILURE)
+ if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
+ || gfc_add_subroutine (&entry->attr, entry->name, NULL) == FAILURE)
return MATCH_ERROR;
}
else
{
/* An entry in a function. */
- m = gfc_match_formal_arglist (entry, 0, 0);
+ m = gfc_match_formal_arglist (entry, 0, 1);
if (m != MATCH_YES)
return MATCH_ERROR;
if (gfc_match_eos () == MATCH_YES)
{
- if (gfc_add_entry (&entry->attr, NULL) == FAILURE
- || gfc_add_function (&entry->attr, NULL) == FAILURE)
+ if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
+ || gfc_add_function (&entry->attr, entry->name, NULL) == FAILURE)
return MATCH_ERROR;
- entry->result = proc->result;
-
+ entry->result = entry;
}
else
{
if (m != MATCH_YES)
return MATCH_ERROR;
- if (gfc_add_result (&result->attr, NULL) == FAILURE
- || gfc_add_entry (&entry->attr, NULL) == FAILURE
- || gfc_add_function (&entry->attr, NULL) == FAILURE)
+ if (gfc_add_result (&result->attr, result->name, NULL) == FAILURE
+ || gfc_add_entry (&entry->attr, result->name, NULL) == FAILURE
+ || gfc_add_function (&entry->attr, result->name,
+ NULL) == FAILURE)
return MATCH_ERROR;
+
+ entry->result = result;
}
if (proc->attr.recursive && result == NULL)
return MATCH_ERROR;
gfc_new_block = sym;
- if (gfc_add_subroutine (&sym->attr, NULL) == FAILURE)
+ if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
return MATCH_ERROR;
if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES)
if ((current_attr.external || current_attr.intrinsic)
&& sym->attr.flavor != FL_PROCEDURE
- && gfc_add_flavor (&sym->attr, FL_PROCEDURE, NULL) == FAILURE)
+ && gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL) == FAILURE)
{
m = MATCH_ERROR;
goto cleanup;
{
gfc_clear_attr (¤t_attr);
- gfc_add_dimension (¤t_attr, NULL);
+ gfc_add_dimension (¤t_attr, NULL, NULL);
return attr_decl ();
}
if (gfc_add_access (&sym->attr,
(st ==
ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE,
- NULL) == FAILURE)
+ sym->name, NULL) == FAILURE)
return MATCH_ERROR;
break;
}
if (gfc_check_assign_symbol (sym, init) == FAILURE
- || gfc_add_flavor (&sym->attr, FL_PARAMETER, NULL) == FAILURE)
+ || gfc_add_flavor (&sym->attr, FL_PARAMETER, sym->name, NULL) == FAILURE)
{
m = MATCH_ERROR;
goto cleanup;
}
+ if (sym->ts.type == BT_CHARACTER
+ && sym->ts.cl != NULL
+ && sym->ts.cl->length != NULL
+ && sym->ts.cl->length->expr_type == EXPR_CONSTANT
+ && init->expr_type == EXPR_CONSTANT
+ && init->ts.type == BT_CHARACTER
+ && init->ts.kind == 1)
+ gfc_set_constant_character_len (
+ mpz_get_si (sym->ts.cl->length->value.integer), init);
+
sym->value = init;
return MATCH_YES;
switch (m)
{
case MATCH_YES:
- if (gfc_add_save (&sym->attr, &gfc_current_locus) == FAILURE)
+ if (gfc_add_save (&sym->attr, sym->name,
+ &gfc_current_locus) == FAILURE)
return MATCH_ERROR;
goto next_item;
/* Match a module procedure statement. Note that we have to modify
symbols in the parent's namespace because the current one was there
- to receive symbols that are in a interface's formal argument list. */
+ to receive symbols that are in an interface's formal argument list. */
match
gfc_match_modproc (void)
return MATCH_ERROR;
if (sym->attr.proc != PROC_MODULE
- && gfc_add_procedure (&sym->attr, PROC_MODULE, NULL) == FAILURE)
+ && gfc_add_procedure (&sym->attr, PROC_MODULE,
+ sym->name, NULL) == FAILURE)
return MATCH_ERROR;
if (gfc_add_interface (sym) == FAILURE)
return MATCH_ERROR;
}
- if (gfc_add_access (&attr, ACCESS_PRIVATE, NULL) == FAILURE)
+ if (gfc_add_access (&attr, ACCESS_PRIVATE, NULL, NULL) == FAILURE)
return MATCH_ERROR;
goto loop;
}
return MATCH_ERROR;
}
- if (gfc_add_access (&attr, ACCESS_PUBLIC, NULL) == FAILURE)
+ if (gfc_add_access (&attr, ACCESS_PUBLIC, NULL, NULL) == FAILURE)
return MATCH_ERROR;
goto loop;
}
derived type that is a pointer. The first part of the AND clause
is true if a the symbol is not the return value of a function. */
if (sym->attr.flavor != FL_DERIVED
- && gfc_add_flavor (&sym->attr, FL_DERIVED, NULL) == FAILURE)
+ && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
return MATCH_ERROR;
if (sym->components != NULL)
}
if (attr.access != ACCESS_UNKNOWN
- && gfc_add_access (&sym->attr, attr.access, NULL) == FAILURE)
+ && gfc_add_access (&sym->attr, attr.access, sym->name, NULL) == FAILURE)
return MATCH_ERROR;
gfc_new_block = sym;