summaryrefslogtreecommitdiff
path: root/gcc/fortran/decl.c
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/fortran/decl.c')
-rw-r--r--gcc/fortran/decl.c240
1 files changed, 175 insertions, 65 deletions
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index d23a32946ef..12497808a4e 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -231,21 +231,21 @@ syntax:
variable-iterator list. */
static match
-var_element (gfc_data_variable *new)
+var_element (gfc_data_variable *new_var)
{
match m;
gfc_symbol *sym;
- memset (new, 0, sizeof (gfc_data_variable));
+ memset (new_var, 0, sizeof (gfc_data_variable));
if (gfc_match_char ('(') == MATCH_YES)
- return var_list (new);
+ return var_list (new_var);
- m = gfc_match_variable (&new->expr, 0);
+ m = gfc_match_variable (&new_var->expr, 0);
if (m != MATCH_YES)
return m;
- sym = new->expr->symtree->n.sym;
+ sym = new_var->expr->symtree->n.sym;
if (!sym->attr.function && gfc_current_ns->parent
&& gfc_current_ns->parent == sym->ns)
@@ -262,7 +262,7 @@ var_element (gfc_data_variable *new)
sym->name) == FAILURE)
return MATCH_ERROR;
- if (gfc_add_data (&sym->attr, sym->name, &new->expr->where) == FAILURE)
+ if (gfc_add_data (&sym->attr, sym->name, &new_var->expr->where) == FAILURE)
return MATCH_ERROR;
return MATCH_YES;
@@ -274,7 +274,7 @@ var_element (gfc_data_variable *new)
static match
top_var_list (gfc_data *d)
{
- gfc_data_variable var, *tail, *new;
+ gfc_data_variable var, *tail, *new_var;
match m;
tail = NULL;
@@ -287,15 +287,15 @@ top_var_list (gfc_data *d)
if (m == MATCH_ERROR)
return MATCH_ERROR;
- new = gfc_get_data_variable ();
- *new = var;
+ new_var = gfc_get_data_variable ();
+ *new_var = var;
if (tail == NULL)
- d->var = new;
+ d->var = new_var;
else
- tail->next = new;
+ tail->next = new_var;
- tail = new;
+ tail = new_var;
if (gfc_match_char ('/') == MATCH_YES)
break;
@@ -367,7 +367,7 @@ match_data_constant (gfc_expr **result)
return MATCH_ERROR;
}
else if (sym->attr.flavor == FL_DERIVED)
- return gfc_match_structure_constructor (sym, result);
+ return gfc_match_structure_constructor (sym, result, false);
/* Check to see if the value is an initialization array expression. */
if (sym->value->expr_type == EXPR_ARRAY)
@@ -404,7 +404,7 @@ match_data_constant (gfc_expr **result)
static match
top_val_list (gfc_data *data)
{
- gfc_data_value *new, *tail;
+ gfc_data_value *new_val, *tail;
gfc_expr *expr;
match m;
@@ -418,15 +418,15 @@ top_val_list (gfc_data *data)
if (m == MATCH_ERROR)
return MATCH_ERROR;
- new = gfc_get_data_value ();
- mpz_init (new->repeat);
+ new_val = gfc_get_data_value ();
+ mpz_init (new_val->repeat);
if (tail == NULL)
- data->value = new;
+ data->value = new_val;
else
- tail->next = new;
+ tail->next = new_val;
- tail = new;
+ tail = new_val;
if (expr->ts.type != BT_INTEGER || gfc_match_char ('*') != MATCH_YES)
{
@@ -518,26 +518,26 @@ match_old_style_init (const char *name)
match
gfc_match_data (void)
{
- gfc_data *new;
+ gfc_data *new_data;
match m;
set_in_match_data (true);
for (;;)
{
- new = gfc_get_data ();
- new->where = gfc_current_locus;
+ new_data = gfc_get_data ();
+ new_data->where = gfc_current_locus;
- m = top_var_list (new);
+ m = top_var_list (new_data);
if (m != MATCH_YES)
goto cleanup;
- m = top_val_list (new);
+ m = top_val_list (new_data);
if (m != MATCH_YES)
goto cleanup;
- new->next = gfc_current_ns->data;
- gfc_current_ns->data = new;
+ new_data->next = gfc_current_ns->data;
+ gfc_current_ns->data = new_data;
if (gfc_match_eos () == MATCH_YES)
break;
@@ -557,7 +557,7 @@ gfc_match_data (void)
cleanup:
set_in_match_data (false);
- gfc_free_data (new);
+ gfc_free_data (new_data);
return MATCH_ERROR;
}
@@ -762,7 +762,7 @@ get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry)
(*result)->ts = sym->ts;
/* Put the symbol in the procedure namespace so that, should
- the ENTRY preceed its specification, the specification
+ the ENTRY precede its specification, the specification
can be applied. */
(*result)->ns = gfc_current_ns;
@@ -781,7 +781,7 @@ get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry)
sym = *result;
gfc_current_ns->refs++;
- if (sym && !sym->new && gfc_current_state () != COMP_INTERFACE)
+ if (sym && !sym->gfc_new && gfc_current_state () != COMP_INTERFACE)
{
/* Trap another encompassed procedure with the same name. All
these conditions are necessary to avoid picking up an entry
@@ -867,11 +867,11 @@ get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry)
the compiler could have automatically handled the varying sizes
across platforms. */
-try
+gfc_try
verify_c_interop_param (gfc_symbol *sym)
{
int is_c_interop = 0;
- try retval = SUCCESS;
+ gfc_try retval = SUCCESS;
/* We check implicitly typed variables in symbol.c:gfc_set_default_type().
Don't repeat the checks here. */
@@ -1009,7 +1009,7 @@ verify_c_interop_param (gfc_symbol *sym)
/* Function called by variable_decl() that adds a name to the symbol table. */
-static try
+static gfc_try
build_sym (const char *name, gfc_charlen *cl,
gfc_array_spec **as, locus *var_locus)
{
@@ -1185,7 +1185,7 @@ gfc_free_enum_history (void)
/* Function called by variable_decl() that adds an initialization
expression to a symbol. */
-static try
+static gfc_try
add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus)
{
symbol_attribute attr;
@@ -1362,7 +1362,7 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus)
/* Function called by variable_decl() that adds a name to a structure
being built. */
-static try
+static gfc_try
build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
gfc_array_spec **as)
{
@@ -1548,7 +1548,7 @@ variable_decl (int elem)
gfc_charlen *cl;
locus var_locus;
match m;
- try t;
+ gfc_try t;
gfc_symbol *sym;
locus old_locus;
@@ -2786,7 +2786,7 @@ match_attr_spec (void)
decl_types d;
const char *attr;
match m;
- try t;
+ gfc_try t;
gfc_clear_attr (&current_attr);
start = gfc_current_locus;
@@ -3248,7 +3248,7 @@ cleanup:
(J3/04-007, section 15.4.1). If a binding label was given and
there is more than one argument (num_idents), it is an error. */
-try
+gfc_try
set_binding_label (char *dest_label, const char *sym_name, int num_idents)
{
if (num_idents > 1 && has_name_equals)
@@ -3288,10 +3288,10 @@ set_com_block_bind_c (gfc_common_head *com_block, int is_bind_c)
/* Verify that the given gfc_typespec is for a C interoperable type. */
-try
+gfc_try
verify_c_interop (gfc_typespec *ts, const char *name, locus *where)
{
- try t;
+ gfc_try t;
/* Make sure the kind used is appropriate for the type.
The f90_type is unknown if an integer constant was
@@ -3326,11 +3326,11 @@ verify_c_interop (gfc_typespec *ts, const char *name, locus *where)
interoperable type. Errors will be reported here, if
encountered. */
-try
+gfc_try
verify_com_block_vars_c_interop (gfc_common_head *com_block)
{
gfc_symbol *curr_sym = NULL;
- try retval = SUCCESS;
+ gfc_try retval = SUCCESS;
curr_sym = com_block->head;
@@ -3354,11 +3354,11 @@ verify_com_block_vars_c_interop (gfc_common_head *com_block)
/* Verify that a given BIND(C) symbol is C interoperable. If it is not,
an appropriate error message is reported. */
-try
+gfc_try
verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts,
int is_in_common, gfc_common_head *com_block)
{
- try retval = SUCCESS;
+ gfc_try retval = SUCCESS;
if (tmp_sym->attr.function && tmp_sym->result != NULL)
{
@@ -3478,10 +3478,10 @@ verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts,
the type is C interoperable. Errors are reported by the functions
used to set/test these fields. */
-try
+gfc_try
set_verify_bind_c_sym (gfc_symbol *tmp_sym, int num_idents)
{
- try retval = SUCCESS;
+ gfc_try retval = SUCCESS;
/* TODO: Do we need to make sure the vars aren't marked private? */
@@ -3499,10 +3499,10 @@ set_verify_bind_c_sym (gfc_symbol *tmp_sym, int num_idents)
/* Set the fields marking the given common block as BIND(C), including
a binding label, and report any errors encountered. */
-try
+gfc_try
set_verify_bind_c_com_block (gfc_common_head *com_block, int num_idents)
{
- try retval = SUCCESS;
+ gfc_try retval = SUCCESS;
/* destLabel, common name, typespec (which may have binding label). */
if (set_binding_label (com_block->binding_label, com_block->name, num_idents)
@@ -3519,7 +3519,7 @@ set_verify_bind_c_com_block (gfc_common_head *com_block, int num_idents)
/* Retrieve the list of one or more identifiers that the given bind(c)
attribute applies to. */
-try
+gfc_try
get_bind_c_idents (void)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
@@ -3792,7 +3792,7 @@ loop:
/* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
-static try
+static gfc_try
copy_prefix (symbol_attribute *dest, locus *where)
{
if (current_attr.pure && gfc_add_pure (dest, where) == FAILURE)
@@ -4120,8 +4120,8 @@ match_procedure_decl (void)
/* Handle intrinsic procedures. */
if (!(proc_if->attr.external || proc_if->attr.use_assoc
|| proc_if->attr.if_source == IFSRC_IFBODY)
- && (gfc_intrinsic_name (proc_if->name, 0)
- || gfc_intrinsic_name (proc_if->name, 1)))
+ && (gfc_is_intrinsic (proc_if, 0, gfc_current_locus)
+ || gfc_is_intrinsic (proc_if, 1, gfc_current_locus)))
proc_if->attr.intrinsic = 1;
if (proc_if->attr.intrinsic
&& !gfc_intrinsic_actual_ok (proc_if->name, 0))
@@ -4336,6 +4336,22 @@ gfc_match_procedure (void)
}
+/* Warn if a matched procedure has the same name as an intrinsic; this is
+ simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
+ parser-state-stack to find out whether we're in a module. */
+
+static void
+warn_intrinsic_shadow (const gfc_symbol* sym, bool func)
+{
+ bool in_module;
+
+ in_module = (gfc_state_stack->previous
+ && gfc_state_stack->previous->state == COMP_MODULE);
+
+ gfc_warn_intrinsic_shadow (sym, in_module, func);
+}
+
+
/* Match a function declaration. */
match
@@ -4460,6 +4476,9 @@ gfc_match_function_decl (void)
sym->result = result;
}
+ /* Warn if this procedure has the same name as an intrinsic. */
+ warn_intrinsic_shadow (sym, true);
+
return MATCH_YES;
}
@@ -4842,6 +4861,9 @@ gfc_match_subroutine (void)
if (copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
return MATCH_ERROR;
+ /* Warn if it has the same name as an intrinsic. */
+ warn_intrinsic_shadow (sym, false);
+
return MATCH_YES;
}
@@ -5630,7 +5652,7 @@ access_attr_decl (gfc_statement st)
interface_type type;
gfc_user_op *uop;
gfc_symbol *sym;
- gfc_intrinsic_op operator;
+ gfc_intrinsic_op op;
match m;
if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
@@ -5638,7 +5660,7 @@ access_attr_decl (gfc_statement st)
for (;;)
{
- m = gfc_match_generic_spec (&type, name, &operator);
+ m = gfc_match_generic_spec (&type, name, &op);
if (m == MATCH_NO)
goto syntax;
if (m == MATCH_ERROR)
@@ -5662,15 +5684,15 @@ access_attr_decl (gfc_statement st)
break;
case INTERFACE_INTRINSIC_OP:
- if (gfc_current_ns->operator_access[operator] == ACCESS_UNKNOWN)
+ if (gfc_current_ns->operator_access[op] == ACCESS_UNKNOWN)
{
- gfc_current_ns->operator_access[operator] =
+ gfc_current_ns->operator_access[op] =
(st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
}
else
{
gfc_error ("Access specification of the %s operator at %C has "
- "already been specified", gfc_op2string (operator));
+ "already been specified", gfc_op2string (op));
goto done;
}
@@ -5770,7 +5792,7 @@ syntax:
/* The PRIVATE statement is a bit weird in that it can be an attribute
- declaration, but also works as a standlone statement inside of a
+ declaration, but also works as a standalone statement inside of a
type declaration or a module. */
match
@@ -6228,6 +6250,49 @@ syntax:
}
+/* Check a derived type that is being extended. */
+static gfc_symbol*
+check_extended_derived_type (char *name)
+{
+ gfc_symbol *extended;
+
+ if (gfc_find_symbol (name, gfc_current_ns, 1, &extended))
+ {
+ gfc_error ("Ambiguous symbol in TYPE definition at %C");
+ return NULL;
+ }
+
+ if (!extended)
+ {
+ gfc_error ("No such symbol in TYPE definition at %C");
+ return NULL;
+ }
+
+ if (extended->attr.flavor != FL_DERIVED)
+ {
+ gfc_error ("'%s' in EXTENDS expression at %C is not a "
+ "derived type", name);
+ return NULL;
+ }
+
+ if (extended->attr.is_bind_c)
+ {
+ gfc_error ("'%s' cannot be extended at %C because it "
+ "is BIND(C)", extended->name);
+ return NULL;
+ }
+
+ if (extended->attr.sequence)
+ {
+ gfc_error ("'%s' cannot be extended at %C because it "
+ "is a SEQUENCE type", extended->name);
+ return NULL;
+ }
+
+ return extended;
+}
+
+
/* Match the optional attribute specifiers for a type declaration.
Return MATCH_ERROR if an error is encountered in one of the handled
attributes (public, private, bind(c)), MATCH_NO if what's found is
@@ -6235,7 +6300,7 @@ syntax:
checking on attribute conflicts needs to be done. */
match
-gfc_get_type_attr_spec (symbol_attribute *attr)
+gfc_get_type_attr_spec (symbol_attribute *attr, char *name)
{
/* See if the derived type is marked as private. */
if (gfc_match (" , private") == MATCH_YES)
@@ -6273,6 +6338,11 @@ gfc_get_type_attr_spec (symbol_attribute *attr)
/* TODO: attr conflicts need to be checked, probably in symbol.c. */
}
+ else if (name && gfc_match(" , extends ( %n )", name) == MATCH_YES)
+ {
+ if (gfc_add_extension (attr, &gfc_current_locus) == FAILURE)
+ return MATCH_ERROR;
+ }
else
return MATCH_NO;
@@ -6289,8 +6359,10 @@ match
gfc_match_derived_decl (void)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
+ char parent[GFC_MAX_SYMBOL_LEN + 1];
symbol_attribute attr;
gfc_symbol *sym;
+ gfc_symbol *extended;
match m;
match is_type_attr_spec = MATCH_NO;
bool seen_attr = false;
@@ -6298,17 +6370,29 @@ gfc_match_derived_decl (void)
if (gfc_current_state () == COMP_DERIVED)
return MATCH_NO;
+ name[0] = '\0';
+ parent[0] = '\0';
gfc_clear_attr (&attr);
+ extended = NULL;
do
{
- is_type_attr_spec = gfc_get_type_attr_spec (&attr);
+ is_type_attr_spec = gfc_get_type_attr_spec (&attr, parent);
if (is_type_attr_spec == MATCH_ERROR)
return MATCH_ERROR;
if (is_type_attr_spec == MATCH_YES)
seen_attr = true;
} while (is_type_attr_spec == MATCH_YES);
+ /* Deal with derived type extensions. The extension attribute has
+ been added to 'attr' but now the parent type must be found and
+ checked. */
+ if (parent[0])
+ extended = check_extended_derived_type (parent);
+
+ if (parent[0] && !extended)
+ return MATCH_ERROR;
+
if (gfc_match (" ::") != MATCH_YES && seen_attr)
{
gfc_error ("Expected :: in TYPE definition at %C");
@@ -6341,7 +6425,7 @@ gfc_match_derived_decl (void)
components. The ways this can happen is via a function
definition, an INTRINSIC statement or a subtype in another
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. */
+ is true if the symbol is not the return value of a function. */
if (sym->attr.flavor != FL_DERIVED
&& gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
return MATCH_ERROR;
@@ -6361,10 +6445,34 @@ gfc_match_derived_decl (void)
if (attr.is_bind_c != 0)
sym->attr.is_bind_c = attr.is_bind_c;
+
/* Construct the f2k_derived namespace if it is not yet there. */
if (!sym->f2k_derived)
sym->f2k_derived = gfc_get_namespace (NULL, 0);
+
+ if (extended && !sym->components)
+ {
+ gfc_component *p;
+ gfc_symtree *st;
+
+ /* Add the extended derived type as the first component. */
+ gfc_add_component (sym, parent, &p);
+ sym->attr.extension = attr.extension;
+ extended->refs++;
+ gfc_set_sym_referenced (extended);
+
+ p->ts.type = BT_DERIVED;
+ p->ts.derived = extended;
+ p->initializer = gfc_default_initializer (&p->ts);
+
+ /* Provide the links between the extended type and its extension. */
+ if (!extended->f2k_derived)
+ extended->f2k_derived = gfc_get_namespace (NULL, 0);
+ st = gfc_new_symtree (&extended->f2k_derived->sym_root, sym->name);
+ st->n.sym = sym;
+ }
+
gfc_new_block = sym;
return MATCH_YES;
@@ -6378,7 +6486,7 @@ gfc_match_derived_decl (void)
is the case. Since there is no bounds-checking for Cray Pointees,
this will be okay. */
-try
+gfc_try
gfc_mod_pointee_as (gfc_array_spec *as)
{
as->cray_pointee = true; /* This will be useful to know later. */
@@ -6432,7 +6540,7 @@ enumerator_decl (void)
gfc_symbol *sym;
locus var_locus;
match m;
- try t;
+ gfc_try t;
locus old_locus;
initializer = NULL;
@@ -6515,7 +6623,7 @@ match
gfc_match_enumerator_def (void)
{
match m;
- try t;
+ gfc_try t;
gfc_clear_ts (&current_ts);
@@ -6575,6 +6683,7 @@ cleanup:
}
+
/* Match a FINAL declaration inside a derived type. */
match
@@ -6655,7 +6764,7 @@ gfc_match_final_decl (void)
/* Check if we already have this symbol in the list, this is an error. */
for (f = gfc_current_block ()->f2k_derived->finalizers; f; f = f->next)
- if (f->procedure == sym)
+ if (f->proc_sym == sym)
{
gfc_error ("'%s' at %C is already defined as FINAL procedure!",
name);
@@ -6666,7 +6775,8 @@ gfc_match_final_decl (void)
gcc_assert (gfc_current_block ()->f2k_derived);
++sym->refs;
f = XCNEW (gfc_finalizer);
- f->procedure = sym;
+ f->proc_sym = sym;
+ f->proc_tree = NULL;
f->where = gfc_current_locus;
f->next = gfc_current_block ()->f2k_derived->finalizers;
gfc_current_block ()->f2k_derived->finalizers = f;
View Lorry Controller Status