/* Perform type resolution on the various stuctures.
- Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation,
- Inc.
+ Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007
+ Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
Software Foundation, 51 Franklin Street, Fifth Floor,Boston, MA
02110-1301, USA. */
-
#include "config.h"
#include "system.h"
#include "flags.h"
#include "gfortran.h"
+#include "obstack.h"
+#include "bitmap.h"
#include "arith.h" /* For gfc_compare_expr(). */
#include "dependency.h"
}
seq_type;
-/* Stack to push the current if we descend into a block during
- resolution. See resolve_branch() and resolve_code(). */
+/* Stack to keep track of the nesting of blocks as we move through the
+ code. See resolve_branch() and resolve_code(). */
typedef struct code_stack
{
- struct gfc_code *head, *current;
+ struct gfc_code *head, *current, *tail;
struct code_stack *prev;
+
+ /* This bitmap keeps track of the targets valid for a branch from
+ inside this block. */
+ bitmap reachable_labels;
}
code_stack;
/* The id of the last entry seen. */
static int current_entry_id;
+/* We use bitmaps to determine if a branch target is valid. */
+static bitmap_obstack labels_obstack;
+
int
gfc_is_formal_arg (void)
{
resort left for untyped names are the IMPLICIT types. */
static void
-resolve_formal_arglist (gfc_symbol * proc)
+resolve_formal_arglist (gfc_symbol *proc)
{
gfc_formal_arglist *f;
gfc_symbol *sym;
if (sym == NULL)
{
- /* Alternate return placeholder. */
+ /* Alternate return placeholder. */
if (gfc_elemental (proc))
gfc_error ("Alternate return specifier in elemental subroutine "
"'%s' at %L is not allowed", proc->name,
&proc->declared_at);
- if (proc->attr.function)
- gfc_error ("Alternate return specifier in function "
- "'%s' at %L is not allowed", proc->name,
- &proc->declared_at);
+ if (proc->attr.function)
+ gfc_error ("Alternate return specifier in function "
+ "'%s' at %L is not allowed", proc->name,
+ &proc->declared_at);
continue;
}
{
if (gfc_pure (proc) && !gfc_pure (sym))
{
- gfc_error
- ("Dummy procedure '%s' of PURE procedure at %L must also "
- "be PURE", sym->name, &sym->declared_at);
+ gfc_error ("Dummy procedure '%s' of PURE procedure at %L must "
+ "also be PURE", sym->name, &sym->declared_at);
continue;
}
if (gfc_elemental (proc))
{
- gfc_error
- ("Dummy procedure at %L not allowed in ELEMENTAL procedure",
- &sym->declared_at);
+ gfc_error ("Dummy procedure at %L not allowed in ELEMENTAL "
+ "procedure", &sym->declared_at);
continue;
}
gfc_resolve_array_spec (sym->as, 0);
/* We can't tell if an array with dimension (:) is assumed or deferred
- shape until we know if it has the pointer or allocatable attributes.
+ shape until we know if it has the pointer or allocatable attributes.
*/
if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
- && !(sym->attr.pointer || sym->attr.allocatable))
- {
- sym->as->type = AS_ASSUMED_SHAPE;
- for (i = 0; i < sym->as->rank; i++)
- sym->as->lower[i] = gfc_int_expr (1);
- }
+ && !(sym->attr.pointer || sym->attr.allocatable))
+ {
+ sym->as->type = AS_ASSUMED_SHAPE;
+ for (i = 0; i < sym->as->rank; i++)
+ sym->as->lower[i] = gfc_int_expr (1);
+ }
if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
- || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
- || sym->attr.optional)
- proc->attr.always_explicit = 1;
+ || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
+ || sym->attr.optional)
+ proc->attr.always_explicit = 1;
/* If the flavor is unknown at this point, it has to be a variable.
- A procedure specification would have already set the type. */
+ A procedure specification would have already set the type. */
if (sym->attr.flavor == FL_UNKNOWN)
gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
if (gfc_pure (proc) && !sym->attr.pointer
- && sym->attr.flavor != FL_PROCEDURE)
+ && sym->attr.flavor != FL_PROCEDURE)
{
if (proc->attr.function && sym->attr.intent != INTENT_IN)
gfc_error ("Argument '%s' of pure function '%s' at %L must be "
{
if (sym->as != NULL)
{
- gfc_error
- ("Argument '%s' of elemental procedure at %L must be scalar",
- sym->name, &sym->declared_at);
+ gfc_error ("Argument '%s' of elemental procedure at %L must "
+ "be scalar", sym->name, &sym->declared_at);
continue;
}
if (sym->attr.pointer)
{
- gfc_error
- ("Argument '%s' of elemental procedure at %L cannot have "
- "the POINTER attribute", sym->name, &sym->declared_at);
+ gfc_error ("Argument '%s' of elemental procedure at %L cannot "
+ "have the POINTER attribute", sym->name,
+ &sym->declared_at);
continue;
}
}
/* Each dummy shall be specified to be scalar. */
if (proc->attr.proc == PROC_ST_FUNCTION)
- {
- if (sym->as != NULL)
- {
- gfc_error
- ("Argument '%s' of statement function at %L must be scalar",
- sym->name, &sym->declared_at);
- continue;
- }
+ {
+ if (sym->as != NULL)
+ {
+ gfc_error ("Argument '%s' of statement function at %L must "
+ "be scalar", sym->name, &sym->declared_at);
+ continue;
+ }
- if (sym->ts.type == BT_CHARACTER)
- {
- gfc_charlen *cl = sym->ts.cl;
- if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
- {
- gfc_error
- ("Character-valued argument '%s' of statement function at "
- "%L must have constant length",
- sym->name, &sym->declared_at);
- continue;
- }
- }
- }
+ if (sym->ts.type == BT_CHARACTER)
+ {
+ gfc_charlen *cl = sym->ts.cl;
+ if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
+ {
+ gfc_error ("Character-valued argument '%s' of statement "
+ "function at %L must have constant length",
+ sym->name, &sym->declared_at);
+ continue;
+ }
+ }
+ }
}
formal_arg_flag = 0;
}
associated with them. */
static void
-find_arglists (gfc_symbol * sym)
+find_arglists (gfc_symbol *sym)
{
-
if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
return;
*/
static void
-resolve_formal_arglists (gfc_namespace * ns)
+resolve_formal_arglists (gfc_namespace *ns)
{
-
if (ns == NULL)
return;
static void
-resolve_contained_fntype (gfc_symbol * sym, gfc_namespace * ns)
+resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
{
try t;
/* If this namespace is not a function, ignore it. */
- if (! sym
- || !(sym->attr.function
- || sym->attr.flavor == FL_VARIABLE))
+ if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE))
return;
/* Try to find out of what the return type is. */
- if (sym->result != NULL)
- sym = sym->result;
-
- if (sym->ts.type == BT_UNKNOWN)
+ if (sym->result->ts.type == BT_UNKNOWN)
{
- t = gfc_set_default_type (sym, 0, ns);
+ t = gfc_set_default_type (sym->result, 0, ns);
- if (t == FAILURE && !sym->attr.untyped)
+ if (t == FAILURE && !sym->result->attr.untyped)
{
- gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
- sym->name, &sym->declared_at); /* FIXME */
- sym->attr.untyped = 1;
+ if (sym->result == sym)
+ gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
+ sym->name, &sym->declared_at);
+ else
+ gfc_error ("Result '%s' of contained function '%s' at %L has "
+ "no IMPLICIT type", sym->result->name, sym->name,
+ &sym->result->declared_at);
+ sym->result->attr.untyped = 1;
}
}
- /*Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character type,
- lists the only ways a character length value of * can be used: dummy arguments
- of procedures, named constants, and function results in external functions.
- Internal function results are not on that list; ergo, not permitted. */
+ /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character
+ type, lists the only ways a character length value of * can be used:
+ dummy arguments of procedures, named constants, and function results
+ in external functions. Internal function results are not on that list;
+ ergo, not permitted. */
- if (sym->ts.type == BT_CHARACTER)
+ if (sym->result->ts.type == BT_CHARACTER)
{
- gfc_charlen *cl = sym->ts.cl;
+ gfc_charlen *cl = sym->result->ts.cl;
if (!cl || !cl->length)
gfc_error ("Character-valued internal function '%s' at %L must "
"not be assumed length", sym->name, &sym->declared_at);
symbol into an entry point. */
static void
-resolve_entries (gfc_namespace * ns)
+resolve_entries (gfc_namespace *ns)
{
gfc_namespace *old_ns;
gfc_code *c;
left in their own namespace, to keep prior references linked to
the entry declaration.*/
if (ns->proc_name->attr.function
- && ns->parent
- && ns->parent->proc_name->attr.flavor == FL_MODULE)
+ && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
el->sym->ns = ns;
/* Add an entry statement for it. */
{
sym = el->sym->result;
if (sym->attr.dimension)
- {
- if (el == ns->entries)
- gfc_error
- ("FUNCTION result %s can't be an array in FUNCTION %s at %L",
- sym->name, ns->entries->sym->name, &sym->declared_at);
- else
- gfc_error
- ("ENTRY result %s can't be an array in FUNCTION %s at %L",
- sym->name, ns->entries->sym->name, &sym->declared_at);
- }
+ {
+ if (el == ns->entries)
+ gfc_error ("FUNCTION result %s can't be an array in "
+ "FUNCTION %s at %L", sym->name,
+ ns->entries->sym->name, &sym->declared_at);
+ else
+ gfc_error ("ENTRY result %s can't be an array in "
+ "FUNCTION %s at %L", sym->name,
+ ns->entries->sym->name, &sym->declared_at);
+ }
else if (sym->attr.pointer)
- {
- if (el == ns->entries)
- gfc_error
- ("FUNCTION result %s can't be a POINTER in FUNCTION %s at %L",
- sym->name, ns->entries->sym->name, &sym->declared_at);
- else
- gfc_error
- ("ENTRY result %s can't be a POINTER in FUNCTION %s at %L",
- sym->name, ns->entries->sym->name, &sym->declared_at);
- }
+ {
+ if (el == ns->entries)
+ gfc_error ("FUNCTION result %s can't be a POINTER in "
+ "FUNCTION %s at %L", sym->name,
+ ns->entries->sym->name, &sym->declared_at);
+ else
+ gfc_error ("ENTRY result %s can't be a POINTER in "
+ "FUNCTION %s at %L", sym->name,
+ ns->entries->sym->name, &sym->declared_at);
+ }
else
{
ts = &sym->ts;
break;
}
if (sym)
- {
- if (el == ns->entries)
- gfc_error
- ("FUNCTION result %s can't be of type %s in FUNCTION %s at %L",
- sym->name, gfc_typename (ts), ns->entries->sym->name,
- &sym->declared_at);
- else
- gfc_error
- ("ENTRY result %s can't be of type %s in FUNCTION %s at %L",
- sym->name, gfc_typename (ts), ns->entries->sym->name,
- &sym->declared_at);
- }
+ {
+ if (el == ns->entries)
+ gfc_error ("FUNCTION result %s can't be of type %s "
+ "in FUNCTION %s at %L", sym->name,
+ gfc_typename (ts), ns->entries->sym->name,
+ &sym->declared_at);
+ else
+ gfc_error ("ENTRY result %s can't be of type %s "
+ "in FUNCTION %s at %L", sym->name,
+ gfc_typename (ts), ns->entries->sym->name,
+ &sym->declared_at);
+ }
}
}
}
}
+/* Resolve common blocks. */
+static void
+resolve_common_blocks (gfc_symtree *common_root)
+{
+ gfc_symtree *symtree;
+ gfc_symbol *sym;
+
+ if (common_root == NULL)
+ return;
+
+ for (symtree = common_root; symtree->left; symtree = symtree->left);
+
+ for (; symtree; symtree = symtree->right)
+ {
+ gfc_find_symbol (symtree->name, gfc_current_ns, 0, &sym);
+ if (sym == NULL)
+ continue;
+
+ if (sym->attr.flavor == FL_PARAMETER)
+ {
+ gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
+ sym->name, &symtree->n.common->where,
+ &sym->declared_at);
+ }
+
+ if (sym->attr.intrinsic)
+ {
+ gfc_error ("COMMON block '%s' at %L is also an intrinsic "
+ "procedure", sym->name,
+ &symtree->n.common->where);
+ }
+ else if (sym->attr.result
+ ||(sym->attr.function && gfc_current_ns->proc_name == sym))
+ {
+ gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' "
+ "at %L that is also a function result", sym->name,
+ &symtree->n.common->where);
+ }
+ else if (sym->attr.flavor == FL_PROCEDURE
+ && sym->attr.proc != PROC_INTERNAL
+ && sym->attr.proc != PROC_ST_FUNCTION)
+ {
+ gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' "
+ "at %L that is also a global procedure", sym->name,
+ &symtree->n.common->where);
+ }
+ }
+}
+
+
/* Resolve contained function types. Because contained functions can call one
another, they have to be worked out before any of the contained procedures
can be resolved.
in, not in a sibling or parent namespace. */
static void
-resolve_contained_functions (gfc_namespace * ns)
+resolve_contained_functions (gfc_namespace *ns)
{
gfc_namespace *child;
gfc_entry_list *el;
the types are correct. */
static try
-resolve_structure_cons (gfc_expr * expr)
+resolve_structure_cons (gfc_expr *expr)
{
gfc_constructor *cons;
gfc_component *comp;
for (; comp; comp = comp->next, cons = cons->next)
{
- if (! cons->expr)
+ if (!cons->expr)
continue;
if (gfc_resolve_expr (cons->expr) == FAILURE)
}
if (cons->expr->expr_type != EXPR_NULL
- && comp->as && comp->as->rank != cons->expr->rank
- && (comp->allocatable || cons->expr->rank))
+ && comp->as && comp->as->rank != cons->expr->rank
+ && (comp->allocatable || cons->expr->rank))
{
gfc_error ("The rank of the element in the derived type "
"constructor at %L does not match that of the "
}
-
/****************** Expression name resolution ******************/
/* Returns 0 if a symbol was not declared with a type or
attribute declaration statement, nonzero otherwise. */
static int
-was_declared (gfc_symbol * sym)
+was_declared (gfc_symbol *sym)
{
symbol_attribute a;
return 1;
if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
- || a.optional || a.pointer || a.save || a.target || a.volatile_ || a.value
- || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
+ || a.optional || a.pointer || a.save || a.target || a.volatile_
+ || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
return 1;
return 0;
/* Determine if a symbol is generic or not. */
static int
-generic_sym (gfc_symbol * sym)
+generic_sym (gfc_symbol *sym)
{
gfc_symbol *s;
/* Determine if a symbol is specific or not. */
static int
-specific_sym (gfc_symbol * sym)
+specific_sym (gfc_symbol *sym)
{
gfc_symbol *s;
|| sym->attr.proc == PROC_MODULE
|| sym->attr.proc == PROC_INTERNAL
|| sym->attr.proc == PROC_ST_FUNCTION
- || (sym->attr.intrinsic &&
- gfc_specific_intrinsic (sym->name))
+ || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name))
|| sym->attr.external)
return 1;
proc_type;
static proc_type
-procedure_kind (gfc_symbol * sym)
+procedure_kind (gfc_symbol *sym)
{
-
if (generic_sym (sym))
return PTYPE_GENERIC;
static int need_full_assumed_size = 0;
static bool
-check_assumed_size_reference (gfc_symbol * sym, gfc_expr * e)
+check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e)
{
- gfc_ref * ref;
+ gfc_ref *ref;
int dim;
int last = 1;
- if (need_full_assumed_size
- || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
+ if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
return false;
for (ref = e->ref; ref; ref = ref->next)
if (ref->type == REF_ARRAY)
for (dim = 0; dim < ref->u.ar.as->rank; dim++)
- last = (ref->u.ar.end[dim] == NULL) && (ref->u.ar.type == DIMEN_ELEMENT);
+ last = (ref->u.ar.end[dim] == NULL)
+ && (ref->u.ar.type == DIMEN_ELEMENT);
if (last)
{
switch (e->expr_type)
{
case EXPR_VARIABLE:
- if (e->symtree
- && check_assumed_size_reference (e->symtree->n.sym, e))
+ if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e))
return true;
break;
case EXPR_OP:
if (resolve_assumed_size_actual (e->value.op.op1)
- || resolve_assumed_size_actual (e->value.op.op2))
+ || resolve_assumed_size_actual (e->value.op.op2))
return true;
break;
references. */
static try
-resolve_actual_arglist (gfc_actual_arglist * arg, procedure_type ptype)
+resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype)
{
gfc_symbol *sym;
gfc_symtree *parent_st;
{
e = arg->expr;
if (e == NULL)
- {
- /* Check the label is a valid branching target. */
- if (arg->label)
- {
- if (arg->label->defined == ST_LABEL_UNKNOWN)
- {
- gfc_error ("Label %d referenced at %L is never defined",
- arg->label->value, &arg->label->where);
- return FAILURE;
- }
- }
- continue;
- }
+ {
+ /* Check the label is a valid branching target. */
+ if (arg->label)
+ {
+ if (arg->label->defined == ST_LABEL_UNKNOWN)
+ {
+ gfc_error ("Label %d referenced at %L is never defined",
+ arg->label->value, &arg->label->where);
+ return FAILURE;
+ }
+ }
+ continue;
+ }
if (e->ts.type != BT_PROCEDURE)
{
goto argument_list;
}
- /* See if the expression node should really be a variable
- reference. */
+ /* See if the expression node should really be a variable reference. */
sym = e->symtree->n.sym;
/* If a procedure is not already determined to be something else
check if it is intrinsic. */
if (!sym->attr.intrinsic
- && !(sym->attr.external || sym->attr.use_assoc
- || sym->attr.if_source == IFSRC_IFBODY)
- && gfc_intrinsic_name (sym->name, sym->attr.subroutine))
+ && !(sym->attr.external || sym->attr.use_assoc
+ || sym->attr.if_source == IFSRC_IFBODY)
+ && gfc_intrinsic_name (sym->name, sym->attr.subroutine))
sym->attr.intrinsic = 1;
if (sym->attr.proc == PROC_ST_FUNCTION)
"actual argument", sym->name, &e->where);
}
- actual_ok = gfc_intrinsic_actual_ok (sym->name, sym->attr.subroutine);
+ actual_ok = gfc_intrinsic_actual_ok (sym->name,
+ sym->attr.subroutine);
if (sym->attr.intrinsic && actual_ok == 0)
{
gfc_error ("Intrinsic '%s' at %L is not allowed as an "
if (sym->attr.elemental && !sym->attr.intrinsic)
{
gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
- "allowed as an actual argument at %L", sym->name,
+ "allowed as an actual argument at %L", sym->name,
&e->where);
}
+ /* Check if a generic interface has a specific procedure
+ with the same name before emitting an error. */
if (sym->attr.generic)
{
- gfc_error ("GENERIC non-INTRINSIC procedure '%s' is not "
- "allowed as an actual argument at %L", sym->name,
- &e->where);
+ gfc_interface *p;
+ for (p = sym->generic; p; p = p->next)
+ if (strcmp (sym->name, p->sym->name) == 0)
+ {
+ e->symtree = gfc_find_symtree
+ (p->sym->ns->sym_root, sym->name);
+ sym = p->sym;
+ break;
+ }
+
+ if (p == NULL || e->symtree == NULL)
+ gfc_error ("GENERIC non-INTRINSIC procedure '%s' is not "
+ "allowed as an actual argument at %L", sym->name,
+ &e->where);
}
/* If the symbol is the function that names the current (or
/* If all else fails, see if we have a specific intrinsic. */
if (sym->attr.function
- && sym->ts.type == BT_UNKNOWN
- && sym->attr.intrinsic)
+ && sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic)
{
gfc_intrinsic_sym *isym;
isym = gfc_find_function (sym->name);
e->ref->u.ar.as = sym->as;
}
+ /* Expressions are assigned a default ts.type of BT_PROCEDURE in
+ primary.c (match_actual_arg). If above code determines that it
+ is a variable instead, it needs to be resolved as it was not
+ done at the beginning of this function. */
+ if (gfc_resolve_expr (e) != SUCCESS)
+ return FAILURE;
+
argument_list:
/* Check argument list functions %VAL, %LOC and %REF. There is
nothing to do for %REF. */
since same file external procedures are not resolvable
in gfortran, it is a good deal easier to leave them to
intrinsic.c. */
- if (ptype != PROC_UNKNOWN && ptype != PROC_EXTERNAL)
+ if (ptype != PROC_UNKNOWN
+ && ptype != PROC_DUMMY
+ && ptype != PROC_EXTERNAL
+ && ptype != PROC_MODULE)
{
gfc_error ("By-value argument at %L is not allowed "
"in this context", &e->where);
return FAILURE;
}
-
- if (((e->ts.type == BT_REAL || e->ts.type == BT_COMPLEX)
- && e->ts.kind > gfc_default_real_kind)
- || (e->ts.kind > gfc_default_integer_kind))
- {
- gfc_error ("Kind of by-value argument at %L is larger "
- "than default kind", &e->where);
- return FAILURE;
- }
-
}
/* Statement functions have already been excluded above. */
else if (strncmp ("%LOC", arg->name, 4) == 0
- && e->ts.type == BT_PROCEDURE)
+ && e->ts.type == BT_PROCEDURE)
{
if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
{
/* Do the checks of the actual argument list that are specific to elemental
procedures. If called with c == NULL, we have a function, otherwise if
expr == NULL, we have a subroutine. */
+
static try
resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
{
if (expr && expr->value.function.actual != NULL)
{
if (expr->value.function.esym != NULL
- && expr->value.function.esym->attr.elemental)
+ && expr->value.function.esym->attr.elemental)
{
arg0 = expr->value.function.actual;
esym = expr->value.function.esym;
}
else if (expr->value.function.isym != NULL
- && expr->value.function.isym->elemental)
+ && expr->value.function.isym->elemental)
{
arg0 = expr->value.function.actual;
isym = expr->value.function.isym;
else
return SUCCESS;
}
- else if (c && c->ext.actual != NULL
- && c->symtree->n.sym->attr.elemental)
+ else if (c && c->ext.actual != NULL && c->symtree->n.sym->attr.elemental)
{
arg0 = c->ext.actual;
esym = c->symtree->n.sym;
{
rank = arg->expr->rank;
if (arg->expr->expr_type == EXPR_VARIABLE
- && arg->expr->symtree->n.sym->attr.optional)
+ && arg->expr->symtree->n.sym->attr.optional)
set_by_optional = true;
/* Function specific; set the result rank and shape. */
formal_optional = true;
if (pedantic && arg->expr != NULL
- && arg->expr->expr_type == EXPR_VARIABLE
- && arg->expr->symtree->n.sym->attr.optional
- && formal_optional
- && arg->expr->rank
- && (set_by_optional || arg->expr->rank != rank)
- && !(isym && isym->generic_id == GFC_ISYM_CONVERSION))
+ && arg->expr->expr_type == EXPR_VARIABLE
+ && arg->expr->symtree->n.sym->attr.optional
+ && formal_optional
+ && arg->expr->rank
+ && (set_by_optional || arg->expr->rank != rank)
+ && !(isym && isym->id == GFC_ISYM_CONVERSION))
{
gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
"MISSING, it cannot be the actual argument of an "
- "ELEMENTAL procedure unless there is a non-optional"
+ "ELEMENTAL procedure unless there is a non-optional "
"argument with the same rank (12.4.1.5)",
arg->expr->symtree->n.sym->name, &arg->expr->where);
return FAILURE;
if (e != NULL)
{
if (gfc_check_conformance ("elemental subroutine", arg->expr, e)
- == FAILURE)
+ == FAILURE)
return FAILURE;
}
else
function being called, or NULL if not known. */
static void
-find_noncopying_intrinsics (gfc_symbol * fnsym, gfc_actual_arglist * actual)
+find_noncopying_intrinsics (gfc_symbol *fnsym, gfc_actual_arglist *actual)
{
gfc_actual_arglist *ap;
gfc_expr *expr;
ap->expr->inline_noncopying_intrinsic = 1;
}
+
/* This function does the checking of references to global procedures
as defined in sections 18.1 and 14.1, respectively, of the Fortran
77 and 95 standards. It checks for a gsymbol for the name, making
gsym->used = 1;
}
+
/************* Function resolution *************/
/* Resolve a function call known to be generic.
Section 14.1.2.4.1. */
static match
-resolve_generic_f0 (gfc_expr * expr, gfc_symbol * sym)
+resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
{
gfc_symbol *s;
if (sym->attr.generic)
{
- s =
- gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
+ s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
if (s != NULL)
{
expr->value.function.name = s->name;
return MATCH_YES;
}
- /* TODO: Need to search for elemental references in generic interface */
+ /* TODO: Need to search for elemental references in generic
+ interface. */
}
if (sym->attr.intrinsic)
static try
-resolve_generic_f (gfc_expr * expr)
+resolve_generic_f (gfc_expr *expr)
{
gfc_symbol *sym;
match m;
/* Last ditch attempt. See if the reference is to an intrinsic
that possesses a matching interface. 14.1.2.4 */
- if (!gfc_intrinsic_name (sym->name, 0))
+ if (sym && !gfc_intrinsic_name (sym->name, 0))
{
gfc_error ("There is no specific function for the generic '%s' at %L",
expr->symtree->n.sym->name, &expr->where);
if (m == MATCH_YES)
return SUCCESS;
if (m == MATCH_NO)
- gfc_error
- ("Generic function '%s' at %L is not consistent with a specific "
- "intrinsic interface", expr->symtree->n.sym->name, &expr->where);
+ gfc_error ("Generic function '%s' at %L is not consistent with a "
+ "specific intrinsic interface", expr->symtree->n.sym->name,
+ &expr->where);
return FAILURE;
}
/* Resolve a function call known to be specific. */
static match
-resolve_specific_f0 (gfc_symbol * sym, gfc_expr * expr)
+resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr)
{
match m;
if (m == MATCH_YES)
return MATCH_YES;
if (m == MATCH_NO)
- gfc_error
- ("Function '%s' at %L is INTRINSIC but is not compatible with "
- "an intrinsic", sym->name, &expr->where);
+ gfc_error ("Function '%s' at %L is INTRINSIC but is not compatible "
+ "with an intrinsic", sym->name, &expr->where);
return MATCH_ERROR;
}
static try
-resolve_specific_f (gfc_expr * expr)
+resolve_specific_f (gfc_expr *expr)
{
gfc_symbol *sym;
match m;
/* Resolve a procedure call not known to be generic nor specific. */
static try
-resolve_unknown_f (gfc_expr * expr)
+resolve_unknown_f (gfc_expr *expr)
{
gfc_symbol *sym;
gfc_typespec *ts;
}
+/* Return true, if the symbol is an external procedure. */
+static bool
+is_external_proc (gfc_symbol *sym)
+{
+ if (!sym->attr.dummy && !sym->attr.contained
+ && !(sym->attr.intrinsic
+ || gfc_intrinsic_name (sym->name, sym->attr.subroutine))
+ && sym->attr.proc != PROC_ST_FUNCTION
+ && !sym->attr.use_assoc
+ && sym->name)
+ return true;
+ else
+ return false;
+}
+
+
/* Figure out if a function reference is pure or not. Also set the name
of the function for a potential error message. Return nonzero if the
function is PURE, zero if not. */
static int
-pure_function (gfc_expr * e, const char **name)
+pure_function (gfc_expr *e, const char **name)
{
int pure;
+ *name = NULL;
+
if (e->symtree != NULL
&& e->symtree->n.sym != NULL
&& e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
else if (e->value.function.isym)
{
pure = e->value.function.isym->pure
- || e->value.function.isym->elemental;
+ || e->value.function.isym->elemental;
*name = e->value.function.isym->name;
}
else
}
+static try
+is_scalar_expr_ptr (gfc_expr *expr)
+{
+ try retval = SUCCESS;
+ gfc_ref *ref;
+ int start;
+ int end;
+
+ /* See if we have a gfc_ref, which means we have a substring, array
+ reference, or a component. */
+ if (expr->ref != NULL)
+ {
+ ref = expr->ref;
+ while (ref->next != NULL)
+ ref = ref->next;
+
+ switch (ref->type)
+ {
+ case REF_SUBSTRING:
+ if (ref->u.ss.length != NULL
+ && ref->u.ss.length->length != NULL
+ && ref->u.ss.start
+ && ref->u.ss.start->expr_type == EXPR_CONSTANT
+ && ref->u.ss.end
+ && ref->u.ss.end->expr_type == EXPR_CONSTANT)
+ {
+ start = (int) mpz_get_si (ref->u.ss.start->value.integer);
+ end = (int) mpz_get_si (ref->u.ss.end->value.integer);
+ if (end - start + 1 != 1)
+ retval = FAILURE;
+ }
+ else
+ retval = FAILURE;
+ break;
+ case REF_ARRAY:
+ if (ref->u.ar.type == AR_ELEMENT)
+ retval = SUCCESS;
+ else if (ref->u.ar.type == AR_FULL)
+ {
+ /* The user can give a full array if the array is of size 1. */
+ if (ref->u.ar.as != NULL
+ && ref->u.ar.as->rank == 1
+ && ref->u.ar.as->type == AS_EXPLICIT
+ && ref->u.ar.as->lower[0] != NULL
+ && ref->u.ar.as->lower[0]->expr_type == EXPR_CONSTANT
+ && ref->u.ar.as->upper[0] != NULL
+ && ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT)
+ {
+ /* If we have a character string, we need to check if
+ its length is one. */
+ if (expr->ts.type == BT_CHARACTER)
+ {
+ if (expr->ts.cl == NULL
+ || expr->ts.cl->length == NULL
+ || mpz_cmp_si (expr->ts.cl->length->value.integer, 1)
+ != 0)
+ retval = FAILURE;
+ }
+ else
+ {
+ /* We have constant lower and upper bounds. If the
+ difference between is 1, it can be considered a
+ scalar. */
+ start = (int) mpz_get_si
+ (ref->u.ar.as->lower[0]->value.integer);
+ end = (int) mpz_get_si
+ (ref->u.ar.as->upper[0]->value.integer);
+ if (end - start + 1 != 1)
+ retval = FAILURE;
+ }
+ }
+ else
+ retval = FAILURE;
+ }
+ else
+ retval = FAILURE;
+ break;
+ default:
+ retval = SUCCESS;
+ break;
+ }
+ }
+ else if (expr->ts.type == BT_CHARACTER && expr->rank == 0)
+ {
+ /* Character string. Make sure it's of length 1. */
+ if (expr->ts.cl == NULL
+ || expr->ts.cl->length == NULL
+ || mpz_cmp_si (expr->ts.cl->length->value.integer, 1) != 0)
+ retval = FAILURE;
+ }
+ else if (expr->rank != 0)
+ retval = FAILURE;
+
+ return retval;
+}
+
+
+/* Match one of the iso_c_binding functions (c_associated or c_loc)
+ and, in the case of c_associated, set the binding label based on
+ the arguments. */
+
+static try
+gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
+ gfc_symbol **new_sym)
+{
+ char name[GFC_MAX_SYMBOL_LEN + 1];
+ char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
+ int optional_arg = 0;
+ try retval = SUCCESS;
+ gfc_symbol *args_sym;
+
+ if (args->expr->expr_type == EXPR_CONSTANT
+ || args->expr->expr_type == EXPR_OP
+ || args->expr->expr_type == EXPR_NULL)
+ {
+ gfc_error ("Argument to '%s' at %L is not a variable",
+ sym->name, &(args->expr->where));
+ return FAILURE;
+ }
+
+ args_sym = args->expr->symtree->n.sym;
+
+ if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
+ {
+ /* If the user gave two args then they are providing something for
+ the optional arg (the second cptr). Therefore, set the name and
+ binding label to the c_associated for two cptrs. Otherwise,
+ set c_associated to expect one cptr. */
+ if (args->next)
+ {
+ /* two args. */
+ sprintf (name, "%s_2", sym->name);
+ sprintf (binding_label, "%s_2", sym->binding_label);
+ optional_arg = 1;
+ }
+ else
+ {
+ /* one arg. */
+ sprintf (name, "%s_1", sym->name);
+ sprintf (binding_label, "%s_1", sym->binding_label);
+ optional_arg = 0;
+ }
+
+ /* Get a new symbol for the version of c_associated that
+ will get called. */
+ *new_sym = get_iso_c_sym (sym, name, binding_label, optional_arg);
+ }
+ else if (sym->intmod_sym_id == ISOCBINDING_LOC
+ || sym->intmod_sym_id == ISOCBINDING_FUNLOC)
+ {
+ sprintf (name, "%s", sym->name);
+ sprintf (binding_label, "%s", sym->binding_label);
+
+ /* Error check the call. */
+ if (args->next != NULL)
+ {
+ gfc_error_now ("More actual than formal arguments in '%s' "
+ "call at %L", name, &(args->expr->where));
+ retval = FAILURE;
+ }
+ else if (sym->intmod_sym_id == ISOCBINDING_LOC)
+ {
+ /* Make sure we have either the target or pointer attribute. */
+ if (!(args->expr->symtree->n.sym->attr.target)
+ && !(args->expr->symtree->n.sym->attr.pointer))
+ {
+ gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
+ "a TARGET or an associated pointer",
+ args->expr->symtree->n.sym->name,
+ sym->name, &(args->expr->where));
+ retval = FAILURE;
+ }
+
+ /* See if we have interoperable type and type param. */
+ if (verify_c_interop (&(args->expr->symtree->n.sym->ts),
+ args->expr->symtree->n.sym->name,
+ &(args->expr->where)) == SUCCESS
+ || gfc_check_any_c_kind (&(args_sym->ts)) == SUCCESS)
+ {
+ if (args_sym->attr.target == 1)
+ {
+ /* Case 1a, section 15.1.2.5, J3/04-007: variable that
+ has the target attribute and is interoperable. */
+ /* Case 1b, section 15.1.2.5, J3/04-007: allocated
+ allocatable variable that has the TARGET attribute and
+ is not an array of zero size. */
+ if (args_sym->attr.allocatable == 1)
+ {
+ if (args_sym->attr.dimension != 0
+ && (args_sym->as && args_sym->as->rank == 0))
+ {
+ gfc_error_now ("Allocatable variable '%s' used as a "
+ "parameter to '%s' at %L must not be "
+ "an array of zero size",
+ args_sym->name, sym->name,
+ &(args->expr->where));
+ retval = FAILURE;
+ }
+ }
+ else
+ {
+ /* A non-allocatable target variable with C
+ interoperable type and type parameters must be
+ interoperable. */
+ if (args_sym && args_sym->attr.dimension)
+ {
+ if (args_sym->as->type == AS_ASSUMED_SHAPE)
+ {
+ gfc_error ("Assumed-shape array '%s' at %L "
+ "cannot be an argument to the "
+ "procedure '%s' because "
+ "it is not C interoperable",
+ args_sym->name,
+ &(args->expr->where), sym->name);
+ retval = FAILURE;
+ }
+ else if (args_sym->as->type == AS_DEFERRED)
+ {
+ gfc_error ("Deferred-shape array '%s' at %L "
+ "cannot be an argument to the "
+ "procedure '%s' because "
+ "it is not C interoperable",
+ args_sym->name,
+ &(args->expr->where), sym->name);
+ retval = FAILURE;
+ }
+ }
+
+ /* Make sure it's not a character string. Arrays of
+ any type should be ok if the variable is of a C
+ interoperable type. */
+ if (args_sym->ts.type == BT_CHARACTER)
+ if (args_sym->ts.cl != NULL
+ && (args_sym->ts.cl->length == NULL
+ || args_sym->ts.cl->length->expr_type
+ != EXPR_CONSTANT
+ || mpz_cmp_si
+ (args_sym->ts.cl->length->value.integer, 1)
+ != 0)
+ && is_scalar_expr_ptr (args->expr) != SUCCESS)
+ {
+ gfc_error_now ("CHARACTER argument '%s' to '%s' "
+ "at %L must have a length of 1",
+ args_sym->name, sym->name,
+ &(args->expr->where));
+ retval = FAILURE;
+ }
+ }
+ }
+ else if (args_sym->attr.pointer == 1
+ && is_scalar_expr_ptr (args->expr) != SUCCESS)
+ {
+ /* Case 1c, section 15.1.2.5, J3/04-007: an associated
+ scalar pointer. */
+ gfc_error_now ("Argument '%s' to '%s' at %L must be an "
+ "associated scalar POINTER", args_sym->name,
+ sym->name, &(args->expr->where));
+ retval = FAILURE;
+ }
+ }
+ else
+ {
+ /* The parameter is not required to be C interoperable. If it
+ is not C interoperable, it must be a nonpolymorphic scalar
+ with no length type parameters. It still must have either
+ the pointer or target attribute, and it can be
+ allocatable (but must be allocated when c_loc is called). */
+ if (args_sym->attr.dimension != 0
+ && is_scalar_expr_ptr (args->expr) != SUCCESS)
+ {
+ gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
+ "scalar", args_sym->name, sym->name,
+ &(args->expr->where));
+ retval = FAILURE;
+ }
+ else if (args_sym->ts.type == BT_CHARACTER
+ && is_scalar_expr_ptr (args->expr) != SUCCESS)
+ {
+ gfc_error_now ("CHARACTER argument '%s' to '%s' at "
+ "%L must have a length of 1",
+ args_sym->name, sym->name,
+ &(args->expr->where));
+ retval = FAILURE;
+ }
+ }
+ }
+ else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
+ {
+ if (args->expr->symtree->n.sym->attr.flavor != FL_PROCEDURE)
+ {
+ /* TODO: Update this error message to allow for procedure
+ pointers once they are implemented. */
+ gfc_error_now ("Parameter '%s' to '%s' at %L must be a "
+ "procedure",
+ args->expr->symtree->n.sym->name, sym->name,
+ &(args->expr->where));
+ retval = FAILURE;
+ }
+ else if (args->expr->symtree->n.sym->attr.is_c_interop != 1)
+ {
+ gfc_error_now ("Parameter '%s' to '%s' at %L must be C "
+ "interoperable",
+ args->expr->symtree->n.sym->name, sym->name,
+ &(args->expr->where));
+ retval = FAILURE;
+ }
+ }
+
+ /* for c_loc/c_funloc, the new symbol is the same as the old one */
+ *new_sym = sym;
+ }
+ else
+ {
+ gfc_internal_error ("gfc_iso_c_func_interface(): Unhandled "
+ "iso_c_binding function: '%s'!\n", sym->name);
+ }
+
+ return retval;
+}
+
+
/* Resolve a function call, which means resolving the arguments, then figuring
out which entity the name refers to. */
/* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
to INTENT(OUT) or INTENT(INOUT). */
static try
-resolve_function (gfc_expr * expr)
+resolve_function (gfc_expr *expr)
{
gfc_actual_arglist *arg;
- gfc_symbol * sym;
+ gfc_symbol *sym;
const char *name;
try t;
int temp;
if (sym && sym->attr.flavor == FL_VARIABLE)
{
- gfc_error ("'%s' at %L is not a function",
- sym->name, &expr->where);
+ gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
return FAILURE;
}
- /* If the procedure is not internal, a statement function or a module
- procedure,it must be external and should be checked for usage. */
- if (sym && !sym->attr.dummy && !sym->attr.contained
- && sym->attr.proc != PROC_ST_FUNCTION
- && !sym->attr.use_assoc)
+ /* If the procedure is external, check for usage. */
+ if (sym && is_external_proc (sym))
resolve_global_procedure (sym, &expr->where, 0);
/* Switch off assumed size checking and do this again for certain kinds
if (resolve_actual_arglist (expr->value.function.actual, p) == FAILURE)
return FAILURE;
- /* Resume assumed_size checking. */
+ /* Need to setup the call to the correct c_associated, depending on
+ the number of cptrs to user gives to compare. */
+ if (sym && sym->attr.is_iso_c == 1)
+ {
+ if (gfc_iso_c_func_interface (sym, expr->value.function.actual, &sym)
+ == FAILURE)
+ return FAILURE;
+
+ /* Get the symtree for the new symbol (resolved func).
+ the old one will be freed later, when it's no longer used. */
+ gfc_find_sym_tree (sym->name, sym->ns, 1, &(expr->symtree));
+ }
+
+ /* Resume assumed_size checking. */
need_full_assumed_size--;
if (sym && sym->ts.type == BT_CHARACTER
- && sym->ts.cl
- && sym->ts.cl->length == NULL
- && !sym->attr.dummy
- && expr->value.function.esym == NULL
- && !sym->attr.contained)
+ && sym->ts.cl
+ && sym->ts.cl->length == NULL
+ && !sym->attr.dummy
+ && expr->value.function.esym == NULL
+ && !sym->attr.contained)
{
/* Internal procedures are taken care of in resolve_contained_fntype. */
gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
return FAILURE;
}
-/* See if function is already resolved. */
+ /* See if function is already resolved. */
if (expr->value.function.name != NULL)
{
&& expr->value.function.esym
&& ! gfc_elemental (expr->value.function.esym))
{
- gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed"
- " in WORKSHARE construct", expr->value.function.esym->name,
+ gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed "
+ "in WORKSHARE construct", expr->value.function.esym->name,
&expr->where);
t = FAILURE;
}
-#define GENERIC_ID expr->value.function.isym->generic_id
+#define GENERIC_ID expr->value.function.isym->id
else if (expr->value.function.actual != NULL
- && expr->value.function.isym != NULL
- && GENERIC_ID != GFC_ISYM_LBOUND
- && GENERIC_ID != GFC_ISYM_LEN
- && GENERIC_ID != GFC_ISYM_LOC
- && GENERIC_ID != GFC_ISYM_PRESENT)
+ && expr->value.function.isym != NULL
+ && GENERIC_ID != GFC_ISYM_LBOUND
+ && GENERIC_ID != GFC_ISYM_LEN
+ && GENERIC_ID != GFC_ISYM_LOC
+ && GENERIC_ID != GFC_ISYM_PRESENT)
{
/* Array intrinsics must also have the last upper bound of an
assumed size array argument. UBOUND and SIZE have to be
}
if (arg->expr != NULL
- && arg->expr->rank > 0
- && resolve_assumed_size_actual (arg->expr))
+ && arg->expr->rank > 0
+ && resolve_assumed_size_actual (arg->expr))
return FAILURE;
}
}
#undef GENERIC_ID
need_full_assumed_size = temp;
+ name = NULL;
if (!pure_function (expr, &name) && name)
{
if (forall_flag)
{
- gfc_error
- ("reference to non-PURE function '%s' at %L inside a "
- "FORALL %s", name, &expr->where, forall_flag == 2 ?
- "mask" : "block");
+ gfc_error ("reference to non-PURE function '%s' at %L inside a "
+ "FORALL %s", name, &expr->where,
+ forall_flag == 2 ? "mask" : "block");
t = FAILURE;
}
else if (gfc_pure (NULL))
proc = gfc_current_ns->proc_name;
if (esym == proc)
{
- gfc_error ("Function '%s' at %L cannot call itself, as it is not "
- "RECURSIVE", name, &expr->where);
- t = FAILURE;
+ gfc_error ("Function '%s' at %L cannot call itself, as it is not "
+ "RECURSIVE", name, &expr->where);
+ t = FAILURE;
}
if (esym->attr.entry && esym->ns->entries && proc->ns->entries
- && esym->ns->entries->sym == proc->ns->entries->sym)
+ && esym->ns->entries->sym == proc->ns->entries->sym)
{
- gfc_error ("Call to ENTRY '%s' at %L is recursive, but function "
- "'%s' is not declared as RECURSIVE",
- esym->name, &expr->where, esym->ns->entries->sym->name);
- t = FAILURE;
+ gfc_error ("Call to ENTRY '%s' at %L is recursive, but function "
+ "'%s' is not declared as RECURSIVE",
+ esym->name, &expr->where, esym->ns->entries->sym->name);
+ t = FAILURE;
}
}
if (expr->symtree->n.sym->result
&& expr->symtree->n.sym->result->ts.type != BT_UNKNOWN)
expr->ts = expr->symtree->n.sym->result->ts;
- else
- expr->ts = expr->symtree->n.sym->result->ts;
}
return t;
/************* Subroutine resolution *************/
static void
-pure_subroutine (gfc_code * c, gfc_symbol * sym)
+pure_subroutine (gfc_code *c, gfc_symbol *sym)
{
-
if (gfc_pure (sym))
return;
static match
-resolve_generic_s0 (gfc_code * c, gfc_symbol * sym)
+resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
{
gfc_symbol *s;
s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
if (s != NULL)
{
- c->resolved_sym = s;
+ c->resolved_sym = s;
pure_subroutine (c, s);
return MATCH_YES;
}
static try
-resolve_generic_s (gfc_code * c)
+resolve_generic_s (gfc_code *c)
{
gfc_symbol *sym;
match m;
if (!gfc_intrinsic_name (sym->name, 1))
{
- gfc_error
- ("There is no specific subroutine for the generic '%s' at %L",
- sym->name, &c->loc);
+ gfc_error ("There is no specific subroutine for the generic '%s' at %L",
+ sym->name, &c->loc);
return FAILURE;
}
}
+/* Set the name and binding label of the subroutine symbol in the call
+ expression represented by 'c' to include the type and kind of the
+ second parameter. This function is for resolving the appropriate
+ version of c_f_pointer() and c_f_procpointer(). For example, a
+ call to c_f_pointer() for a default integer pointer could have a
+ name of c_f_pointer_i4. If no second arg exists, which is an error
+ for these two functions, it defaults to the generic symbol's name
+ and binding label. */
+
+static void
+set_name_and_label (gfc_code *c, gfc_symbol *sym,
+ char *name, char *binding_label)
+{
+ gfc_expr *arg = NULL;
+ char type;
+ int kind;
+
+ /* The second arg of c_f_pointer and c_f_procpointer determines
+ the type and kind for the procedure name. */
+ arg = c->ext.actual->next->expr;
+
+ if (arg != NULL)
+ {
+ /* Set up the name to have the given symbol's name,
+ plus the type and kind. */
+ /* a derived type is marked with the type letter 'u' */
+ if (arg->ts.type == BT_DERIVED)
+ {
+ type = 'd';
+ kind = 0; /* set the kind as 0 for now */
+ }
+ else
+ {
+ type = gfc_type_letter (arg->ts.type);
+ kind = arg->ts.kind;
+ }
+
+ if (arg->ts.type == BT_CHARACTER)
+ /* Kind info for character strings not needed. */
+ kind = 0;
+
+ sprintf (name, "%s_%c%d", sym->name, type, kind);
+ /* Set up the binding label as the given symbol's label plus
+ the type and kind. */
+ sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
+ }
+ else
+ {
+ /* If the second arg is missing, set the name and label as
+ was, cause it should at least be found, and the missing
+ arg error will be caught by compare_parameters(). */
+ sprintf (name, "%s", sym->name);
+ sprintf (binding_label, "%s", sym->binding_label);
+ }
+
+ return;
+}
+
+
+/* Resolve a generic version of the iso_c_binding procedure given
+ (sym) to the specific one based on the type and kind of the
+ argument(s). Currently, this function resolves c_f_pointer() and
+ c_f_procpointer based on the type and kind of the second argument
+ (FPTR). Other iso_c_binding procedures aren't specially handled.
+ Upon successfully exiting, c->resolved_sym will hold the resolved
+ symbol. Returns MATCH_ERROR if an error occurred; MATCH_YES
+ otherwise. */
+
+match
+gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
+{
+ gfc_symbol *new_sym;
+ /* this is fine, since we know the names won't use the max */
+ char name[GFC_MAX_SYMBOL_LEN + 1];
+ char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
+ /* default to success; will override if find error */
+ match m = MATCH_YES;
+ gfc_symbol *tmp_sym;
+
+ if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
+ (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
+ {
+ set_name_and_label (c, sym, name, binding_label);
+
+ if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
+ {
+ if (c->ext.actual != NULL && c->ext.actual->next != NULL)
+ {
+ /* Make sure we got a third arg. The type/rank of it will
+ be checked later if it's there (gfc_procedure_use()). */
+ if (c->ext.actual->next->expr->rank != 0 &&
+ c->ext.actual->next->next == NULL)
+ {
+ m = MATCH_ERROR;
+ gfc_error ("Missing SHAPE parameter for call to %s "
+ "at %L", sym->name, &(c->loc));
+ }
+ /* Make sure the param is a POINTER. No need to make sure
+ it does not have INTENT(IN) since it is a POINTER. */
+ tmp_sym = c->ext.actual->next->expr->symtree->n.sym;
+ if (tmp_sym != NULL && tmp_sym->attr.pointer != 1)
+ {
+ gfc_error ("Argument '%s' to '%s' at %L "
+ "must have the POINTER attribute",
+ tmp_sym->name, sym->name, &(c->loc));
+ m = MATCH_ERROR;
+ }
+ }
+ }
+
+ if (m != MATCH_ERROR)
+ {
+ /* the 1 means to add the optional arg to formal list */
+ new_sym = get_iso_c_sym (sym, name, binding_label, 1);
+
+ /* Set the kind for the SHAPE array to that of the actual
+ (if given). */
+ if (c->ext.actual != NULL && c->ext.actual->next != NULL
+ && c->ext.actual->next->expr->rank != 0)
+ new_sym->formal->next->next->sym->ts.kind =
+ c->ext.actual->next->next->expr->ts.kind;
+
+ /* for error reporting, say it's declared where the original was */
+ new_sym->declared_at = sym->declared_at;
+ }
+ }
+ else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
+ {
+ /* TODO: Figure out if this is even reacable; this part of the
+ conditional may not be necessary. */
+ int num_args = 0;
+ if (c->ext.actual->next == NULL)
+ {
+ /* The user did not give two args, so resolve to the version
+ of c_associated expecting one arg. */
+ num_args = 1;
+ /* get rid of the second arg */
+ /* TODO!! Should free up the memory here! */
+ sym->formal->next = NULL;
+ }
+ else
+ {
+ num_args = 2;
+ }
+
+ new_sym = sym;
+ sprintf (name, "%s_%d", sym->name, num_args);
+ sprintf (binding_label, "%s_%d", sym->binding_label, num_args);
+ sym->name = gfc_get_string (name);
+ strcpy (sym->binding_label, binding_label);
+ }
+ else
+ {
+ /* no differences for c_loc or c_funloc */
+ new_sym = sym;
+ }
+
+ /* set the resolved symbol */
+ if (m != MATCH_ERROR)
+ {
+ gfc_procedure_use (new_sym, &c->ext.actual, &c->loc);
+ c->resolved_sym = new_sym;
+ }
+ else
+ c->resolved_sym = sym;
+
+ return m;
+}
+
+
/* Resolve a subroutine call known to be specific. */
static match
-resolve_specific_s0 (gfc_code * c, gfc_symbol * sym)
+resolve_specific_s0 (gfc_code *c, gfc_symbol *sym)
{
match m;
+ if(sym->attr.is_iso_c)
+ {
+ m = gfc_iso_c_sub_interface (c,sym);
+ return m;
+ }
+
if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
{
if (sym->attr.dummy)
static try
-resolve_specific_s (gfc_code * c)
+resolve_specific_s (gfc_code *c)
{
gfc_symbol *sym;
match m;
/* Resolve a subroutine call not known to be generic nor specific. */
static try
-resolve_unknown_s (gfc_code * c)
+resolve_unknown_s (gfc_code *c)
{
gfc_symbol *sym;
makes things awkward. */
static try
-resolve_call (gfc_code * c)
+resolve_call (gfc_code *c)
{
try t;
procedure_type ptype = PROC_INTRINSIC;
if (c->symtree && c->symtree->n.sym
- && c->symtree->n.sym->ts.type != BT_UNKNOWN)
+ && c->symtree->n.sym->ts.type != BT_UNKNOWN)
{
gfc_error ("'%s' at %L has a type, which is not consistent with "
"the CALL at %L", c->symtree->n.sym->name,
return FAILURE;
}
- /* If the procedure is not internal or module, it must be external and
- should be checked for usage. */
- if (c->symtree && c->symtree->n.sym
- && !c->symtree->n.sym->attr.dummy
- && !c->symtree->n.sym->attr.contained
- && !c->symtree->n.sym->attr.use_assoc)
+ /* If external, check for usage. */
+ if (c->symtree && is_external_proc (c->symtree->n.sym))
resolve_global_procedure (c->symtree->n.sym, &c->loc, 1);
/* Subroutines without the RECURSIVE attribution are not allowed to
proc = gfc_current_ns->proc_name;
if (csym == proc)
{
- gfc_error ("SUBROUTINE '%s' at %L cannot call itself, as it is not "
- "RECURSIVE", csym->name, &c->loc);
- t = FAILURE;
+ gfc_error ("SUBROUTINE '%s' at %L cannot call itself, as it is not "
+ "RECURSIVE", csym->name, &c->loc);
+ t = FAILURE;
}
if (csym->attr.entry && csym->ns->entries && proc->ns->entries
- && csym->ns->entries->sym == proc->ns->entries->sym)
+ && csym->ns->entries->sym == proc->ns->entries->sym)
{
- gfc_error ("Call to ENTRY '%s' at %L is recursive, but subroutine "
- "'%s' is not declared as RECURSIVE",
- csym->name, &c->loc, csym->ns->entries->sym->name);
- t = FAILURE;
+ gfc_error ("Call to ENTRY '%s' at %L is recursive, but subroutine "
+ "'%s' is not declared as RECURSIVE",
+ csym->name, &c->loc, csym->ns->entries->sym->name);
+ t = FAILURE;
}
}
if (resolve_actual_arglist (c->ext.actual, ptype) == FAILURE)
return FAILURE;
- /* Resume assumed_size checking. */
+ /* Resume assumed_size checking. */
need_full_assumed_size--;
-
t = SUCCESS;
if (c->resolved_sym == NULL)
switch (procedure_kind (c->symtree->n.sym))
return t;
}
+
/* Compare the shapes of two arrays that have non-NULL shapes. If both
op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
match. If both op1->shape and op2->shape are non-NULL return FAILURE
NULL, return SUCCESS. */
static try
-compare_shapes (gfc_expr * op1, gfc_expr * op2)
+compare_shapes (gfc_expr *op1, gfc_expr *op2)
{
try t;
int i;
return t;
}
+
/* Resolve an operator expression node. This can involve replacing the
operation with a user defined function call. */
static try
-resolve_operator (gfc_expr * e)
+resolve_operator (gfc_expr *e)
{
gfc_expr *op1, *op2;
char msg[200];
+ bool dual_locus_error;
try t;
/* Resolve all subnodes-- give them types. */
op1 = e->value.op.op1;
op2 = e->value.op.op2;
+ dual_locus_error = false;
+
+ if ((op1 && op1->expr_type == EXPR_NULL)
+ || (op2 && op2->expr_type == EXPR_NULL))
+ {
+ sprintf (msg, _("Invalid context for NULL() pointer at %%L"));
+ goto bad_op;
+ }
switch (e->value.op.operator)
{
{
e->ts.type = BT_LOGICAL;
e->ts.kind = gfc_kind_max (op1, op2);
- if (op1->ts.kind < e->ts.kind)
- gfc_convert_type (op1, &e->ts, 2);
- else if (op2->ts.kind < e->ts.kind)
- gfc_convert_type (op2, &e->ts, 2);
+ if (op1->ts.kind < e->ts.kind)
+ gfc_convert_type (op1, &e->ts, 2);
+ else if (op2->ts.kind < e->ts.kind)
+ gfc_convert_type (op2, &e->ts, 2);
break;
}
break;
}
- sprintf (msg, _("Operand of .NOT. operator at %%L is %s"),
+ sprintf (msg, _("Operand of .not. operator at %%L is %s"),
gfc_typename (&op1->ts));
goto bad_op;
case INTRINSIC_GT:
+ case INTRINSIC_GT_OS:
case INTRINSIC_GE:
+ case INTRINSIC_GE_OS:
case INTRINSIC_LT:
+ case INTRINSIC_LT_OS:
case INTRINSIC_LE:
+ case INTRINSIC_LE_OS:
if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
{
strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
/* Fall through... */
case INTRINSIC_EQ:
+ case INTRINSIC_EQ_OS:
case INTRINSIC_NE:
+ case INTRINSIC_NE_OS:
if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
{
e->ts.type = BT_LOGICAL;
if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
sprintf (msg,
- _("Logicals at %%L must be compared with %s instead of %s"),
- e->value.op.operator == INTRINSIC_EQ ? ".EQV." : ".NEQV.",
+ _("Logicals at %%L must be compared with %s instead of %s"),
+ e->value.op.operator == INTRINSIC_EQ ? ".eqv." : ".neqv.",
gfc_op2string (e->value.op.operator));
else
sprintf (msg,
- _("Operands of comparison operator '%s' at %%L are %s/%s"),
+ _("Operands of comparison operator '%s' at %%L are %s/%s"),
gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
gfc_typename (&op2->ts));
goto bad_op;
case INTRINSIC_USER:
- if (op2 == NULL)
+ if (e->value.op.uop->operator == NULL)
+ sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
+ else if (op2 == NULL)
sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
e->value.op.uop->name, gfc_typename (&op1->ts));
else
case INTRINSIC_EQV:
case INTRINSIC_NEQV:
case INTRINSIC_EQ:
+ case INTRINSIC_EQ_OS:
case INTRINSIC_NE:
+ case INTRINSIC_NE_OS:
case INTRINSIC_GT:
+ case INTRINSIC_GT_OS:
case INTRINSIC_GE:
+ case INTRINSIC_GE_OS:
case INTRINSIC_LT:
+ case INTRINSIC_LT_OS:
case INTRINSIC_LE:
+ case INTRINSIC_LE_OS:
if (op1->rank == 0 && op2->rank == 0)
e->rank = 0;
}
}
else
- {
- gfc_error ("Inconsistent ranks for operator at %L and %L",
- &op1->where, &op2->where);
- t = FAILURE;
-
- /* Allow higher level expressions to work. */
+ {
+ /* Allow higher level expressions to work. */
e->rank = 0;
+
+ /* Try user-defined operators, and otherwise throw an error. */
+ dual_locus_error = true;
+ sprintf (msg,
+ _("Inconsistent ranks for operator at %%L and %%L"));
+ goto bad_op;
}
}
if (gfc_extend_expr (e) == SUCCESS)
return SUCCESS;
- gfc_error (msg, &e->where);
+ if (dual_locus_error)
+ gfc_error (msg, &op1->where, &op2->where);
+ else
+ gfc_error (msg, &e->where);
return FAILURE;
}
/************** Array resolution subroutines **************/
-
typedef enum
{ CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
comparison;
/* Compare two integer expressions. */
static comparison
-compare_bound (gfc_expr * a, gfc_expr * b)
+compare_bound (gfc_expr *a, gfc_expr *b)
{
int i;
/* Compare an integer expression with an integer. */
static comparison
-compare_bound_int (gfc_expr * a, int b)
+compare_bound_int (gfc_expr *a, int b)
{
int i;
/* Compare an integer expression with a mpz_t. */
static comparison
-compare_bound_mpz_t (gfc_expr * a, mpz_t b)
+compare_bound_mpz_t (gfc_expr *a, mpz_t b)
{
int i;
sequence if empty, and 1 otherwise. */
static int
-compute_last_value_for_triplet (gfc_expr * start, gfc_expr * end,
- gfc_expr * stride, mpz_t last)
+compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end,
+ gfc_expr *stride, mpz_t last)
{
mpz_t rem;
specification. */
static try
-check_dimension (int i, gfc_array_ref * ar, gfc_array_spec * as)
+check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
{
mpz_t last_value;
break;
case AR_SECTION:
- if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
- {
- gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
- return FAILURE;
- }
-
+ {
#define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
#define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
- if (compare_bound (AR_START, AR_END) == CMP_EQ
- && (compare_bound (AR_START, as->lower[i]) == CMP_LT
- || compare_bound (AR_START, as->upper[i]) == CMP_GT))
- goto bound;
+ comparison comp_start_end = compare_bound (AR_START, AR_END);
- if (((compare_bound_int (ar->stride[i], 0) == CMP_GT
- || ar->stride[i] == NULL)
- && compare_bound (AR_START, AR_END) != CMP_GT)
- || (compare_bound_int (ar->stride[i], 0) == CMP_LT
- && compare_bound (AR_START, AR_END) != CMP_LT))
- {
- if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
- goto bound;
- if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
- goto bound;
- }
+ /* Check for zero stride, which is not allowed. */
+ if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
+ {
+ gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
+ return FAILURE;
+ }
- mpz_init (last_value);
- if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
- last_value))
- {
- if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT
- || compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
- {
- mpz_clear (last_value);
+ /* if start == len || (stride > 0 && start < len)
+ || (stride < 0 && start > len),
+ then the array section contains at least one element. In this
+ case, there is an out-of-bounds access if
+ (start < lower || start > upper). */
+ if (compare_bound (AR_START, AR_END) == CMP_EQ
+ || ((compare_bound_int (ar->stride[i], 0) == CMP_GT
+ || ar->stride[i] == NULL) && comp_start_end == CMP_LT)
+ || (compare_bound_int (ar->stride[i], 0) == CMP_LT
+ && comp_start_end == CMP_GT))
+ {
+ if (compare_bound (AR_START, as->lower[i]) == CMP_LT
+ || compare_bound (AR_START, as->upper[i]) == CMP_GT)
goto bound;
- }
- }
- mpz_clear (last_value);
+ }
+
+ /* If we can compute the highest index of the array section,
+ then it also has to be between lower and upper. */
+ mpz_init (last_value);
+ if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
+ last_value))
+ {
+ if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT
+ || compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
+ {
+ mpz_clear (last_value);
+ goto bound;
+ }
+ }
+ mpz_clear (last_value);
#undef AR_START
#undef AR_END
-
+ }
break;
default:
/* Compare an array reference with an array specification. */
static try
-compare_spec_to_ref (gfc_array_ref * ar)
+compare_spec_to_ref (gfc_array_ref *ar)
{
gfc_array_spec *as;
int i;
/* TODO: Full array sections are only allowed as actual parameters. */
if (as->type == AS_ASSUMED_SIZE
&& (/*ar->type == AR_FULL
- ||*/ (ar->type == AR_SECTION
- && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
+ ||*/ (ar->type == AR_SECTION
+ && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
{
- gfc_error ("Rightmost upper bound of assumed size array section"
- " not specified at %L", &ar->where);
+ gfc_error ("Rightmost upper bound of assumed size array section "
+ "not specified at %L", &ar->where);
return FAILURE;
}
/* Resolve one part of an array index. */
try
-gfc_resolve_index (gfc_expr * index, int check_scalar)
+gfc_resolve_index (gfc_expr *index, int check_scalar)
{
gfc_typespec ts;
provide an additional array specification. */
static void
-find_array_spec (gfc_expr * e)
+find_array_spec (gfc_expr *e)
{
gfc_array_spec *as;
gfc_component *c;
/* Resolve an array reference. */
static try
-resolve_array_ref (gfc_array_ref * ar)
+resolve_array_ref (gfc_array_ref *ar)
{
int i, check_scalar;
gfc_expr *e;
case 1:
ar->dimen_type[i] = DIMEN_VECTOR;
if (e->expr_type == EXPR_VARIABLE
- && e->symtree->n.sym->ts.type == BT_DERIVED)
+ && e->symtree->n.sym->ts.type == BT_DERIVED)
ar->start[i] = gfc_get_parentheses (e);
break;
static try
-resolve_substring (gfc_ref * ref)
+resolve_substring (gfc_ref *ref)
{
-
if (ref->u.ss.start != NULL)
{
if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
/* Resolve subtype references. */
static try
-resolve_ref (gfc_expr * expr)
+resolve_ref (gfc_expr *expr)
{
int current_part_dimension, n_components, seen_part_dimension;
gfc_ref *ref;
if (current_part_dimension || seen_part_dimension)
{
if (ref->u.c.component->pointer)
- {
- gfc_error
- ("Component to the right of a part reference with nonzero "
- "rank must not have the POINTER attribute at %L",
- &expr->where);
+ {
+ gfc_error ("Component to the right of a part reference "
+ "with nonzero rank must not have the POINTER "
+ "attribute at %L", &expr->where);
return FAILURE;
}
else if (ref->u.c.component->allocatable)
- {
- gfc_error
- ("Component to the right of a part reference with nonzero "
- "rank must not have the ALLOCATABLE attribute at %L",
- &expr->where);
+ {
+ gfc_error ("Component to the right of a part reference "
+ "with nonzero rank must not have the ALLOCATABLE "
+ "attribute at %L", &expr->where);
return FAILURE;
}
}
if (((ref->type == REF_COMPONENT && n_components > 1)
|| ref->next == NULL)
- && current_part_dimension
+ && current_part_dimension
&& seen_part_dimension)
{
-
gfc_error ("Two or more part references with nonzero rank must "
"not be specified at %L", &expr->where);
return FAILURE;
if (current_part_dimension)
seen_part_dimension = 1;
- /* reset to make sure */
+ /* reset to make sure */
current_part_dimension = 0;
}
}
Leaves the shape array NULL if it is not possible to determine the shape. */
static void
-expression_shape (gfc_expr * e)
+expression_shape (gfc_expr *e)
{
mpz_t array[GFC_MAX_DIMENSIONS];
int i;
examining the base symbol and any reference structures it may have. */
static void
-expression_rank (gfc_expr * e)
+expression_rank (gfc_expr *e)
{
gfc_ref *ref;
int i, rank;
}
e->rank = (e->symtree->n.sym->as == NULL)
- ? 0 : e->symtree->n.sym->as->rank;
+ ? 0 : e->symtree->n.sym->as->rank;
goto done;
}
if (ref->u.ar.type == AR_SECTION)
{
- /* Figure out the rank of the section. */
+ /* Figure out the rank of the section. */
if (rank != 0)
gfc_internal_error ("expression_rank(): Two array specs");
/* Resolve a variable expression. */
static try
-resolve_variable (gfc_expr * e)
+resolve_variable (gfc_expr *e)
{
gfc_symbol *sym;
try t;
/* Deal with forward references to entries during resolve_code, to
satisfy, at least partially, 12.5.2.5. */
if (gfc_current_ns->entries
- && current_entry_id == sym->entry_id
- && cs_base
- && cs_base->current
- && cs_base->current->op != EXEC_ENTRY)
+ && current_entry_id == sym->entry_id
+ && cs_base
+ && cs_base->current
+ && cs_base->current->op != EXEC_ENTRY)
{
gfc_entry_list *entry;
gfc_formal_arglist *formal;
/* Now do the same check on the specification expressions. */
specification_expr = 1;
if (sym->ts.type == BT_CHARACTER
- && gfc_resolve_expr (sym->ts.cl->length) == FAILURE)
+ && gfc_resolve_expr (sym->ts.cl->length) == FAILURE)
t = FAILURE;
if (sym->as)
}
+/* Checks to see that the correct symbol has been host associated.
+ The only situation where this arises is that in which a twice
+ contained function is parsed after the host association is made.
+ Therefore, on detecting this, the line is rematched, having got
+ rid of the existing references and actual_arg_list. */
+static bool
+check_host_association (gfc_expr *e)
+{
+ gfc_symbol *sym, *old_sym;
+ locus temp_locus;
+ gfc_expr *expr;
+ int n;
+ bool retval = e->expr_type == EXPR_FUNCTION;
+
+ if (e->symtree == NULL || e->symtree->n.sym == NULL)
+ return retval;
+
+ old_sym = e->symtree->n.sym;
+
+ if (old_sym->attr.use_assoc)
+ return retval;
+
+ if (gfc_current_ns->parent
+ && gfc_current_ns->parent->parent
+ && old_sym->ns != gfc_current_ns)
+ {
+ gfc_find_symbol (old_sym->name, gfc_current_ns->parent, 1, &sym);
+ if (sym && old_sym != sym && sym->attr.flavor == FL_PROCEDURE)
+ {
+ temp_locus = gfc_current_locus;
+ gfc_current_locus = e->where;
+
+ gfc_buffer_error (1);
+
+ gfc_free_ref_list (e->ref);
+ e->ref = NULL;
+
+ if (retval)
+ {
+ gfc_free_actual_arglist (e->value.function.actual);
+ e->value.function.actual = NULL;
+ }
+
+ if (e->shape != NULL)
+ {
+ for (n = 0; n < e->rank; n++)
+ mpz_clear (e->shape[n]);
+
+ gfc_free (e->shape);
+ }
+
+ gfc_match_rvalue (&expr);
+ gfc_clear_error ();
+ gfc_buffer_error (0);
+
+ gcc_assert (expr && sym == expr->symtree->n.sym);
+
+ *e = *expr;
+ gfc_free (expr);
+ sym->refs++;
+
+ gfc_current_locus = temp_locus;
+ }
+ }
+ /* This might have changed! */
+ return e->expr_type == EXPR_FUNCTION;
+}
+
+
/* Resolve an expression. That is, make sure that types of operands agree
with their operators, intrinsic operators are converted to function calls
for overloaded types and unresolved function references are resolved. */
try
-gfc_resolve_expr (gfc_expr * e)
+gfc_resolve_expr (gfc_expr *e)
{
try t;
break;
case EXPR_FUNCTION:
- t = resolve_function (e);
- break;
-
case EXPR_VARIABLE:
- t = resolve_variable (e);
- if (t == SUCCESS)
- expression_rank (e);
+
+ if (check_host_association (e))
+ t = resolve_function (e);
+ else
+ {
+ t = resolve_variable (e);
+ if (t == SUCCESS)
+ expression_rank (e);
+ }
break;
case EXPR_SUBSTRING:
gfc_expand_constructor (e);
}
- /* This provides the opportunity for the length of constructors with character
- valued function elements to propogate the string length to the expression. */
+ /* This provides the opportunity for the length of constructors with
+ character valued function elements to propagate the string length
+ to the expression. */
if (e->ts.type == BT_CHARACTER)
- gfc_resolve_character_array_constructor (e);
+ gfc_resolve_character_array_constructor (e);
break;
INTEGER or (optionally) REAL type. */
static try
-gfc_resolve_iterator_expr (gfc_expr * expr, bool real_ok,
- const char * name_msgid)
+gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
+ const char *name_msgid)
{
if (gfc_resolve_expr (expr) == FAILURE)
return FAILURE;
return FAILURE;
}
- if (!(expr->ts.type == BT_INTEGER
- || (expr->ts.type == BT_REAL && real_ok)))
+ if (expr->ts.type != BT_INTEGER)
{
- if (real_ok)
- gfc_error ("%s at %L must be INTEGER or REAL", _(name_msgid),
- &expr->where);
+ if (expr->ts.type == BT_REAL)
+ {
+ if (real_ok)
+ return gfc_notify_std (GFC_STD_F95_DEL,
+ "Deleted feature: %s at %L must be integer",
+ _(name_msgid), &expr->where);
+ else
+ {
+ gfc_error ("%s at %L must be INTEGER", _(name_msgid),
+ &expr->where);
+ return FAILURE;
+ }
+ }
else
- gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
- return FAILURE;
+ {
+ gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
+ return FAILURE;
+ }
}
return SUCCESS;
}
false allow only INTEGER type iterators, otherwise allow REAL types. */
try
-gfc_resolve_iterator (gfc_iterator * iter, bool real_ok)
+gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
{
-
- if (iter->var->ts.type == BT_REAL)
- gfc_notify_std (GFC_STD_F95_DEL,
- "Obsolete: REAL DO loop iterator at %L",
- &iter->var->where);
-
if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
== FAILURE)
return FAILURE;
INTEGERs, and if stride is a constant it must be nonzero. */
static void
-resolve_forall_iterators (gfc_forall_iterator * iter)
+resolve_forall_iterators (gfc_forall_iterator *iter)
{
-
while (iter)
{
if (gfc_resolve_expr (iter->var) == SUCCESS
{
if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
gfc_error ("FORALL stride expression at %L must be a scalar %s",
- &iter->stride->where, "INTEGER");
+ &iter->stride->where, "INTEGER");
if (iter->stride->expr_type == EXPR_CONSTANT
&& mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
Returns zero if no pointer components are found, nonzero otherwise. */
static int
-derived_pointer (gfc_symbol * sym)
+derived_pointer (gfc_symbol *sym)
{
gfc_component *c;
for (c = sym->components; c; c = c->next)
{
- if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.derived))
- return 1;
+ if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.derived))
+ return 1;
}
return 0;
a pointer or a full array. */
static try
-resolve_deallocate_expr (gfc_expr * e)
+resolve_deallocate_expr (gfc_expr *e)
{
symbol_attribute attr;
int allocatable, pointer, check_intent_in;
for (ref = e->ref; ref; ref = ref->next)
{
if (pointer)
- check_intent_in = 0;
+ check_intent_in = 0;
switch (ref->type)
- {
- case REF_ARRAY:
+ {
+ case REF_ARRAY:
if (ref->u.ar.type != AR_FULL)
allocatable = 0;
break;
- case REF_COMPONENT:
+ case REF_COMPONENT:
allocatable = (ref->u.c.component->as != NULL
- && ref->u.c.component->as->type == AS_DEFERRED);
+ && ref->u.c.component->as->type == AS_DEFERRED);
pointer = ref->u.c.component->pointer;
break;
- case REF_SUBSTRING:
+ case REF_SUBSTRING:
allocatable = 0;
break;
- }
+ }
}
attr = gfc_expr_attr (e);
&& e->symtree->n.sym->attr.intent == INTENT_IN)
{
gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
- e->symtree->n.sym->name, &e->where);
+ e->symtree->n.sym->name, &e->where);
return FAILURE;
}
return SUCCESS;
}
+
/* Returns true if the expression e contains a reference the symbol sym. */
static bool
find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
case REF_COMPONENT:
if (ref->u.c.component->ts.type == BT_CHARACTER
- && ref->u.c.component->ts.cl->length->expr_type
- != EXPR_CONSTANT)
- rv = rv || find_sym_in_expr (sym, ref->u.c.component->ts.cl->length);
+ && ref->u.c.component->ts.cl->length->expr_type
+ != EXPR_CONSTANT)
+ rv = rv
+ || find_sym_in_expr (sym,
+ ref->u.c.component->ts.cl->length);
if (ref->u.c.component->as)
- for (i = 0; i < ref->u.c.component->as->rank; i++)
+ for (i = 0; i < ref->u.c.component->as->rank; i++)
{
- rv = rv || find_sym_in_expr (sym, ref->u.c.component->as->lower[i]);
- rv = rv || find_sym_in_expr (sym, ref->u.c.component->as->upper[i]);
+ rv = rv
+ || find_sym_in_expr (sym,
+ ref->u.c.component->as->lower[i]);
+ rv = rv
+ || find_sym_in_expr (sym,
+ ref->u.c.component->as->upper[i]);
}
break;
}
components that need nullification.) */
static gfc_expr *
-expr_to_initialize (gfc_expr * e)
+expr_to_initialize (gfc_expr *e)
{
gfc_expr *result;
gfc_ref *ref;
for (ref = result->ref; ref; ref = ref->next)
if (ref->type == REF_ARRAY && ref->next == NULL)
{
- ref->u.ar.type = AR_FULL;
+ ref->u.ar.type = AR_FULL;
- for (i = 0; i < ref->u.ar.dimen; i++)
- ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
+ for (i = 0; i < ref->u.ar.dimen; i++)
+ ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
- result->rank = ref->u.ar.dimen;
- break;
+ result->rank = ref->u.ar.dimen;
+ break;
}
return result;
have a trailing array reference that gives the size of the array. */
static try
-resolve_allocate_expr (gfc_expr * e, gfc_code * code)
+resolve_allocate_expr (gfc_expr *e, gfc_code *code)
{
int i, pointer, allocatable, dimension, check_intent_in;
symbol_attribute attr;
if (e->expr_type != EXPR_VARIABLE)
{
allocatable = 0;
-
attr = gfc_expr_attr (e);
pointer = attr.pointer;
dimension = attr.dimension;
-
}
else
{
}
for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
- {
+ {
if (pointer)
check_intent_in = 0;
switch (ref->type)
{
case REF_ARRAY:
- if (ref->next != NULL)
- pointer = 0;
- break;
+ if (ref->next != NULL)
+ pointer = 0;
+ break;
case REF_COMPONENT:
- allocatable = (ref->u.c.component->as != NULL
- && ref->u.c.component->as->type == AS_DEFERRED);
+ allocatable = (ref->u.c.component->as != NULL
+ && ref->u.c.component->as->type == AS_DEFERRED);
- pointer = ref->u.c.component->pointer;
- dimension = ref->u.c.component->dimension;
- break;
+ pointer = ref->u.c.component->pointer;
+ dimension = ref->u.c.component->dimension;
+ break;
case REF_SUBSTRING:
- allocatable = 0;
- pointer = 0;
- break;
+ allocatable = 0;
+ pointer = 0;
+ break;
}
}
}
&& e->symtree->n.sym->attr.intent == INTENT_IN)
{
gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
- e->symtree->n.sym->name, &e->where);
+ e->symtree->n.sym->name, &e->where);
return FAILURE;
}
/* Add default initializer for those derived types that need them. */
if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts)))
{
- init_st = gfc_get_code ();
- init_st->loc = code->loc;
- init_st->op = EXEC_INIT_ASSIGN;
- init_st->expr = expr_to_initialize (e);
- init_st->expr2 = init_e;
- init_st->next = code->next;
- code->next = init_st;
+ init_st = gfc_get_code ();
+ init_st->loc = code->loc;
+ init_st->op = EXEC_INIT_ASSIGN;
+ init_st->expr = expr_to_initialize (e);
+ init_st->expr2 = init_e;
+ init_st->next = code->next;
+ code->next = init_st;
}
if (pointer && dimension == 0)
There are nine situations to check. */
static int
-compare_cases (const gfc_case * op1, const gfc_case * op2)
+compare_cases (const gfc_case *op1, const gfc_case *op2)
{
int retval;
retval = (gfc_compare_expr (op1->low, op2->high) > 0) ? 1 : 0;
else if (op2->high == NULL) /* op2 = (M:), L < M */
retval = (gfc_compare_expr (op1->high, op2->low) < 0) ? -1 : 0;
- else /* op2 = (M:N) */
- {
+ else /* op2 = (M:N) */
+ {
retval = 0;
- /* L < M */
+ /* L < M */
if (gfc_compare_expr (op1->high, op2->low) < 0)
retval = -1;
- /* K > N */
+ /* K > N */
else if (gfc_compare_expr (op1->low, op2->high) > 0)
retval = 1;
}
overlap, or NULL otherwise. */
static gfc_case *
-check_case_overlap (gfc_case * list)
+check_case_overlap (gfc_case *list)
{
gfc_case *p, *q, *e, *tail;
int insize, nmerges, psize, qsize, cmp, overlap_seen;
nmerges++;
/* Cut the list in two pieces by stepping INSIZE places
- forward in the list, starting from P. */
+ forward in the list, starting from P. */
psize = 0;
q = p;
for (i = 0; i < insize; i++)
/* Now we have two lists. Merge them! */
while (psize > 0 || (qsize > 0 && q != NULL))
{
-
/* See from which the next case to merge comes from. */
if (psize == 0)
{
if (cmp < 0)
{
/* The whole case range for P is less than the
- one for Q. */
+ one for Q. */
e = p;
p = p->right;
psize--;
else if (cmp > 0)
{
/* The whole case range for Q is greater than
- the case range for P. */
+ the case range for P. */
e = q;
q = q->right;
qsize--;
}
/* P has now stepped INSIZE places along, and so has Q. So
- they're the same. */
+ they're the same. */
p = q;
}
tail->right = NULL;
/* If we have done only one merge or none at all, we've
- finished sorting the cases. */
+ finished sorting the cases. */
if (nmerges <= 1)
- {
+ {
if (!overlap_seen)
return list;
else
type. Return FAILURE if anything is wrong. */
static try
-validate_case_label_expr (gfc_expr * e, gfc_expr * case_expr)
+validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
{
if (e == NULL) return SUCCESS;
if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
{
gfc_error("Expression in CASE statement at %L must be kind %d",
- &e->where, case_expr->ts.kind);
+ &e->where, case_expr->ts.kind);
return FAILURE;
}
expression. */
static void
-resolve_select (gfc_code * code)
+resolve_select (gfc_code *code)
{
gfc_code *body;
gfc_expr *case_expr;
{
/* This was actually a computed GOTO statement. */
case_expr = code->expr2;
- if (case_expr->ts.type != BT_INTEGER
- || case_expr->rank != 0)
+ if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0)
gfc_error ("Selection expression in computed GOTO statement "
"at %L must be a scalar integer expression",
&case_expr->where);
seen_unreachable = 0;
/* Walk the case label list, making sure that all case labels
- are legal. */
+ are legal. */
for (cp = body->ext.case_list; cp; cp = cp->next)
{
/* Count the number of cases in the whole construct. */
if (cp->low == NULL && cp->high == NULL)
{
if (default_case != NULL)
- {
+ {
gfc_error ("The DEFAULT CASE at %L cannot be followed "
"by a second DEFAULT CASE at %L",
&default_case->where, &cp->where);
}
/* Deal with single value cases and case ranges. Errors are
- issued from the validation function. */
+ issued from the validation function. */
if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
|| validate_case_label_expr (cp->high, case_expr) != SUCCESS)
{
&& ((cp->low == NULL || cp->high == NULL)
|| cp->low != cp->high))
{
- gfc_error
- ("Logical range in CASE statement at %L is not allowed",
- &cp->low->where);
+ gfc_error ("Logical range in CASE statement at %L is not "
+ "allowed", &cp->low->where);
t = FAILURE;
break;
}
&& gfc_compare_expr (cp->low, cp->high) > 0)
{
if (gfc_option.warn_surprising)
- gfc_warning ("Range specification at %L can never "
+ gfc_warning ("Range specification at %L can never "
"be matched", &cp->where);
cp->unreachable = 1;
double linked list here. We sort that with a merge sort
later on to detect any overlapping cases. */
if (!head)
- {
+ {
head = tail = cp;
head->right = head->left = NULL;
}
else
- {
+ {
tail->right = cp;
tail->right->left = tail;
tail = tail->right;
for (body = code; body && body->block; body = body->block)
{
if (body->block->ext.case_list == NULL)
- {
+ {
/* Cut the unreachable block from the code chain. */
gfc_code *c = body->block;
body->block = c->block;
/* Kill the dead block, but not the blocks below it. */
c->block = NULL;
gfc_free_statements (c);
- }
+ }
}
/* More than two cases is legal but insane for logical selects.
-- we're not trying to transfer a whole assumed size array. */
static void
-resolve_transfer (gfc_code * code)
+resolve_transfer (gfc_code *code)
{
gfc_typespec *ts;
gfc_symbol *sym;
exp = code->expr;
- if (exp->expr_type != EXPR_VARIABLE
- && exp->expr_type != EXPR_FUNCTION)
+ if (exp->expr_type != EXPR_VARIABLE && exp->expr_type != EXPR_FUNCTION)
return;
sym = exp->symtree->n.sym;
/*********** Toplevel code resolution subroutines ***********/
+/* Find the set of labels that are reachable from this block. We also
+ record the last statement in each block so that we don't have to do
+ a linear search to find the END DO statements of the blocks. */
+
+static void
+reachable_labels (gfc_code *block)
+{
+ gfc_code *c;
+
+ if (!block)
+ return;
+
+ cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
+
+ /* Collect labels in this block. */
+ for (c = block; c; c = c->next)
+ {
+ if (c->here)
+ bitmap_set_bit (cs_base->reachable_labels, c->here->value);
+
+ if (!c->next && cs_base->prev)
+ cs_base->prev->tail = c;
+ }
+
+ /* Merge with labels from parent block. */
+ if (cs_base->prev)
+ {
+ gcc_assert (cs_base->prev->reachable_labels);
+ bitmap_ior_into (cs_base->reachable_labels,
+ cs_base->prev->reachable_labels);
+ }
+}
+
/* Given a branch to a label and a namespace, if the branch is conforming.
- The code node described where the branch is located. */
+ The code node describes where the branch is located. */
static void
-resolve_branch (gfc_st_label * label, gfc_code * code)
+resolve_branch (gfc_st_label *label, gfc_code *code)
{
- gfc_code *block, *found;
code_stack *stack;
- gfc_st_label *lp;
if (label == NULL)
return;
- lp = label;
/* Step one: is this a valid branching target? */
- if (lp->defined == ST_LABEL_UNKNOWN)
+ if (label->defined == ST_LABEL_UNKNOWN)
{
- gfc_error ("Label %d referenced at %L is never defined", lp->value,
- &lp->where);
+ gfc_error ("Label %d referenced at %L is never defined", label->value,
+ &label->where);
return;
}
- if (lp->defined != ST_LABEL_TARGET)
+ if (label->defined != ST_LABEL_TARGET)
{
gfc_error ("Statement at %L is not a valid branch target statement "
- "for the branch statement at %L", &lp->where, &code->loc);
+ "for the branch statement at %L", &label->where, &code->loc);
return;
}
return;
}
- /* Step three: Try to find the label in the parse tree. To do this,
- we traverse the tree block-by-block: first the block that
- contains this GOTO, then the block that it is nested in, etc. We
- can ignore other blocks because branching into another block is
- not allowed. */
-
- found = NULL;
-
- for (stack = cs_base; stack; stack = stack->prev)
- {
- for (block = stack->head; block; block = block->next)
- {
- if (block->here == label)
- {
- found = block;
- break;
- }
- }
-
- if (found)
- break;
- }
+ /* Step three: See if the label is in the same block as the
+ branching statement. The hard work has been done by setting up
+ the bitmap reachable_labels. */
- if (found == NULL)
+ if (!bitmap_bit_p (cs_base->reachable_labels, label->value))
{
/* The label is not in an enclosing block, so illegal. This was
- allowed in Fortran 66, so we allow it as extension. We also
- forego further checks if we run into this. */
- gfc_notify_std (GFC_STD_LEGACY,
- "Label at %L is not in the same block as the "
- "GOTO statement at %L", &lp->where, &code->loc);
+ allowed in Fortran 66, so we allow it as extension. No
+ further checks are necessary in this case. */
+ gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block "
+ "as the GOTO statement at %L", &label->where,
+ &code->loc);
return;
}
/* Step four: Make sure that the branching target is legal if
- the statement is an END {SELECT,DO,IF}. */
+ the statement is an END {SELECT,IF}. */
- if (found->op == EXEC_NOP)
- {
- for (stack = cs_base; stack; stack = stack->prev)
- if (stack->current->next == found)
- break;
+ for (stack = cs_base; stack; stack = stack->prev)
+ if (stack->current->next && stack->current->next->here == label)
+ break;
- if (stack == NULL)
- gfc_notify_std (GFC_STD_F95_DEL,
- "Obsolete: GOTO at %L jumps to END of construct at %L",
- &code->loc, &found->loc);
+ if (stack && stack->current->next->op == EXEC_NOP)
+ {
+ gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: GOTO at %L jumps to "
+ "END of construct at %L", &code->loc,
+ &stack->current->next->loc);
+ return; /* We know this is not an END DO. */
}
+
+ /* Step five: Make sure that we're not jumping to the end of a DO
+ loop from within the loop. */
+
+ for (stack = cs_base; stack; stack = stack->prev)
+ if ((stack->current->op == EXEC_DO
+ || stack->current->op == EXEC_DO_WHILE)
+ && stack->tail->here == label && stack->tail->op == EXEC_NOP)
+ {
+ gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: GOTO at %L jumps "
+ "to END of construct at %L", &code->loc,
+ &stack->tail->loc);
+ return;
+
+ }
}
for (i=0; i<expr1->rank; i++)
{
if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
- goto ignore;
+ goto ignore;
if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
- goto ignore;
+ goto ignore;
if (mpz_cmp (shape[i], shape2[i]))
- goto over;
+ goto over;
}
/* When either of the two expression is an assumed size array, we
result = SUCCESS;
over:
- for (i--; i>=0; i--)
+ for (i--; i >= 0; i--)
{
mpz_clear (shape[i]);
mpz_clear (shape2[i]);
while (cblock)
{
if (cblock->expr)
- {
- /* Check if the mask-expr has a consistent shape with the
- outmost WHERE mask-expr. */
- if (resolve_where_shape (cblock->expr, e) == FAILURE)
- gfc_error ("WHERE mask at %L has inconsistent shape",
- &cblock->expr->where);
- }
+ {
+ /* Check if the mask-expr has a consistent shape with the
+ outmost WHERE mask-expr. */
+ if (resolve_where_shape (cblock->expr, e) == FAILURE)
+ gfc_error ("WHERE mask at %L has inconsistent shape",
+ &cblock->expr->where);
+ }
/* the assignment statement of a WHERE statement, or the first
- statement in where-body-construct of a WHERE construct */
+ statement in where-body-construct of a WHERE construct */
cnext = cblock->next;
while (cnext)
- {
- switch (cnext->op)
- {
- /* WHERE assignment statement */
- case EXEC_ASSIGN:
-
- /* Check shape consistent for WHERE assignment target. */
- if (e && resolve_where_shape (cnext->expr, e) == FAILURE)
- gfc_error ("WHERE assignment target at %L has "
- "inconsistent shape", &cnext->expr->where);
- break;
-
- /* WHERE or WHERE construct is part of a where-body-construct */
- case EXEC_WHERE:
- resolve_where (cnext, e);
- break;
-
- default:
- gfc_error ("Unsupported statement inside WHERE at %L",
- &cnext->loc);
- }
- /* the next statement within the same where-body-construct */
- cnext = cnext->next;
+ {
+ switch (cnext->op)
+ {
+ /* WHERE assignment statement */
+ case EXEC_ASSIGN:
+
+ /* Check shape consistent for WHERE assignment target. */
+ if (e && resolve_where_shape (cnext->expr, e) == FAILURE)
+ gfc_error ("WHERE assignment target at %L has "
+ "inconsistent shape", &cnext->expr->where);
+ break;
+
+
+ case EXEC_ASSIGN_CALL:
+ resolve_call (cnext);
+ break;
+
+ /* WHERE or WHERE construct is part of a where-body-construct */
+ case EXEC_WHERE:
+ resolve_where (cnext, e);
+ break;
+
+ default:
+ gfc_error ("Unsupported statement inside WHERE at %L",
+ &cnext->loc);
+ }
+ /* the next statement within the same where-body-construct */
+ cnext = cnext->next;
}
/* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
cblock = cblock->block;
/* A scalar assignment */
if (!expr->ref)
- {
- if (expr->symtree->n.sym == symbol)
- return SUCCESS;
- else
- return FAILURE;
- }
+ {
+ if (expr->symtree->n.sym == symbol)
+ return SUCCESS;
+ else
+ return FAILURE;
+ }
/* the expr is array ref, substring or struct component. */
tmp = expr->ref;
while (tmp != NULL)
- {
- switch (tmp->type)
- {
- case REF_ARRAY:
- /* Check if the symbol appears in the array subscript. */
- ar = tmp->u.ar;
- for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
- {
- if (ar.start[i])
- if (gfc_find_forall_index (ar.start[i], symbol) == SUCCESS)
- return SUCCESS;
-
- if (ar.end[i])
- if (gfc_find_forall_index (ar.end[i], symbol) == SUCCESS)
- return SUCCESS;
-
- if (ar.stride[i])
- if (gfc_find_forall_index (ar.stride[i], symbol) == SUCCESS)
- return SUCCESS;
- } /* end for */
- break;
-
- case REF_SUBSTRING:
- if (expr->symtree->n.sym == symbol)
- return SUCCESS;
- tmp = expr->ref;
- /* Check if the symbol appears in the substring section. */
- if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
- return SUCCESS;
- if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
- return SUCCESS;
- break;
-
- case REF_COMPONENT:
- break;
-
- default:
- gfc_error("expression reference type error at %L", &expr->where);
- }
- tmp = tmp->next;
- }
+ {
+ switch (tmp->type)
+ {
+ case REF_ARRAY:
+ /* Check if the symbol appears in the array subscript. */
+ ar = tmp->u.ar;
+ for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
+ {
+ if (ar.start[i])
+ if (gfc_find_forall_index (ar.start[i], symbol) == SUCCESS)
+ return SUCCESS;
+
+ if (ar.end[i])
+ if (gfc_find_forall_index (ar.end[i], symbol) == SUCCESS)
+ return SUCCESS;
+
+ if (ar.stride[i])
+ if (gfc_find_forall_index (ar.stride[i], symbol) == SUCCESS)
+ return SUCCESS;
+ } /* end for */
+ break;
+
+ case REF_SUBSTRING:
+ if (expr->symtree->n.sym == symbol)
+ return SUCCESS;
+ tmp = expr->ref;
+ /* Check if the symbol appears in the substring section. */
+ if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
+ return SUCCESS;
+ if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
+ return SUCCESS;
+ break;
+
+ case REF_COMPONENT:
+ break;
+
+ default:
+ gfc_error("expression reference type error at %L", &expr->where);
+ }
+ tmp = tmp->next;
+ }
break;
/* If the expression is a function call, then check if the symbol
appears in the actual arglist of the function. */
case EXPR_FUNCTION:
for (args = expr->value.function.actual; args; args = args->next)
- {
- if (gfc_find_forall_index(args->expr,symbol) == SUCCESS)
- return SUCCESS;
- }
+ {
+ if (gfc_find_forall_index(args->expr,symbol) == SUCCESS)
+ return SUCCESS;
+ }
break;
/* It seems not to happen. */
case EXPR_SUBSTRING:
if (expr->ref)
- {
- tmp = expr->ref;
- gcc_assert (expr->ref->type == REF_SUBSTRING);
- if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
- return SUCCESS;
- if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
- return SUCCESS;
- }
+ {
+ tmp = expr->ref;
+ gcc_assert (expr->ref->type == REF_SUBSTRING);
+ if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
+ return SUCCESS;
+ if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
+ return SUCCESS;
+ }
break;
/* It seems not to happen. */
case EXPR_STRUCTURE:
case EXPR_ARRAY:
gfc_error ("Unsupported statement while finding forall index in "
- "expression");
+ "expression");
break;
case EXPR_OP:
forall_index = var_expr[n]->symtree->n.sym;
/* Check whether the assignment target is one of the FORALL index
- variable. */
+ variable. */
if ((code->expr->expr_type == EXPR_VARIABLE)
- && (code->expr->symtree->n.sym == forall_index))
- gfc_error ("Assignment to a FORALL index variable at %L",
- &code->expr->where);
+ && (code->expr->symtree->n.sym == forall_index))
+ gfc_error ("Assignment to a FORALL index variable at %L",
+ &code->expr->where);
else
- {
- /* If one of the FORALL index variables doesn't appear in the
- assignment target, then there will be a many-to-one
- assignment. */
- if (gfc_find_forall_index (code->expr, forall_index) == FAILURE)
- gfc_error ("The FORALL with index '%s' cause more than one "
- "assignment to this object at %L",
- var_expr[n]->symtree->name, &code->expr->where);
- }
+ {
+ /* If one of the FORALL index variables doesn't appear in the
+ assignment target, then there will be a many-to-one
+ assignment. */
+ if (gfc_find_forall_index (code->expr, forall_index) == FAILURE)
+ gfc_error ("The FORALL with index '%s' cause more than one "
+ "assignment to this object at %L",
+ var_expr[n]->symtree->name, &code->expr->where);
+ }
}
}
/* Resolve WHERE statement in FORALL construct. */
static void
-gfc_resolve_where_code_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr){
+gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
+ gfc_expr **var_expr)
+{
gfc_code *cblock;
gfc_code *cnext;
while (cblock)
{
/* the assignment statement of a WHERE statement, or the first
- statement in where-body-construct of a WHERE construct */
+ statement in where-body-construct of a WHERE construct */
cnext = cblock->next;
while (cnext)
- {
- switch (cnext->op)
- {
- /* WHERE assignment statement */
- case EXEC_ASSIGN:
- gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
- break;
-
- /* WHERE or WHERE construct is part of a where-body-construct */
- case EXEC_WHERE:
- gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
- break;
-
- default:
- gfc_error ("Unsupported statement inside WHERE at %L",
- &cnext->loc);
- }
- /* the next statement within the same where-body-construct */
- cnext = cnext->next;
- }
+ {
+ switch (cnext->op)
+ {
+ /* WHERE assignment statement */
+ case EXEC_ASSIGN:
+ gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
+ break;
+
+ /* WHERE operator assignment statement */
+ case EXEC_ASSIGN_CALL:
+ resolve_call (cnext);
+ break;
+
+ /* WHERE or WHERE construct is part of a where-body-construct */
+ case EXEC_WHERE:
+ gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
+ break;
+
+ default:
+ gfc_error ("Unsupported statement inside WHERE at %L",
+ &cnext->loc);
+ }
+ /* the next statement within the same where-body-construct */
+ cnext = cnext->next;
+ }
/* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
cblock = cblock->block;
}
while (c)
{
switch (c->op)
- {
- case EXEC_ASSIGN:
- case EXEC_POINTER_ASSIGN:
- gfc_resolve_assign_in_forall (c, nvar, var_expr);
- break;
+ {
+ case EXEC_ASSIGN:
+ case EXEC_POINTER_ASSIGN:
+ gfc_resolve_assign_in_forall (c, nvar, var_expr);
+ break;
- /* Because the gfc_resolve_blocks() will handle the nested FORALL,
- there is no need to handle it here. */
- case EXEC_FORALL:
- break;
- case EXEC_WHERE:
- gfc_resolve_where_code_in_forall(c, nvar, var_expr);
- break;
- default:
- break;
- }
+ case EXEC_ASSIGN_CALL:
+ resolve_call (c);
+ break;
+
+ /* Because the gfc_resolve_blocks() will handle the nested FORALL,
+ there is no need to handle it here. */
+ case EXEC_FORALL:
+ break;
+ case EXEC_WHERE:
+ gfc_resolve_where_code_in_forall(c, nvar, var_expr);
+ break;
+ default:
+ break;
+ }
/* The next statement in the FORALL body. */
c = c->next;
}
if (forall_save == 0)
{
/* Count the total number of FORALL index in the nested FORALL
- construct in order to allocate the VAR_EXPR with proper size. */
+ construct in order to allocate the VAR_EXPR with proper size. */
next = code;
while ((next != NULL) && (next->op == EXEC_FORALL))
- {
- for (fa = next->ext.forall_iterator; fa; fa = fa->next)
- total_var ++;
- next = next->block->next;
- }
+ {
+ for (fa = next->ext.forall_iterator; fa; fa = fa->next)
+ total_var ++;
+ next = next->block->next;
+ }
/* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
/* The information about FORALL iterator, including FORALL index start, end
and stride. The FORALL index can not appear in start, end or stride. */
for (fa = code->ext.forall_iterator; fa; fa = fa->next)
- {
- /* Check if any outer FORALL index name is the same as the current
- one. */
- for (i = 0; i < nvar; i++)
- {
- if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
- {
- gfc_error ("An outer FORALL construct already has an index "
- "with this name %L", &fa->var->where);
- }
- }
+ {
+ /* Check if any outer FORALL index name is the same as the current
+ one. */
+ for (i = 0; i < nvar; i++)
+ {
+ if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
+ {
+ gfc_error ("An outer FORALL construct already has an index "
+ "with this name %L", &fa->var->where);
+ }
+ }
/* Record the current FORALL index. */
var_expr[nvar] = gfc_copy_expr (fa->var);
/* Check if the FORALL index appears in start, end or stride. */
if (gfc_find_forall_index (fa->start, forall_index) == SUCCESS)
- gfc_error ("A FORALL index must not appear in a limit or stride "
- "expression in the same FORALL at %L", &fa->start->where);
+ gfc_error ("A FORALL index must not appear in a limit or stride "
+ "expression in the same FORALL at %L", &fa->start->where);
if (gfc_find_forall_index (fa->end, forall_index) == SUCCESS)
- gfc_error ("A FORALL index must not appear in a limit or stride "
- "expression in the same FORALL at %L", &fa->end->where);
+ gfc_error ("A FORALL index must not appear in a limit or stride "
+ "expression in the same FORALL at %L", &fa->end->where);
if (gfc_find_forall_index (fa->stride, forall_index) == SUCCESS)
- gfc_error ("A FORALL index must not appear in a limit or stride "
- "expression in the same FORALL at %L", &fa->stride->where);
+ gfc_error ("A FORALL index must not appear in a limit or stride "
+ "expression in the same FORALL at %L", &fa->stride->where);
nvar++;
}
static void resolve_code (gfc_code *, gfc_namespace *);
void
-gfc_resolve_blocks (gfc_code * b, gfc_namespace * ns)
+gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
{
try t;
case EXEC_IF:
if (t == SUCCESS && b->expr != NULL
&& (b->expr->ts.type != BT_LOGICAL || b->expr->rank != 0))
- gfc_error
- ("IF clause at %L requires a scalar LOGICAL expression",
- &b->expr->where);
+ gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
+ &b->expr->where);
break;
case EXEC_WHERE:
if (t == SUCCESS
&& b->expr != NULL
- && (b->expr->ts.type != BT_LOGICAL
- || b->expr->rank == 0))
- gfc_error
- ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
- &b->expr->where);
+ && (b->expr->ts.type != BT_LOGICAL || b->expr->rank == 0))
+ gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
+ &b->expr->where);
break;
- case EXEC_GOTO:
- resolve_branch (b->label, b);
- break;
+ case EXEC_GOTO:
+ resolve_branch (b->label, b);
+ break;
case EXEC_SELECT:
case EXEC_FORALL:
code block. */
static void
-resolve_code (gfc_code * code, gfc_namespace * ns)
+resolve_code (gfc_code *code, gfc_namespace *ns)
{
int omp_workshare_save;
int forall_save;
frame.head = code;
cs_base = &frame;
+ reachable_labels (code);
+
for (; code; code = code->next)
{
frame.current = code;
break;
case EXEC_GOTO:
- if (code->expr != NULL)
+ if (code->expr != NULL)
{
if (code->expr->ts.type != BT_INTEGER)
- gfc_error ("ASSIGNED GOTO statement at %L requires an INTEGER "
- "variable", &code->expr->where);
+ gfc_error ("ASSIGNED GOTO statement at %L requires an "
+ "INTEGER variable", &code->expr->where);
else if (code->expr->symtree->n.sym->attr.assign != 1)
- gfc_error ("Variable '%s' has not been assigned a target label "
- "at %L", code->expr->symtree->n.sym->name,
- &code->expr->where);
+ gfc_error ("Variable '%s' has not been assigned a target "
+ "label at %L", code->expr->symtree->n.sym->name,
+ &code->expr->where);
}
else
- resolve_branch (code->label, code);
+ resolve_branch (code->label, code);
break;
case EXEC_RETURN:
}
if (code->expr->ts.type == BT_CHARACTER
- && gfc_option.warn_character_truncation)
+ && gfc_option.warn_character_truncation)
{
int llen = 0, rlen = 0;
if (code->expr->ts.cl != NULL
- && code->expr->ts.cl->length != NULL
- && code->expr->ts.cl->length->expr_type == EXPR_CONSTANT)
+ && code->expr->ts.cl->length != NULL
+ && code->expr->ts.cl->length->expr_type == EXPR_CONSTANT)
llen = mpz_get_si (code->expr->ts.cl->length->value.integer);
if (code->expr2->expr_type == EXPR_CONSTANT)
rlen = code->expr2->value.character.length;
else if (code->expr2->ts.cl != NULL
- && code->expr2->ts.cl->length != NULL
- && code->expr2->ts.cl->length->expr_type == EXPR_CONSTANT)
+ && code->expr2->ts.cl->length != NULL
+ && code->expr2->ts.cl->length->expr_type
+ == EXPR_CONSTANT)
rlen = mpz_get_si (code->expr2->ts.cl->length->value.integer);
if (rlen && llen && rlen > llen)
- gfc_warning_now ("rhs of CHARACTER assignment at %L will "
- "be truncated (%d/%d)", &code->loc, rlen, llen);
+ gfc_warning_now ("CHARACTER expression will be truncated "
+ "in assignment (%d/%d) at %L",
+ llen, rlen, &code->loc);
}
if (gfc_pure (NULL))
{
if (gfc_impure_variable (code->expr->symtree->n.sym))
{
- gfc_error
- ("Cannot assign to variable '%s' in PURE procedure at %L",
- code->expr->symtree->n.sym->name, &code->expr->where);
+ gfc_error ("Cannot assign to variable '%s' in PURE "
+ "procedure at %L",
+ code->expr->symtree->n.sym->name,
+ &code->expr->where);
break;
}
- if (code->expr2->ts.type == BT_DERIVED
- && derived_pointer (code->expr2->ts.derived))
+ if (code->expr->ts.type == BT_DERIVED
+ && code->expr->expr_type == EXPR_VARIABLE
+ && derived_pointer (code->expr->ts.derived)
+ && gfc_impure_variable (code->expr2->symtree->n.sym))
{
- gfc_error
- ("Right side of assignment at %L is a derived type "
- "containing a POINTER in a PURE procedure",
- &code->expr2->where);
+ gfc_error ("The impure variable at %L is assigned to "
+ "a derived type variable with a POINTER "
+ "component in a PURE procedure (12.6)",
+ &code->expr2->where);
break;
}
}
- gfc_check_assign (code->expr, code->expr2, 1);
+ gfc_check_assign (code->expr, code->expr2, 1);
break;
case EXEC_LABEL_ASSIGN:
- if (code->label->defined == ST_LABEL_UNKNOWN)
- gfc_error ("Label %d referenced at %L is never defined",
- code->label->value, &code->label->where);
- if (t == SUCCESS
+ if (code->label->defined == ST_LABEL_UNKNOWN)
+ gfc_error ("Label %d referenced at %L is never defined",
+ code->label->value, &code->label->where);
+ if (t == SUCCESS
&& (code->expr->expr_type != EXPR_VARIABLE
|| code->expr->symtree->n.sym->ts.type != BT_INTEGER
|| code->expr->symtree->n.sym->ts.kind
- != gfc_default_integer_kind
+ != gfc_default_integer_kind
|| code->expr->symtree->n.sym->as != NULL))
gfc_error ("ASSIGN statement at %L requires a scalar "
"default INTEGER variable", &code->expr->where);
resolve_forall_iterators (code->ext.forall_iterator);
if (code->expr != NULL && code->expr->ts.type != BT_LOGICAL)
- gfc_error
- ("FORALL mask clause at %L requires a LOGICAL expression",
- &code->expr->where);
+ gfc_error ("FORALL mask clause at %L requires a LOGICAL "
+ "expression", &code->expr->where);
break;
case EXEC_OMP_ATOMIC:
the variable. */
static void
-resolve_values (gfc_symbol * sym)
+resolve_values (gfc_symbol *sym)
{
-
if (sym->value == NULL)
return;
}
+/* Verify the binding labels for common blocks that are BIND(C). The label
+ for a BIND(C) common block must be identical in all scoping units in which
+ the common block is declared. Further, the binding label can not collide
+ with any other global entity in the program. */
+
+static void
+resolve_bind_c_comms (gfc_symtree *comm_block_tree)
+{
+ if (comm_block_tree->n.common->is_bind_c == 1)
+ {
+ gfc_gsymbol *binding_label_gsym;
+ gfc_gsymbol *comm_name_gsym;
+
+ /* See if a global symbol exists by the common block's name. It may
+ be NULL if the common block is use-associated. */
+ comm_name_gsym = gfc_find_gsymbol (gfc_gsym_root,
+ comm_block_tree->n.common->name);
+ if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
+ gfc_error ("Binding label '%s' for common block '%s' at %L collides "
+ "with the global entity '%s' at %L",
+ comm_block_tree->n.common->binding_label,
+ comm_block_tree->n.common->name,
+ &(comm_block_tree->n.common->where),
+ comm_name_gsym->name, &(comm_name_gsym->where));
+ else if (comm_name_gsym != NULL
+ && strcmp (comm_name_gsym->name,
+ comm_block_tree->n.common->name) == 0)
+ {
+ /* TODO: Need to make sure the fields of gfc_gsymbol are initialized
+ as expected. */
+ if (comm_name_gsym->binding_label == NULL)
+ /* No binding label for common block stored yet; save this one. */
+ comm_name_gsym->binding_label =
+ comm_block_tree->n.common->binding_label;
+ else
+ if (strcmp (comm_name_gsym->binding_label,
+ comm_block_tree->n.common->binding_label) != 0)
+ {
+ /* Common block names match but binding labels do not. */
+ gfc_error ("Binding label '%s' for common block '%s' at %L "
+ "does not match the binding label '%s' for common "
+ "block '%s' at %L",
+ comm_block_tree->n.common->binding_label,
+ comm_block_tree->n.common->name,
+ &(comm_block_tree->n.common->where),
+ comm_name_gsym->binding_label,
+ comm_name_gsym->name,
+ &(comm_name_gsym->where));
+ return;
+ }
+ }
+
+ /* There is no binding label (NAME="") so we have nothing further to
+ check and nothing to add as a global symbol for the label. */
+ if (comm_block_tree->n.common->binding_label[0] == '\0' )
+ return;
+
+ binding_label_gsym =
+ gfc_find_gsymbol (gfc_gsym_root,
+ comm_block_tree->n.common->binding_label);
+ if (binding_label_gsym == NULL)
+ {
+ /* Need to make a global symbol for the binding label to prevent
+ it from colliding with another. */
+ binding_label_gsym =
+ gfc_get_gsymbol (comm_block_tree->n.common->binding_label);
+ binding_label_gsym->sym_name = comm_block_tree->n.common->name;
+ binding_label_gsym->type = GSYM_COMMON;
+ }
+ else
+ {
+ /* If comm_name_gsym is NULL, the name common block is use
+ associated and the name could be colliding. */
+ if (binding_label_gsym->type != GSYM_COMMON)
+ gfc_error ("Binding label '%s' for common block '%s' at %L "
+ "collides with the global entity '%s' at %L",
+ comm_block_tree->n.common->binding_label,
+ comm_block_tree->n.common->name,
+ &(comm_block_tree->n.common->where),
+ binding_label_gsym->name,
+ &(binding_label_gsym->where));
+ else if (comm_name_gsym != NULL
+ && (strcmp (binding_label_gsym->name,
+ comm_name_gsym->binding_label) != 0)
+ && (strcmp (binding_label_gsym->sym_name,
+ comm_name_gsym->name) != 0))
+ gfc_error ("Binding label '%s' for common block '%s' at %L "
+ "collides with global entity '%s' at %L",
+ binding_label_gsym->name, binding_label_gsym->sym_name,
+ &(comm_block_tree->n.common->where),
+ comm_name_gsym->name, &(comm_name_gsym->where));
+ }
+ }
+
+ return;
+}
+
+
+/* Verify any BIND(C) derived types in the namespace so we can report errors
+ for them once, rather than for each variable declared of that type. */
+
+static void
+resolve_bind_c_derived_types (gfc_symbol *derived_sym)
+{
+ if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED
+ && derived_sym->attr.is_bind_c == 1)
+ verify_bind_c_derived_type (derived_sym);
+
+ return;
+}
+
+
+/* Verify that any binding labels used in a given namespace do not collide
+ with the names or binding labels of any global symbols. */
+
+static void
+gfc_verify_binding_labels (gfc_symbol *sym)
+{
+ int has_error = 0;
+
+ if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
+ && sym->attr.flavor != FL_DERIVED && sym->binding_label[0] != '\0')
+ {
+ gfc_gsymbol *bind_c_sym;
+
+ bind_c_sym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label);
+ if (bind_c_sym != NULL
+ && strcmp (bind_c_sym->name, sym->binding_label) == 0)
+ {
+ if (sym->attr.if_source == IFSRC_DECL
+ && (bind_c_sym->type != GSYM_SUBROUTINE
+ && bind_c_sym->type != GSYM_FUNCTION)
+ && ((sym->attr.contained == 1
+ && strcmp (bind_c_sym->sym_name, sym->name) != 0)
+ || (sym->attr.use_assoc == 1
+ && (strcmp (bind_c_sym->mod_name, sym->module) != 0))))
+ {
+ /* Make sure global procedures don't collide with anything. */
+ gfc_error ("Binding label '%s' at %L collides with the global "
+ "entity '%s' at %L", sym->binding_label,
+ &(sym->declared_at), bind_c_sym->name,
+ &(bind_c_sym->where));
+ has_error = 1;
+ }
+ else if (sym->attr.contained == 0
+ && (sym->attr.if_source == IFSRC_IFBODY
+ && sym->attr.flavor == FL_PROCEDURE)
+ && (bind_c_sym->sym_name != NULL
+ && strcmp (bind_c_sym->sym_name, sym->name) != 0))
+ {
+ /* Make sure procedures in interface bodies don't collide. */
+ gfc_error ("Binding label '%s' in interface body at %L collides "
+ "with the global entity '%s' at %L",
+ sym->binding_label,
+ &(sym->declared_at), bind_c_sym->name,
+ &(bind_c_sym->where));
+ has_error = 1;
+ }
+ else if (sym->attr.contained == 0
+ && (sym->attr.if_source == IFSRC_UNKNOWN))
+ if ((sym->attr.use_assoc
+ && (strcmp (bind_c_sym->mod_name, sym->module) != 0))
+ || sym->attr.use_assoc == 0)
+ {
+ gfc_error ("Binding label '%s' at %L collides with global "
+ "entity '%s' at %L", sym->binding_label,
+ &(sym->declared_at), bind_c_sym->name,
+ &(bind_c_sym->where));
+ has_error = 1;
+ }
+
+ if (has_error != 0)
+ /* Clear the binding label to prevent checking multiple times. */
+ sym->binding_label[0] = '\0';
+ }
+ else if (bind_c_sym == NULL)
+ {
+ bind_c_sym = gfc_get_gsymbol (sym->binding_label);
+ bind_c_sym->where = sym->declared_at;
+ bind_c_sym->sym_name = sym->name;
+
+ if (sym->attr.use_assoc == 1)
+ bind_c_sym->mod_name = sym->module;
+ else
+ if (sym->ns->proc_name != NULL)
+ bind_c_sym->mod_name = sym->ns->proc_name->name;
+
+ if (sym->attr.contained == 0)
+ {
+ if (sym->attr.subroutine)
+ bind_c_sym->type = GSYM_SUBROUTINE;
+ else if (sym->attr.function)
+ bind_c_sym->type = GSYM_FUNCTION;
+ }
+ }
+ }
+ return;
+}
+
+
/* Resolve an index expression. */
static try
-resolve_index_expr (gfc_expr * e)
+resolve_index_expr (gfc_expr *e)
{
if (gfc_resolve_expr (e) == FAILURE)
return FAILURE;
static try
resolve_charlen (gfc_charlen *cl)
{
+ int i;
+
if (cl->resolved)
return SUCCESS;
return FAILURE;
}
+ /* "If the character length parameter value evaluates to a negative
+ value, the length of character entities declared is zero." */
+ if (cl->length && !gfc_extract_int (cl->length, &i) && i <= 0)
+ {
+ gfc_warning_now ("CHARACTER variable has zero length at %L",
+ &cl->length->where);
+ gfc_replace_expr (cl->length, gfc_int_expr (0));
+ }
+
return SUCCESS;
}
-/* Test for non-constant shape arrays. */
+/* Test for non-constant shape arrays. */
static bool
is_non_constant_shape_array (gfc_symbol *sym)
{
e = sym->as->lower[i];
if (e && (resolve_index_expr (e) == FAILURE
- || !gfc_is_constant_expr (e)))
+ || !gfc_is_constant_expr (e)))
not_constant = true;
e = sym->as->upper[i];
if (e && (resolve_index_expr (e) == FAILURE
- || !gfc_is_constant_expr (e)))
+ || !gfc_is_constant_expr (e)))
not_constant = true;
}
}
/* Search for the function namespace if this is a contained
function without an explicit result. */
if (sym->attr.function && sym == sym->result
- && sym->name != sym->ns->proc_name->name)
+ && sym->name != sym->ns->proc_name->name)
{
ns = ns->contained;
for (;ns; ns = ns->sibling)
}
-/* Resolution of common features of flavors variable and procedure. */
+/* Resolution of common features of flavors variable and procedure. */
static try
resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
else
{
if (!mp_flag && !sym->attr.allocatable
- && !sym->attr.pointer && !sym->attr.dummy)
+ && !sym->attr.pointer && !sym->attr.dummy)
{
gfc_error ("Array '%s' at %L cannot have a deferred shape",
sym->name, &sym->declared_at);
return SUCCESS;
}
+
+static gfc_component *
+has_default_initializer (gfc_symbol *der)
+{
+ gfc_component *c;
+ for (c = der->components; c; c = c->next)
+ if ((c->ts.type != BT_DERIVED && c->initializer)
+ || (c->ts.type == BT_DERIVED
+ && !c->pointer
+ && has_default_initializer (c->ts.derived)))
+ break;
+
+ return c;
+}
+
+
/* Resolve symbols with flavor variable. */
static try
int flag;
int i;
gfc_expr *e;
- gfc_expr *constructor_expr;
- const char * auto_save_msg;
+ gfc_component *c;
+ const char *auto_save_msg;
auto_save_msg = "automatic object '%s' at %L cannot have the "
"SAVE attribute";
specification_expr = 1;
if (!sym->attr.use_assoc
- && !sym->attr.allocatable
- && !sym->attr.pointer
- && is_non_constant_shape_array (sym))
+ && !sym->attr.allocatable
+ && !sym->attr.pointer
+ && is_non_constant_shape_array (sym))
{
- /* The shape of a main program or module array needs to be constant. */
+ /* The shape of a main program or module array needs to be
+ constant. */
if (sym->ns->proc_name
- && (sym->ns->proc_name->attr.flavor == FL_MODULE
- || sym->ns->proc_name->attr.is_main_program))
+ && (sym->ns->proc_name->attr.flavor == FL_MODULE
+ || sym->ns->proc_name->attr.is_main_program))
{
gfc_error ("The module or main program array '%s' at %L must "
"have constant shape", sym->name, &sym->declared_at);
}
if (!gfc_is_constant_expr (e)
- && !(e->expr_type == EXPR_VARIABLE
- && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
- && sym->ns->proc_name
- && (sym->ns->proc_name->attr.flavor == FL_MODULE
- || sym->ns->proc_name->attr.is_main_program)
- && !sym->attr.use_assoc)
+ && !(e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
+ && sym->ns->proc_name
+ && (sym->ns->proc_name->attr.flavor == FL_MODULE
+ || sym->ns->proc_name->attr.is_main_program)
+ && !sym->attr.use_assoc)
{
gfc_error ("'%s' at %L must have constant character length "
"in this context", sym->name, &sym->declared_at);
for (i = 0; i < sym->as->rank; i++)
{
if (sym->as->lower[i] == NULL
- || sym->as->lower[i]->expr_type != EXPR_CONSTANT
- || sym->as->upper[i] == NULL
- || sym->as->upper[i]->expr_type != EXPR_CONSTANT)
+ || sym->as->lower[i]->expr_type != EXPR_CONSTANT
+ || sym->as->upper[i] == NULL
+ || sym->as->upper[i]->expr_type != EXPR_CONSTANT)
{
- flag = 1;
+ flag = 2;
break;
}
}
- /* Also, they must not have the SAVE attribute. */
- if (flag && sym->attr.save)
+ /* Also, they must not have the SAVE attribute.
+ SAVE_IMPLICIT is checked below. */
+ if (flag && sym->attr.save == SAVE_EXPLICIT)
{
gfc_error (auto_save_msg, sym->name, &sym->declared_at);
return FAILURE;
}
/* Reject illegal initializers. */
- if (sym->value && flag)
+ if (!sym->mark && sym->value && flag)
{
if (sym->attr.allocatable)
gfc_error ("Allocatable '%s' at %L cannot have an initializer",
else if (sym->attr.external)
gfc_error ("External '%s' at %L cannot have an initializer",
sym->name, &sym->declared_at);
- else if (sym->attr.dummy)
+ else if (sym->attr.dummy
+ && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT))
gfc_error ("Dummy '%s' at %L cannot have an initializer",
sym->name, &sym->declared_at);
else if (sym->attr.intrinsic)
else if (sym->attr.result)
gfc_error ("Function result '%s' at %L cannot have an initializer",
sym->name, &sym->declared_at);
- else
+ else if (flag == 2)
gfc_error ("Automatic array '%s' at %L cannot have an initializer",
sym->name, &sym->declared_at);
+ else
+ goto no_init_error;
return FAILURE;
}
+no_init_error:
/* Check to see if a derived type is blocked from being host associated
by the presence of another class I symbol in the same namespace.
14.6.1.3 of the standard and the discussion on comp.lang.fortran. */
- if (sym->ts.type == BT_DERIVED && sym->ns != sym->ts.derived->ns)
+ if (sym->ts.type == BT_DERIVED && sym->ns != sym->ts.derived->ns
+ && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
{
gfc_symbol *s;
gfc_find_symbol (sym->ts.derived->name, sym->ns, 0, &s);
if (s && (s->attr.flavor != FL_DERIVED
- || !gfc_compare_derived_types (s, sym->ts.derived)))
+ || !gfc_compare_derived_types (s, sym->ts.derived)))
{
gfc_error ("The type %s cannot be host associated at %L because "
"it is blocked by an incompatible object of the same "
}
}
+ /* Do not use gfc_default_initializer to test for a default initializer
+ in the fortran because it generates a hidden default for allocatable
+ components. */
+ c = NULL;
+ if (sym->ts.type == BT_DERIVED && !(sym->value || flag))
+ c = has_default_initializer (sym->ts.derived);
+
/* 4th constraint in section 11.3: "If an object of a type for which
component-initialization is specified (R429) appears in the
specification-part of a module and does not have the ALLOCATABLE
or POINTER attribute, the object shall have the SAVE attribute." */
-
- constructor_expr = NULL;
- if (sym->ts.type == BT_DERIVED && !(sym->value || flag))
- constructor_expr = gfc_default_initializer (&sym->ts);
-
- if (sym->ns->proc_name
- && sym->ns->proc_name->attr.flavor == FL_MODULE
- && constructor_expr
- && !sym->ns->save_all && !sym->attr.save
- && !sym->attr.pointer && !sym->attr.allocatable)
+ if (c && sym->ns->proc_name
+ && sym->ns->proc_name->attr.flavor == FL_MODULE
+ && !sym->ns->save_all && !sym->attr.save
+ && !sym->attr.pointer && !sym->attr.allocatable)
{
gfc_error("Object '%s' at %L must have the SAVE attribute %s",
sym->name, &sym->declared_at,
/* Assign default initializer. */
if (sym->ts.type == BT_DERIVED
- && !sym->value
- && !sym->attr.pointer
- && !sym->attr.allocatable
- && (!flag || sym->attr.intent == INTENT_OUT))
+ && !sym->value
+ && !sym->attr.pointer
+ && !sym->attr.allocatable
+ && (!flag || sym->attr.intent == INTENT_OUT))
sym->value = gfc_default_initializer (&sym->ts);
return SUCCESS;
"interfaces", sym->name, &sym->declared_at);
if (sym->attr.function
- && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
+ && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
return FAILURE;
if (sym->ts.type == BT_CHARACTER)
{
gfc_charlen *cl = sym->ts.cl;
+
+ if (cl && cl->length && gfc_is_constant_expr (cl->length)
+ && resolve_charlen (cl) == FAILURE)
+ return FAILURE;
+
if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
{
if (sym->attr.proc == PROC_ST_FUNCTION)
{
- gfc_error ("Character-valued statement function '%s' at %L must "
- "have constant length", sym->name, &sym->declared_at);
- return FAILURE;
- }
+ gfc_error ("Character-valued statement function '%s' at %L must "
+ "have constant length", sym->name, &sym->declared_at);
+ return FAILURE;
+ }
if (sym->attr.external && sym->formal == NULL
- && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
- {
- gfc_error ("Automatic character length function '%s' at %L must "
- "have an explicit interface", sym->name, &sym->declared_at);
- return FAILURE;
- }
- }
+ && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
+ {
+ gfc_error ("Automatic character length function '%s' at %L must "
+ "have an explicit interface", sym->name,
+ &sym->declared_at);
+ return FAILURE;
+ }
+ }
}
/* Ensure that derived type for are not of a private type. Internal
module procedures are excluded by 2.2.3.3 - ie. they are not
externally accessible and can access all the objects accessible in
- the host. */
+ the host. */
if (!(sym->ns->parent
- && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
- && gfc_check_access(sym->attr.access, sym->ns->default_access))
+ && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
+ && gfc_check_access(sym->attr.access, sym->ns->default_access))
{
+ gfc_interface *iface;
+
for (arg = sym->formal; arg; arg = arg->next)
{
if (arg->sym
- && arg->sym->ts.type == BT_DERIVED
- && !arg->sym->ts.derived->attr.use_assoc
- && !gfc_check_access(arg->sym->ts.derived->attr.access,
- arg->sym->ts.derived->ns->default_access))
+ && arg->sym->ts.type == BT_DERIVED
+ && !arg->sym->ts.derived->attr.use_assoc
+ && !gfc_check_access (arg->sym->ts.derived->attr.access,
+ arg->sym->ts.derived->ns->default_access))
{
gfc_error_now ("'%s' is of a PRIVATE type and cannot be "
"a dummy argument of '%s', which is "
return FAILURE;
}
}
+
+ /* PUBLIC interfaces may expose PRIVATE procedures that take types
+ PRIVATE to the containing module. */
+ for (iface = sym->generic; iface; iface = iface->next)
+ {
+ for (arg = iface->sym->formal; arg; arg = arg->next)
+ {
+ if (arg->sym
+ && arg->sym->ts.type == BT_DERIVED
+ && !arg->sym->ts.derived->attr.use_assoc
+ && !gfc_check_access (arg->sym->ts.derived->attr.access,
+ arg->sym->ts.derived->ns->default_access))
+ {
+ gfc_error_now ("Procedure '%s' in PUBLIC interface '%s' at %L takes "
+ "dummy arguments of '%s' which is PRIVATE",
+ iface->sym->name, sym->name, &iface->sym->declared_at,
+ gfc_typename(&arg->sym->ts));
+ /* Stop this message from recurring. */
+ arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
+ return FAILURE;
+ }
+ }
+ }
+
+ /* PUBLIC interfaces may expose PRIVATE procedures that take types
+ PRIVATE to the containing module. */
+ for (iface = sym->generic; iface; iface = iface->next)
+ {
+ for (arg = iface->sym->formal; arg; arg = arg->next)
+ {
+ if (arg->sym
+ && arg->sym->ts.type == BT_DERIVED
+ && !arg->sym->ts.derived->attr.use_assoc
+ && !gfc_check_access (arg->sym->ts.derived->attr.access,
+ arg->sym->ts.derived->ns->default_access))
+ {
+ gfc_error_now ("Procedure '%s' in PUBLIC interface '%s' at %L takes "
+ "dummy arguments of '%s' which is PRIVATE",
+ iface->sym->name, sym->name, &iface->sym->declared_at,
+ gfc_typename(&arg->sym->ts));
+ /* Stop this message from recurring. */
+ arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
+ return FAILURE;
+ }
+ }
+ }
+ }
+
+ if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION)
+ {
+ gfc_error ("Function '%s' at %L cannot have an initializer",
+ sym->name, &sym->declared_at);
+ return FAILURE;
}
/* An external symbol may not have an initializer because it is taken to be
actual length; (ii) To declare a named constant; or (iii) External
function - but length must be declared in calling scoping unit. */
if (sym->attr.function
- && sym->ts.type == BT_CHARACTER
- && sym->ts.cl && sym->ts.cl->length == NULL)
+ && sym->ts.type == BT_CHARACTER
+ && sym->ts.cl && sym->ts.cl->length == NULL)
{
if ((sym->as && sym->as->rank) || (sym->attr.pointer)
- || (sym->attr.recursive) || (sym->attr.pure))
+ || (sym->attr.recursive) || (sym->attr.pure))
{
if (sym->as && sym->as->rank)
gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
"'%s' at %L is obsolescent in fortran 95",
sym->name, &sym->declared_at);
}
+
+ if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
+ {
+ gfc_formal_arglist *curr_arg;
+ int has_non_interop_arg = 0;
+
+ if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
+ sym->common_block) == FAILURE)
+ {
+ /* Clear these to prevent looking at them again if there was an
+ error. */
+ sym->attr.is_bind_c = 0;
+ sym->attr.is_c_interop = 0;
+ sym->ts.is_c_interop = 0;
+ }
+ else
+ {
+ /* So far, no errors have been found. */
+ sym->attr.is_c_interop = 1;
+ sym->ts.is_c_interop = 1;
+ }
+
+ curr_arg = sym->formal;
+ while (curr_arg != NULL)
+ {
+ /* Skip implicitly typed dummy args here. */
+ if (curr_arg->sym->attr.implicit_type == 0)
+ if (verify_c_interop_param (curr_arg->sym) == FAILURE)
+ /* If something is found to fail, record the fact so we
+ can mark the symbol for the procedure as not being
+ BIND(C) to try and prevent multiple errors being
+ reported. */
+ has_non_interop_arg = 1;
+
+ curr_arg = curr_arg->next;
+ }
+
+ /* See if any of the arguments were not interoperable and if so, clear
+ the procedure symbol to prevent duplicate error messages. */
+ if (has_non_interop_arg != 0)
+ {
+ sym->attr.is_c_interop = 0;
+ sym->ts.is_c_interop = 0;
+ sym->attr.is_bind_c = 0;
+ }
+ }
+
return SUCCESS;
}
}
if (c->ts.type == BT_DERIVED
- && sym->component_access != ACCESS_PRIVATE
- && gfc_check_access(sym->attr.access, sym->ns->default_access)
- && !c->ts.derived->attr.use_assoc
- && !gfc_check_access(c->ts.derived->attr.access,
- c->ts.derived->ns->default_access))
+ && sym->component_access != ACCESS_PRIVATE
+ && gfc_check_access (sym->attr.access, sym->ns->default_access)
+ && !c->ts.derived->attr.use_assoc
+ && !gfc_check_access (c->ts.derived->attr.access,
+ c->ts.derived->ns->default_access))
{
gfc_error ("The component '%s' is a PRIVATE type and cannot be "
"a component of '%s', which is PUBLIC at %L",
- c->name, sym->name, &sym->declared_at);
+ c->name, sym->name, &sym->declared_at);
return FAILURE;
}
}
if (c->ts.type == BT_DERIVED && c->pointer
- && c->ts.derived->components == NULL)
+ && c->ts.derived->components == NULL)
{
gfc_error ("The pointer component '%s' of '%s' at %L is a type "
"that has not been declared", c->name, sym->name,
for (i = 0; i < c->as->rank; i++)
{
if (c->as->lower[i] == NULL
- || !gfc_is_constant_expr (c->as->lower[i])
- || (resolve_index_expr (c->as->lower[i]) == FAILURE)
- || c->as->upper[i] == NULL
- || (resolve_index_expr (c->as->upper[i]) == FAILURE)
- || !gfc_is_constant_expr (c->as->upper[i]))
+ || !gfc_is_constant_expr (c->as->lower[i])
+ || (resolve_index_expr (c->as->lower[i]) == FAILURE)
+ || c->as->upper[i] == NULL
+ || (resolve_index_expr (c->as->upper[i]) == FAILURE)
+ || !gfc_is_constant_expr (c->as->upper[i]))
{
gfc_error ("Component '%s' of '%s' at %L must have "
"constant array bounds",
}
/* Add derived type to the derived type list. */
- for (dt_list = sym->ns->derived_types; dt_list; dt_list = dt_list->next)
+ for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
if (sym == dt_list->derived)
break;
if (dt_list == NULL)
{
dt_list = gfc_get_dt_list ();
- dt_list->next = sym->ns->derived_types;
+ dt_list->next = gfc_derived_types;
dt_list->derived = sym;
- sym->ns->derived_types = dt_list;
+ gfc_derived_types = dt_list;
}
return SUCCESS;
for (nl = sym->namelist; nl; nl = nl->next)
{
if (!nl->sym->attr.use_assoc
- && !(sym->ns->parent == nl->sym->ns)
- && !gfc_check_access(nl->sym->attr.access,
- nl->sym->ns->default_access))
+ && !(sym->ns->parent == nl->sym->ns)
+ && !(sym->ns->parent
+ && sym->ns->parent->parent == nl->sym->ns)
+ && !gfc_check_access(nl->sym->attr.access,
+ nl->sym->ns->default_access))
{
gfc_error ("PRIVATE symbol '%s' cannot be member of "
"PUBLIC namelist at %L", nl->sym->name,
for (nl = sym->namelist; nl; nl = nl->next)
{
if (nl->sym->ts.type == BT_DERIVED
- && nl->sym->ts.derived->attr.alloc_comp)
+ && nl->sym->ts.derived->attr.alloc_comp)
{
gfc_error ("NAMELIST object '%s' at %L cannot have ALLOCATABLE "
"components", nl->sym->name, &sym->declared_at);
}
/* 14.1.2 A module or internal procedure represent local entities
- of the same type as a namelist member and so are not allowed.
- Note that this is sometimes caught by check_conflict so the
- same message has been used. */
+ of the same type as a namelist member and so are not allowed. */
for (nl = sym->namelist; nl; nl = nl->next)
{
if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
continue;
+
+ if (nl->sym->attr.function && nl->sym == nl->sym->result)
+ if ((nl->sym == sym->ns->proc_name)
+ ||
+ (sym->ns->parent && nl->sym == sym->ns->parent->proc_name))
+ continue;
+
nlsym = NULL;
- if (sym->ns->parent && nl->sym && nl->sym->name)
- gfc_find_symbol (nl->sym->name, sym->ns->parent, 0, &nlsym);
+ if (nl->sym && nl->sym->name)
+ gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym);
if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
{
gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
matches the implicit type, since PARAMETER statements can precede
IMPLICIT statements. */
if (sym->attr.implicit_type
- && !gfc_compare_types (&sym->ts,
- gfc_get_default_type (sym, sym->ns)))
+ && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym, sym->ns)))
{
gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
"later IMPLICIT type", sym->name, &sym->declared_at);
type checking is deferred until resolution because the type may
refer to a derived type from the host. */
if (sym->ts.type == BT_DERIVED
- && !gfc_compare_types (&sym->ts, &sym->value->ts))
+ && !gfc_compare_types (&sym->ts, &sym->value->ts))
{
gfc_error ("Incompatible derived type in PARAMETER at %L",
&sym->value->where);
of thing commonly happens for symbols in module. */
static void
-resolve_symbol (gfc_symbol * sym)
+resolve_symbol (gfc_symbol *sym)
{
- /* Zero if we are checking a formal namespace. */
- static int formal_ns_flag = 1;
- int formal_ns_save, check_constant, mp_flag;
+ int check_constant, mp_flag;
gfc_symtree *symtree;
gfc_symtree *this_symtree;
gfc_namespace *ns;
can. */
mp_flag = (sym->result != NULL && sym->result != sym);
+
+ /* Make sure that the intrinsic is consistent with its internal
+ representation. This needs to be done before assigning a default
+ type to avoid spurious warnings. */
+ if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic)
+ {
+ if (gfc_intrinsic_name (sym->name, 0))
+ {
+ if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising)
+ gfc_warning ("Type specified for intrinsic function '%s' at %L is ignored",
+ sym->name, &sym->declared_at);
+ }
+ else if (gfc_intrinsic_name (sym->name, 1))
+ {
+ if (sym->ts.type != BT_UNKNOWN)
+ {
+ gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type specifier",
+ sym->name, &sym->declared_at);
+ return;
+ }
+ }
+ else
+ {
+ gfc_error ("Intrinsic '%s' at %L does not exist", sym->name, &sym->declared_at);
+ return;
+ }
+ }
+
/* Assign default type to symbols that need one and don't have one. */
if (sym->ts.type == BT_UNKNOWN)
{
gfc_set_default_type (sym, sym->attr.external, NULL);
else
{
- /* Result may be in another namespace. */
+ /* Result may be in another namespace. */
resolve_symbol (sym->result);
sym->ts = sym->result->ts;
until resolution time. */
if (!sym->attr.dummy
- && (sym->attr.optional
- || sym->attr.intent != INTENT_UNKNOWN))
+ && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN))
{
gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
return;
if (sym->attr.value && !sym->attr.dummy)
{
gfc_error ("'%s' at %L cannot have the VALUE attribute because "
- "it is not a dummy", sym->name, &sym->declared_at);
+ "it is not a dummy argument", sym->name, &sym->declared_at);
return;
}
+ if (sym->attr.value && sym->ts.type == BT_CHARACTER)
+ {
+ gfc_charlen *cl = sym->ts.cl;
+ if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
+ {
+ gfc_error ("Character dummy variable '%s' at %L with VALUE "
+ "attribute must have constant length",
+ sym->name, &sym->declared_at);
+ return;
+ }
+
+ if (sym->ts.is_c_interop
+ && mpz_cmp_si (cl->length->value.integer, 1) != 0)
+ {
+ gfc_error ("C interoperable character dummy variable '%s' at %L "
+ "with VALUE attribute must have length one",
+ sym->name, &sym->declared_at);
+ return;
+ }
+ }
+
+ /* If the symbol is marked as bind(c), verify it's type and kind. Do not
+ do this for something that was implicitly typed because that is handled
+ in gfc_set_default_type. Handle dummy arguments and procedure
+ definitions separately. Also, anything that is use associated is not
+ handled here but instead is handled in the module it is declared in.
+ Finally, derived type definitions are allowed to be BIND(C) since that
+ only implies that they're interoperable, and they are checked fully for
+ interoperability when a variable is declared of that type. */
+ if (sym->attr.is_bind_c && sym->attr.implicit_type == 0 &&
+ sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
+ sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
+ {
+ try t = SUCCESS;
+
+ /* First, make sure the variable is declared at the
+ module-level scope (J3/04-007, Section 15.3). */
+ if (sym->ns->proc_name->attr.flavor != FL_MODULE &&
+ sym->attr.in_common == 0)
+ {
+ gfc_error ("Variable '%s' at %L cannot be BIND(C) because it "
+ "is neither a COMMON block nor declared at the "
+ "module level scope", sym->name, &(sym->declared_at));
+ t = FAILURE;
+ }
+ else if (sym->common_head != NULL)
+ {
+ t = verify_com_block_vars_c_interop (sym->common_head);
+ }
+ else
+ {
+ /* If type() declaration, we need to verify that the components
+ of the given type are all C interoperable, etc. */
+ if (sym->ts.type == BT_DERIVED &&
+ sym->ts.derived->attr.is_c_interop != 1)
+ {
+ /* Make sure the user marked the derived type as BIND(C). If
+ not, call the verify routine. This could print an error
+ for the derived type more than once if multiple variables
+ of that type are declared. */
+ if (sym->ts.derived->attr.is_bind_c != 1)
+ verify_bind_c_derived_type (sym->ts.derived);
+ t = FAILURE;
+ }
+
+ /* Verify the variable itself as C interoperable if it
+ is BIND(C). It is not possible for this to succeed if
+ the verify_bind_c_derived_type failed, so don't have to handle
+ any error returned by verify_bind_c_derived_type. */
+ t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
+ sym->common_block);
+ }
+
+ if (t == FAILURE)
+ {
+ /* clear the is_bind_c flag to prevent reporting errors more than
+ once if something failed. */
+ sym->attr.is_bind_c = 0;
+ return;
+ }
+ }
/* If a derived type symbol has reached this point, without its
type being declared, we have an error. Notice that most
the type is not declared in the scope of the implicit
statement. Change the type to BT_UNKNOWN, both because it is so
and to prevent an ICE. */
- if (sym->ts.type == BT_DERIVED
- && sym->ts.derived->components == NULL)
+ if (sym->ts.type == BT_DERIVED && sym->ts.derived->components == NULL)
{
gfc_error ("The derived type '%s' at %L is of type '%s', "
"which has not been defined", sym->name,
/* An assumed-size array with INTENT(OUT) shall not be of a type for which
default initialization is defined (5.1.2.4.4). */
if (sym->ts.type == BT_DERIVED
- && sym->attr.dummy
- && sym->attr.intent == INTENT_OUT
- && sym->as
- && sym->as->type == AS_ASSUMED_SIZE)
+ && sym->attr.dummy
+ && sym->attr.intent == INTENT_OUT
+ && sym->as
+ && sym->as->type == AS_ASSUMED_SIZE)
{
for (c = sym->ts.derived->components; c; c = c->next)
{
break;
}
- /* Make sure that intrinsic exist */
- if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
- && ! gfc_intrinsic_name(sym->name, 0)
- && ! gfc_intrinsic_name(sym->name, 1))
- gfc_error("Intrinsic at %L does not exist", &sym->declared_at);
-
/* Resolve array specifier. Check as well some constraints
on COMMON blocks. */
formal_arg_flag = 0;
/* Resolve formal namespaces. */
-
- if (formal_ns_flag && sym != NULL && sym->formal_ns != NULL)
- {
- formal_ns_save = formal_ns_flag;
- formal_ns_flag = 0;
- gfc_resolve (sym->formal_ns);
- formal_ns_flag = formal_ns_save;
- }
+ if (sym->formal_ns && sym->formal_ns != gfc_current_ns)
+ gfc_resolve (sym->formal_ns);
/* Check threadprivate restrictions. */
- if (sym->attr.threadprivate && !sym->attr.save
+ if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
&& (!sym->attr.in_common
- && sym->module == NULL
- && (sym->ns->proc_name == NULL
- || sym->ns->proc_name->attr.flavor != FL_MODULE)))
+ && sym->module == NULL
+ && (sym->ns->proc_name == NULL
+ || sym->ns->proc_name->attr.flavor != FL_MODULE)))
gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
/* If we have come this far we can apply default-initializers, as
described in 14.7.5, to those variables that have not already
been assigned one. */
if (sym->ts.type == BT_DERIVED
- && sym->attr.referenced
- && sym->ns == gfc_current_ns
- && !sym->value
- && !sym->attr.allocatable
- && !sym->attr.alloc_comp)
+ && sym->attr.referenced
+ && sym->ns == gfc_current_ns
+ && !sym->value
+ && !sym->attr.allocatable
+ && !sym->attr.alloc_comp)
{
symbol_attribute *a = &sym->attr;
if ((!a->save && !a->dummy && !a->pointer
- && !a->in_common && !a->use_assoc
- && !(a->function && sym != sym->result))
- ||
- (a->dummy && a->intent == INTENT_OUT))
+ && !a->in_common && !a->use_assoc
+ && !(a->function && sym != sym->result))
+ || (a->dummy && a->intent == INTENT_OUT))
apply_default_init (sym);
}
}
-
/************* Resolve DATA statements *************/
static struct
static try
-check_data_variable (gfc_data_variable * var, locus * where)
+check_data_variable (gfc_data_variable *var, locus *where)
{
gfc_expr *e;
mpz_t size;
gfc_internal_error ("check_data_variable(): Bad expression");
if (e->symtree->n.sym->ns->is_block_data
- && !e->symtree->n.sym->attr.in_common)
+ && !e->symtree->n.sym->attr.in_common)
{
gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
- e->symtree->n.sym->name, &e->symtree->n.sym->declared_at);
+ e->symtree->n.sym->name, &e->symtree->n.sym->declared_at);
}
if (e->rank == 0)
break;
case AR_SECTION:
- ar = &ref->u.ar;
- /* Get the start position of array section. */
- gfc_get_section_index (ar, section_index, &offset);
- mark = AR_SECTION;
+ ar = &ref->u.ar;
+ /* Get the start position of array section. */
+ gfc_get_section_index (ar, section_index, &offset);
+ mark = AR_SECTION;
break;
default:
values.left -= 1;
mpz_sub_ui (size, size, 1);
- gfc_assign_data_value (var->expr, values.vnode->expr, offset);
+ t = gfc_assign_data_value (var->expr, values.vnode->expr, offset);
+ if (t == FAILURE)
+ break;
if (mark == AR_FULL)
mpz_add_ui (offset, offset, 1);
if (mark == AR_SECTION)
{
for (i = 0; i < ar->dimen; i++)
- mpz_clear (section_index[i]);
+ mpz_clear (section_index[i]);
}
mpz_clear (size);
/* Iterate over a list of elements in a DATA statement. */
static try
-traverse_data_list (gfc_data_variable * var, locus * where)
+traverse_data_list (gfc_data_variable *var, locus *where)
{
mpz_t trip;
iterator_stack frame;
step = gfc_copy_expr (var->iter.step);
if (gfc_simplify_expr (start, 1) == FAILURE
- || start->expr_type != EXPR_CONSTANT)
+ || start->expr_type != EXPR_CONSTANT)
{
- gfc_error ("iterator start at %L does not simplify",
- &start->where);
+ gfc_error ("iterator start at %L does not simplify", &start->where);
retval = FAILURE;
goto cleanup;
}
if (gfc_simplify_expr (end, 1) == FAILURE
- || end->expr_type != EXPR_CONSTANT)
+ || end->expr_type != EXPR_CONSTANT)
{
- gfc_error ("iterator end at %L does not simplify",
- &end->where);
+ gfc_error ("iterator end at %L does not simplify", &end->where);
retval = FAILURE;
goto cleanup;
}
if (gfc_simplify_expr (step, 1) == FAILURE
- || step->expr_type != EXPR_CONSTANT)
+ || step->expr_type != EXPR_CONSTANT)
{
- gfc_error ("iterator step at %L does not simplify",
- &step->where);
+ gfc_error ("iterator step at %L does not simplify", &step->where);
retval = FAILURE;
goto cleanup;
}
/* Type resolve variables in the variable list of a DATA statement. */
static try
-traverse_data_var (gfc_data_variable * var, locus * where)
+traverse_data_var (gfc_data_variable *var, locus *where)
{
try t;
only be resolved once. */
static try
-resolve_data_variables (gfc_data_variable * d)
+resolve_data_variables (gfc_data_variable *d)
{
for (; d; d = d->next)
{
}
-/* Determines if a variable is not 'pure', ie not assignable within a pure
- procedure. Returns zero if assignment is OK, nonzero if there is a problem.
- */
+/* 12.6 Constraint: In a pure subprogram any variable which is in common or
+ accessed by host or use association, is a dummy argument to a pure function,
+ is a dummy argument with INTENT (IN) to a pure subroutine, or an object that
+ is storage associated with any such variable, shall not be used in the
+ following contexts: (clients of this function). */
+/* Determines if a variable is not 'pure', ie not assignable within a pure
+ procedure. Returns zero if assignment is OK, nonzero if there is a
+ problem. */
int
-gfc_impure_variable (gfc_symbol * sym)
+gfc_impure_variable (gfc_symbol *sym)
{
+ gfc_symbol *proc;
+
if (sym->attr.use_assoc || sym->attr.in_common)
return 1;
if (sym->ns != gfc_current_ns)
return !sym->attr.function;
- /* TODO: Check storage association through EQUIVALENCE statements */
+ proc = sym->ns->proc_name;
+ if (sym->attr.dummy && gfc_pure (proc)
+ && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN)
+ ||
+ proc->attr.function))
+ return 1;
+ /* TODO: Sort out what can be storage associated, if anything, and include
+ it here. In principle equivalences should be scanned but it does not
+ seem to be possible to storage associate an impure variable this way. */
return 0;
}
symbol of the current procedure. */
int
-gfc_pure (gfc_symbol * sym)
+gfc_pure (gfc_symbol *sym)
{
symbol_attribute attr;
/* Test whether the current procedure is elemental or not. */
int
-gfc_elemental (gfc_symbol * sym)
+gfc_elemental (gfc_symbol *sym)
{
symbol_attribute attr;
/* Warn about unused labels. */
static void
-warn_unused_fortran_label (gfc_st_label * label)
+warn_unused_fortran_label (gfc_st_label *label)
{
if (label == NULL)
return;
case BT_REAL:
if (!(ts.kind == gfc_default_real_kind
- || ts.kind == gfc_default_double_kind))
+ || ts.kind == gfc_default_double_kind))
return SEQ_NONDEFAULT;
return SEQ_NUMERIC;
if (!derived->attr.sequence)
{
gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
- "attribute to be an EQUIVALENCE object", sym->name, &e->where);
+ "attribute to be an EQUIVALENCE object", sym->name,
+ &e->where);
return FAILURE;
}
- /* Shall not have allocatable components. */
+ /* Shall not have allocatable components. */
if (derived->attr.alloc_comp)
{
gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
- "components to be an EQUIVALENCE object",sym->name, &e->where);
+ "components to be an EQUIVALENCE object",sym->name,
+ &e->where);
return FAILURE;
}
for (; c ; c = c->next)
{
d = c->ts.derived;
- if (d && (resolve_equivalence_derived (c->ts.derived, sym, e) == FAILURE))
- return FAILURE;
+ if (d
+ && (resolve_equivalence_derived (c->ts.derived, sym, e) == FAILURE))
+ return FAILURE;
/* Shall not be an object of sequence derived type containing a pointer
- in the structure. */
+ in the structure. */
if (c->pointer)
- {
- gfc_error ("Derived type variable '%s' at %L with pointer component(s) "
- "cannot be an EQUIVALENCE object", sym->name, &e->where);
- return FAILURE;
- }
-
- if (c->initializer)
- {
- gfc_error ("Derived type variable '%s' at %L with default initializer "
- "cannot be an EQUIVALENCE object", sym->name, &e->where);
- return FAILURE;
- }
+ {
+ gfc_error ("Derived type variable '%s' at %L with pointer "
+ "component(s) cannot be an EQUIVALENCE object",
+ sym->name, &e->where);
+ return FAILURE;
+ }
}
return SUCCESS;
}
}
if (gfc_resolve_expr (e) == FAILURE)
- continue;
+ continue;
sym = e->symtree->n.sym;
"PROTECTED attribute",
&e->where);
break;
- }
-
- /* An equivalence statement cannot have more than one initialized
- object. */
- if (sym->value)
- {
- if (value_name != NULL)
- {
- gfc_error ("Initialized objects '%s' and '%s' cannot both "
- "be in the EQUIVALENCE statement at %L",
- value_name, sym->name, &e->where);
- continue;
- }
- else
- value_name = sym->name;
}
/* Shall not equivalence common block variables in a PURE procedure. */
if (sym->ns->proc_name
- && sym->ns->proc_name->attr.pure
- && sym->attr.in_common)
- {
- gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
+ && sym->ns->proc_name->attr.pure
+ && sym->attr.in_common)
+ {
+ gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
"object in the pure procedure '%s'",
sym->name, &e->where, sym->ns->proc_name->name);
- break;
- }
+ break;
+ }
/* Shall not be a named constant. */
if (e->expr_type == EXPR_CONSTANT)
- {
- gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
- "object", sym->name, &e->where);
- continue;
- }
+ {
+ gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
+ "object", sym->name, &e->where);
+ continue;
+ }
derived = e->ts.derived;
if (derived && resolve_equivalence_derived (derived, sym, e) == FAILURE)
- continue;
+ continue;
/* Check that the types correspond correctly:
Note 5.28:
msg = "Sequence %s with mixed components in EQUIVALENCE "
"statement at %L with different type objects";
if ((object ==2
- && last_eq_type == SEQ_MIXED
- && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
- last_where) == FAILURE)
- || (eq_type == SEQ_MIXED
- && gfc_notify_std (GFC_STD_GNU, msg,sym->name,
- &e->where) == FAILURE))
+ && last_eq_type == SEQ_MIXED
+ && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)
+ == FAILURE)
+ || (eq_type == SEQ_MIXED
+ && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
+ &e->where) == FAILURE))
continue;
msg = "Non-default type object or sequence %s in EQUIVALENCE "
"statement at %L with objects of different type";
if ((object ==2
- && last_eq_type == SEQ_NONDEFAULT
- && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
- last_where) == FAILURE)
- || (eq_type == SEQ_NONDEFAULT
- && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
- &e->where) == FAILURE))
+ && last_eq_type == SEQ_NONDEFAULT
+ && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
+ last_where) == FAILURE)
+ || (eq_type == SEQ_NONDEFAULT
+ && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
+ &e->where) == FAILURE))
continue;
msg ="Non-CHARACTER object '%s' in default CHARACTER "
"EQUIVALENCE statement at %L";
if (last_eq_type == SEQ_CHARACTER
- && eq_type != SEQ_CHARACTER
- && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
- &e->where) == FAILURE)
+ && eq_type != SEQ_CHARACTER
+ && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
+ &e->where) == FAILURE)
continue;
msg ="Non-NUMERIC object '%s' in default NUMERIC "
"EQUIVALENCE statement at %L";
if (last_eq_type == SEQ_NUMERIC
- && eq_type != SEQ_NUMERIC
- && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
- &e->where) == FAILURE)
+ && eq_type != SEQ_NUMERIC
+ && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
+ &e->where) == FAILURE)
continue;
identical_types:
last_where = &e->where;
if (!e->ref)
- continue;
+ continue;
/* Shall not be an automatic array. */
if (e->ref->type == REF_ARRAY
- && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
- {
- gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
- "an EQUIVALENCE object", sym->name, &e->where);
- continue;
- }
+ && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
+ {
+ gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
+ "an EQUIVALENCE object", sym->name, &e->where);
+ continue;
+ }
r = e->ref;
while (r)
- {
+ {
/* Shall not be a structure component. */
if (r->type == REF_COMPONENT)
{
}
-/* Resolve function and ENTRY types, issue diagnostics if needed. */
+/* Resolve function and ENTRY types, issue diagnostics if needed. */
static void
-resolve_fntype (gfc_namespace * ns)
+resolve_fntype (gfc_namespace *ns)
{
gfc_entry_list *el;
gfc_symbol *sym;
if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.use_assoc
&& !gfc_check_access (sym->ts.derived->attr.access,
- sym->ts.derived->ns->default_access)
+ sym->ts.derived->ns->default_access)
&& gfc_check_access (sym->attr.access, sym->ns->default_access))
{
gfc_error ("PUBLIC function '%s' at %L cannot be of PRIVATE type '%s'",
- sym->name, &sym->declared_at, sym->ts.derived->name);
- }
-
- /* Make sure that the type of a module derived type function is in the
- module namespace, by copying it from the namespace's derived type
- list, if necessary. */
- if (sym->ts.type == BT_DERIVED
- && sym->ns->proc_name->attr.flavor == FL_MODULE
- && sym->ts.derived->ns
- && sym->ns != sym->ts.derived->ns)
- {
- gfc_dt_list *dt = sym->ns->derived_types;
-
- for (; dt; dt = dt->next)
- if (gfc_compare_derived_types (sym->ts.derived, dt->derived))
- sym->ts.derived = dt->derived;
+ sym->name, &sym->declared_at, sym->ts.derived->name);
}
- if (ns->entries)
+ if (ns->entries)
for (el = ns->entries->next; el; el = el->next)
{
if (el->sym->result == el->sym
/* 12.3.2.1.1 Defined operators. */
static void
-gfc_resolve_uops(gfc_symtree *symtree)
+gfc_resolve_uops (gfc_symtree *symtree)
{
gfc_interface *itr;
gfc_symbol *sym;
{
sym = itr->sym;
if (!sym->attr.function)
- gfc_error("User operator procedure '%s' at %L must be a FUNCTION",
- sym->name, &sym->declared_at);
+ gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
+ sym->name, &sym->declared_at);
if (sym->ts.type == BT_CHARACTER
- && !(sym->ts.cl && sym->ts.cl->length)
- && !(sym->result && sym->result->ts.cl && sym->result->ts.cl->length))
- gfc_error("User operator procedure '%s' at %L cannot be assumed character "
- "length", sym->name, &sym->declared_at);
+ && !(sym->ts.cl && sym->ts.cl->length)
+ && !(sym->result && sym->result->ts.cl
+ && sym->result->ts.cl->length))
+ gfc_error ("User operator procedure '%s' at %L cannot be assumed "
+ "character length", sym->name, &sym->declared_at);
formal = sym->formal;
if (!formal || !formal->sym)
{
- gfc_error("User operator procedure '%s' at %L must have at least "
- "one argument", sym->name, &sym->declared_at);
+ gfc_error ("User operator procedure '%s' at %L must have at least "
+ "one argument", sym->name, &sym->declared_at);
continue;
}
block, which is handled by resolve_code. */
static void
-resolve_types (gfc_namespace * ns)
+resolve_types (gfc_namespace *ns)
{
gfc_namespace *n;
gfc_charlen *cl;
resolve_entries (ns);
+ resolve_common_blocks (ns->common_root);
+
resolve_contained_functions (ns);
+ gfc_traverse_ns (ns, resolve_bind_c_derived_types);
+
+ for (cl = ns->cl_list; cl; cl = cl->next)
+ resolve_charlen (cl);
+
gfc_traverse_ns (ns, resolve_symbol);
resolve_fntype (ns);
forall_flag = 0;
gfc_check_interfaces (ns);
- for (cl = ns->cl_list; cl; cl = cl->next)
- resolve_charlen (cl);
-
gfc_traverse_ns (ns, resolve_values);
if (ns->save_all)
iter_stack = NULL;
gfc_traverse_ns (ns, gfc_formalize_init_value);
+ gfc_traverse_ns (ns, gfc_verify_binding_labels);
+
+ if (ns->common_root != NULL)
+ gfc_traverse_symtree (ns->common_root, resolve_bind_c_comms);
+
for (eq = ns->equiv; eq; eq = eq->next)
resolve_equivalence (eq);
/* Call resolve_code recursively. */
static void
-resolve_codes (gfc_namespace * ns)
+resolve_codes (gfc_namespace *ns)
{
gfc_namespace *n;
cs_base = NULL;
/* Set to an out of range value. */
current_entry_id = -1;
+
+ bitmap_obstack_initialize (&labels_obstack);
resolve_code (ns->code, ns);
+ bitmap_obstack_release (&labels_obstack);
}
which functions or subroutines. */
void
-gfc_resolve (gfc_namespace * ns)
+gfc_resolve (gfc_namespace *ns)
{
gfc_namespace *old_ns;
OSDN Git Service
