-/* Perform type resolution on the various stuctures.
+/* Perform type resolution on the various structures.
Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
Free Software Foundation, Inc.
Contributed by Andy Vaught
static void
resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
{
- try t;
+ gfc_try t;
/* If this namespace is not a function or an entry master function,
ignore it. */
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))))
+ && (!c->attr.pointer && has_default_initializer (c->ts.derived))))
break;
return c != NULL;
/* Resolve all of the elements of a structure constructor and make sure that
the types are correct. */
-static try
+static gfc_try
resolve_structure_cons (gfc_expr *expr)
{
gfc_constructor *cons;
gfc_component *comp;
- try t;
+ gfc_try t;
symbol_attribute a;
t = SUCCESS;
rank = comp->as ? comp->as->rank : 0;
if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
- && (comp->allocatable || cons->expr->rank))
+ && (comp->attr.allocatable || cons->expr->rank))
{
gfc_error ("The rank of the element in the derived type "
"constructor at %L does not match that of the "
if (!gfc_compare_types (&cons->expr->ts, &comp->ts))
{
t = FAILURE;
- if (comp->pointer && cons->expr->ts.type != BT_UNKNOWN)
+ if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
gfc_error ("The element in the derived type constructor at %L, "
"for pointer component '%s', is %s but should be %s",
&cons->expr->where, comp->name,
}
if (cons->expr->expr_type == EXPR_NULL
- && !(comp->pointer || comp->allocatable))
+ && !(comp->attr.pointer || comp->attr.allocatable))
{
t = FAILURE;
gfc_error ("The NULL in the derived type constructor at %L is "
comp->name);
}
- if (!comp->pointer || cons->expr->expr_type == EXPR_NULL)
+ if (!comp->attr.pointer || cons->expr->expr_type == EXPR_NULL)
continue;
a = gfc_expr_attr (cons->expr);
that look like procedure arguments are really simple variable
references. */
-static try
+static gfc_try
resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype)
{
gfc_symbol *sym;
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))
+ && gfc_is_intrinsic (sym, sym->attr.subroutine, e->where))
sym->attr.intrinsic = 1;
if (sym->attr.proc == PROC_ST_FUNCTION)
procedures. If called with c == NULL, we have a function, otherwise if
expr == NULL, we have a subroutine. */
-static try
+static gfc_try
resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
{
gfc_actual_arglist *arg0;
}
-static try
+static gfc_try
resolve_generic_f (gfc_expr *expr)
{
gfc_symbol *sym;
/* Last ditch attempt. See if the reference is to an intrinsic
that possesses a matching interface. 14.1.2.4 */
- if (sym && !gfc_intrinsic_name (sym->name, 0))
+ if (sym && !gfc_is_intrinsic (sym, 0, expr->where))
{
gfc_error ("There is no specific function for the generic '%s' at %L",
expr->symtree->n.sym->name, &expr->where);
gfc_intrinsic_sym *isym;
isym = gfc_find_function (sym->ts.interface->name);
- /* Existance of isym should be checked already. */
+ /* Existence of isym should be checked already. */
gcc_assert (isym);
sym->ts.type = isym->ts.type;
}
-static try
+static gfc_try
resolve_specific_f (gfc_expr *expr)
{
gfc_symbol *sym;
/* Resolve a procedure call not known to be generic nor specific. */
-static try
+static gfc_try
resolve_unknown_f (gfc_expr *expr)
{
gfc_symbol *sym;
/* See if we have an intrinsic function reference. */
- if (gfc_intrinsic_name (sym->name, 0))
+ if (gfc_is_intrinsic (sym, 0, expr->where))
{
if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
return SUCCESS;
{
if (!sym->attr.dummy && !sym->attr.contained
&& !(sym->attr.intrinsic
- || gfc_intrinsic_name (sym->name, sym->attr.subroutine))
+ || gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at))
&& sym->attr.proc != PROC_ST_FUNCTION
&& !sym->attr.use_assoc
&& sym->name)
return true;
- else
- return false;
+
+ return false;
}
}
-static try
+static gfc_try
is_scalar_expr_ptr (gfc_expr *expr)
{
- try retval = SUCCESS;
+ gfc_try retval = SUCCESS;
gfc_ref *ref;
int start;
int end;
and, in the case of c_associated, set the binding label based on
the arguments. */
-static try
+static gfc_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_try retval = SUCCESS;
gfc_symbol *args_sym;
gfc_typespec *arg_ts;
gfc_ref *parent_ref;
if (!(args_sym->attr.target)
&& !(args_sym->attr.pointer)
&& (parent_ref == NULL ||
- !parent_ref->u.c.component->pointer))
+ !parent_ref->u.c.component->attr.pointer))
{
gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
"a TARGET or an associated pointer",
}
else if ((args_sym->attr.pointer == 1 ||
(parent_ref != NULL
- && parent_ref->u.c.component->pointer))
+ && parent_ref->u.c.component->attr.pointer))
&& is_scalar_expr_ptr (args->expr) != SUCCESS)
{
/* Case 1c, section 15.1.2.5, J3/04-007: an associated
/* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
to INTENT(OUT) or INTENT(INOUT). */
-static try
+static gfc_try
resolve_function (gfc_expr *expr)
{
gfc_actual_arglist *arg;
gfc_symbol *sym;
const char *name;
- try t;
+ gfc_try t;
int temp;
procedure_type p = PROC_INTRINSIC;
}
-static try
+static gfc_try
resolve_generic_s (gfc_code *c)
{
gfc_symbol *sym;
that possesses a matching interface. 14.1.2.4 */
sym = c->symtree->n.sym;
- if (!gfc_intrinsic_name (sym->name, 1))
+ if (!gfc_is_intrinsic (sym, 1, c->loc))
{
gfc_error ("There is no specific subroutine for the generic '%s' at %L",
sym->name, &c->loc);
isym = gfc_find_function (sym->ts.interface->name);
- /* Existance of isym should be checked already. */
+ /* Existence of isym should be checked already. */
gcc_assert (isym);
sym->ts.type = isym->ts.type;
}
-static try
+static gfc_try
resolve_specific_s (gfc_code *c)
{
gfc_symbol *sym;
/* Resolve a subroutine call not known to be generic nor specific. */
-static try
+static gfc_try
resolve_unknown_s (gfc_code *c)
{
gfc_symbol *sym;
/* See if we have an intrinsic function reference. */
- if (gfc_intrinsic_name (sym->name, 1))
+ if (gfc_is_intrinsic (sym, 1, c->loc))
{
if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
return SUCCESS;
for functions, subroutines and functions are stored differently and this
makes things awkward. */
-static try
+static gfc_try
resolve_call (gfc_code *c)
{
- try t;
+ gfc_try t;
procedure_type ptype = PROC_INTRINSIC;
if (c->symtree && c->symtree->n.sym
if their shapes do not match. If either op1->shape or op2->shape is
NULL, return SUCCESS. */
-static try
+static gfc_try
compare_shapes (gfc_expr *op1, gfc_expr *op2)
{
- try t;
+ gfc_try t;
int i;
t = SUCCESS;
/* Resolve an operator expression node. This can involve replacing the
operation with a user defined function call. */
-static try
+static gfc_try
resolve_operator (gfc_expr *e)
{
gfc_expr *op1, *op2;
char msg[200];
bool dual_locus_error;
- try t;
+ gfc_try t;
/* Resolve all subnodes-- give them types. */
- switch (e->value.op.operator)
+ switch (e->value.op.op)
{
default:
if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
goto bad_op;
}
- switch (e->value.op.operator)
+ switch (e->value.op.op)
{
case INTRINSIC_UPLUS:
case INTRINSIC_UMINUS:
}
sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
- gfc_op2string (e->value.op.operator), gfc_typename (&e->ts));
+ gfc_op2string (e->value.op.op), gfc_typename (&e->ts));
goto bad_op;
case INTRINSIC_PLUS:
sprintf (msg,
_("Operands of binary numeric operator '%s' at %%L are %s/%s"),
- gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
+ gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
gfc_typename (&op2->ts));
goto bad_op;
}
sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
- gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
+ gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
gfc_typename (&op2->ts));
goto bad_op;
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
- || e->value.op.operator == INTRINSIC_EQ_OS)
- ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.operator));
+ (e->value.op.op == INTRINSIC_EQ
+ || e->value.op.op == INTRINSIC_EQ_OS)
+ ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op));
else
sprintf (msg,
_("Operands of comparison operator '%s' at %%L are %s/%s"),
- gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
+ gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
gfc_typename (&op2->ts));
goto bad_op;
case INTRINSIC_USER:
- if (e->value.op.uop->operator == NULL)
+ if (e->value.op.uop->op == 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"),
t = SUCCESS;
- switch (e->value.op.operator)
+ switch (e->value.op.op)
{
case INTRINSIC_PLUS:
case INTRINSIC_MINUS:
{
t = gfc_simplify_expr (e, 0);
/* Some calls do not succeed in simplification and return FAILURE
- even though there is no error; eg. variable references to
+ even though there is no error; e.g. variable references to
PARAMETER arrays. */
if (!gfc_is_constant_expr (e))
t = SUCCESS;
/* Compare a single dimension of an array reference to the array
specification. */
-static try
+static gfc_try
check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
{
mpz_t last_value;
/* Compare an array reference with an array specification. */
-static try
+static gfc_try
compare_spec_to_ref (gfc_array_ref *ar)
{
gfc_array_spec *as;
/* Resolve one part of an array index. */
-try
+gfc_try
gfc_resolve_index (gfc_expr *index, int check_scalar)
{
gfc_typespec ts;
/* Resolve a dim argument to an intrinsic function. */
-try
+gfc_try
gfc_resolve_dim_arg (gfc_expr *dim)
{
if (dim == NULL)
if (c == NULL)
gfc_internal_error ("find_array_spec(): Component not found");
- if (c->dimension)
+ if (c->attr.dimension)
{
if (as != NULL)
gfc_internal_error ("find_array_spec(): unused as(1)");
/* Resolve an array reference. */
-static try
+static gfc_try
resolve_array_ref (gfc_array_ref *ar)
{
int i, check_scalar;
}
-static try
+static gfc_try
resolve_substring (gfc_ref *ref)
{
if (ref->u.ss.start != NULL)
/* Resolve subtype references. */
-static try
+static gfc_try
resolve_ref (gfc_expr *expr)
{
int current_part_dimension, n_components, seen_part_dimension;
case REF_COMPONENT:
if (current_part_dimension || seen_part_dimension)
{
- if (ref->u.c.component->pointer)
+ if (ref->u.c.component->attr.pointer)
{
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)
+ else if (ref->u.c.component->attr.allocatable)
{
gfc_error ("Component to the right of a part reference "
"with nonzero rank must not have the ALLOCATABLE "
/* Resolve a variable expression. */
-static try
+static gfc_try
resolve_variable (gfc_expr *e)
{
gfc_symbol *sym;
- try t;
+ gfc_try t;
t = SUCCESS;
gfc_expr *e1 = NULL;
gfc_expr *e2 = NULL;
- gcc_assert (e->value.op.operator == INTRINSIC_CONCAT);
+ gcc_assert (e->value.op.op == INTRINSIC_CONCAT);
if (op1->ts.cl && op1->ts.cl->length)
e1 = gfc_copy_expr (op1->ts.cl->length);
with their operators, intrinsic operators are converted to function calls
for overloaded types and unresolved function references are resolved. */
-try
+gfc_try
gfc_resolve_expr (gfc_expr *e)
{
- try t;
+ gfc_try t;
if (e == NULL)
return SUCCESS;
/* 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);
+ if (t == SUCCESS && e->ts.type == BT_CHARACTER)
+ t = gfc_resolve_character_array_constructor (e);
break;
/* Resolve an expression from an iterator. They must be scalar and have
INTEGER or (optionally) REAL type. */
-static try
+static gfc_try
gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok,
const char *name_msgid)
{
/* Resolve the expressions in an iterator structure. If REAL_OK is
false allow only INTEGER type iterators, otherwise allow REAL types. */
-try
+gfc_try
gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
{
if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
/* Check whether the FORALL index appears in the expression or not.
Returns SUCCESS if SYM is found in EXPR. */
-try
+gfc_try
find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f)
{
if (gfc_traverse_expr (expr, sym, forall_index, f))
/* Resolve the argument of a deallocate expression. The expression must be
a pointer or a full array. */
-static try
+static gfc_try
resolve_deallocate_expr (gfc_expr *e)
{
symbol_attribute attr;
case REF_COMPONENT:
allocatable = (ref->u.c.component->as != NULL
&& ref->u.c.component->as->type == AS_DEFERRED);
- pointer = ref->u.c.component->pointer;
+ pointer = ref->u.c.component->attr.pointer;
break;
case REF_SUBSTRING:
return false;
}
-static bool
-find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
+bool
+gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
{
return gfc_traverse_expr (e, sym, sym_in_expr, 0);
}
checks to see whether the expression is OK or not. The expression must
have a trailing array reference that gives the size of the array. */
-static try
+static gfc_try
resolve_allocate_expr (gfc_expr *e, gfc_code *code)
{
int i, pointer, allocatable, dimension, check_intent_in;
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;
+ pointer = ref->u.c.component->attr.pointer;
+ dimension = ref->u.c.component->attr.dimension;
break;
case REF_SUBSTRING:
if (sym->ts.type == BT_DERIVED)
continue;
- if ((ar->start[i] != NULL && find_sym_in_expr (sym, ar->start[i]))
- || (ar->end[i] != NULL && find_sym_in_expr (sym, ar->end[i])))
+ if ((ar->start[i] != NULL
+ && gfc_find_sym_in_expr (sym, ar->start[i]))
+ || (ar->end[i] != NULL
+ && gfc_find_sym_in_expr (sym, ar->end[i])))
{
- gfc_error ("'%s' must not appear an the array specification at "
+ gfc_error ("'%s' must not appear in the array specification at "
"%L in the same ALLOCATE statement where it is "
"itself allocated", sym->name, &ar->where);
return FAILURE;
Makes sure that all case expressions are scalar constants of the same
type. Return FAILURE if anything is wrong. */
-static try
+static gfc_try
validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr)
{
if (e == NULL) return SUCCESS;
int seen_logical;
int ncases;
bt type;
- try t;
+ gfc_try t;
if (code->expr == NULL)
{
/* Check whether EXPR1 has the same shape as EXPR2. */
-static try
+static gfc_try
resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
{
mpz_t shape[GFC_MAX_DIMENSIONS];
mpz_t shape2[GFC_MAX_DIMENSIONS];
- try result = FAILURE;
+ gfc_try result = FAILURE;
int i;
/* Compare the rank. */
void
gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
{
- try t;
+ gfc_try t;
for (; b; b = b->block)
{
case EXEC_OMP_PARALLEL_WORKSHARE:
case EXEC_OMP_SECTIONS:
case EXEC_OMP_SINGLE:
+ case EXEC_OMP_TASK:
+ case EXEC_OMP_TASKWAIT:
case EXEC_OMP_WORKSHARE:
break;
/* Does everything to resolve an ordinary assignment. Returns true
- if this is an interface asignment. */
+ if this is an interface assignment. */
static bool
resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
{
{
for (n = 0; n < ref->u.ar.dimen; n++)
if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR
- && find_sym_in_expr (lhs->symtree->n.sym,
- ref->u.ar.start[n]))
+ && gfc_find_sym_in_expr (lhs->symtree->n.sym,
+ ref->u.ar.start[n]))
ref->u.ar.start[n]
= gfc_get_parentheses (ref->u.ar.start[n]);
}
int omp_workshare_save;
int forall_save;
code_stack frame;
- try t;
+ gfc_try t;
frame.prev = cs_base;
frame.head = code;
case EXEC_OMP_PARALLEL:
case EXEC_OMP_PARALLEL_DO:
case EXEC_OMP_PARALLEL_SECTIONS:
+ case EXEC_OMP_TASK:
omp_workshare_save = omp_workshare_flag;
omp_workshare_flag = 0;
gfc_resolve_omp_parallel_blocks (code, ns);
case EXEC_OMP_ORDERED:
case EXEC_OMP_SECTIONS:
case EXEC_OMP_SINGLE:
+ case EXEC_OMP_TASKWAIT:
case EXEC_OMP_WORKSHARE:
gfc_resolve_omp_directive (code, ns);
break;
case EXEC_OMP_PARALLEL_DO:
case EXEC_OMP_PARALLEL_SECTIONS:
case EXEC_OMP_PARALLEL_WORKSHARE:
+ case EXEC_OMP_TASK:
omp_workshare_save = omp_workshare_flag;
omp_workshare_flag = 0;
gfc_resolve_omp_directive (code, ns);
/* Resolve an index expression. */
-static try
+static gfc_try
resolve_index_expr (gfc_expr *e)
{
if (gfc_resolve_expr (e) == FAILURE)
/* Resolve a charlen structure. */
-static try
+static gfc_try
resolve_charlen (gfc_charlen *cl)
{
int i;
/* Resolution of common features of flavors variable and procedure. */
-static try
+static gfc_try
resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
{
/* Constraints on deferred shape variable. */
/* Additional checks for symbols with flavor variable and derived
type. To be called from resolve_fl_variable. */
-static try
+static gfc_try
resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
{
gcc_assert (sym->ts.type == BT_DERIVED);
/* Resolve symbols with flavor variable. */
-static try
+static gfc_try
resolve_fl_variable (gfc_symbol *sym, int mp_flag)
{
int no_init_flag, automatic_flag;
/* Resolve a procedure. */
-static try
+static gfc_try
resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
{
gfc_formal_arglist *arg;
}
/* 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
+ module procedures are excluded by 2.2.3.3 - i.e., they are not
externally accessible and can access all the objects accessible in
the host. */
if (!(sym->ns->parent
}
}
- if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION)
+ if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
+ && !sym->attr.proc_pointer)
{
gfc_error ("Function '%s' at %L cannot have an initializer",
sym->name, &sym->declared_at);
}
/* An external symbol may not have an initializer because it is taken to be
- a procedure. */
- if (sym->attr.external && sym->value)
+ a procedure. Exception: Procedure Pointers. */
+ if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
{
gfc_error ("External object '%s' at %L may not have an initializer",
sym->name, &sym->declared_at);
}
}
+ if (sym->attr.save == SAVE_EXPLICIT && !sym->attr.proc_pointer)
+ {
+ gfc_error ("PROCEDURE attribute conflicts with SAVE attribute "
+ "in '%s' at %L", sym->name, &sym->declared_at);
+ return FAILURE;
+ }
+
+ if (sym->attr.intent && !sym->attr.proc_pointer)
+ {
+ gfc_error ("PROCEDURE attribute conflicts with INTENT attribute "
+ "in '%s' at %L", sym->name, &sym->declared_at);
+ return FAILURE;
+ }
+
return SUCCESS;
}
been defined and we now know their defined arguments, check that they fulfill
the requirements of the standard for procedures used as finalizers. */
-static try
+static gfc_try
gfc_resolve_finalizers (gfc_symbol* derived)
{
gfc_finalizer* list;
gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
- try result = SUCCESS;
+ gfc_try result = SUCCESS;
bool seen_scalar = false;
if (!derived->f2k_derived || !derived->f2k_derived->finalizers)
gfc_finalizer* i;
int my_rank;
+ /* Skip this finalizer if we already resolved it. */
+ if (list->proc_tree)
+ {
+ prev_link = &(list->next);
+ continue;
+ }
+
/* Check this exists and is a SUBROUTINE. */
- if (!list->procedure->attr.subroutine)
+ if (!list->proc_sym->attr.subroutine)
{
gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
- list->procedure->name, &list->where);
+ list->proc_sym->name, &list->where);
goto error;
}
/* We should have exactly one argument. */
- if (!list->procedure->formal || list->procedure->formal->next)
+ if (!list->proc_sym->formal || list->proc_sym->formal->next)
{
gfc_error ("FINAL procedure at %L must have exactly one argument",
&list->where);
goto error;
}
- arg = list->procedure->formal->sym;
+ arg = list->proc_sym->formal->sym;
/* This argument must be of our type. */
if (arg->ts.type != BT_DERIVED || arg->ts.derived != derived)
{
/* Argument list might be empty; that is an error signalled earlier,
but we nevertheless continued resolving. */
- if (i->procedure->formal)
+ if (i->proc_sym->formal)
{
- gfc_symbol* i_arg = i->procedure->formal->sym;
+ gfc_symbol* i_arg = i->proc_sym->formal->sym;
const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
if (i_rank == my_rank)
{
gfc_error ("FINAL procedure '%s' declared at %L has the same"
" rank (%d) as '%s'",
- list->procedure->name, &list->where, my_rank,
- i->procedure->name);
+ list->proc_sym->name, &list->where, my_rank,
+ i->proc_sym->name);
goto error;
}
}
if (!arg->as || arg->as->rank == 0)
seen_scalar = true;
+ /* Find the symtree for this procedure. */
+ gcc_assert (!list->proc_tree);
+ list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
+
prev_link = &list->next;
continue;
- /* Remove wrong nodes immediatelly from the list so we don't risk any
+ /* Remove wrong nodes immediately from the list so we don't risk any
troubles in the future when they might fail later expectations. */
error:
result = FAILURE;
derived->name, &derived->declared_at);
/* TODO: Remove this error when finalization is finished. */
- gfc_error ("Finalization at %L is not yet implemented", &derived->declared_at);
+ gfc_error ("Finalization at %L is not yet implemented",
+ &derived->declared_at);
return result;
}
+/* Add a derived type to the dt_list. The dt_list is used in trans-types.c
+ to give all identical derived types the same backend_decl. */
+static void
+add_dt_to_dt_list (gfc_symbol *derived)
+{
+ gfc_dt_list *dt_list;
+
+ for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
+ if (derived == dt_list->derived)
+ break;
+
+ if (dt_list == NULL)
+ {
+ dt_list = gfc_get_dt_list ();
+ dt_list->next = gfc_derived_types;
+ dt_list->derived = derived;
+ gfc_derived_types = dt_list;
+ }
+}
+
+
/* Resolve the components of a derived type. */
-static try
+static gfc_try
resolve_fl_derived (gfc_symbol *sym)
{
gfc_component *c;
- gfc_dt_list * dt_list;
int i;
for (c = sym->components; c != NULL; c = c->next)
}
}
- if (c->ts.type == BT_DERIVED && c->pointer
- && c->ts.derived->components == NULL)
+ if (c->ts.type == BT_DERIVED && c->attr.pointer
+ && c->ts.derived->components == NULL
+ && !c->ts.derived->attr.zero_comp)
{
gfc_error ("The pointer component '%s' of '%s' at %L is a type "
"that has not been declared", c->name, sym->name,
return FAILURE;
}
- if (c->pointer || c->allocatable || c->as == NULL)
+ /* Ensure that all the derived type components are put on the
+ derived type list; even in formal namespaces, where derived type
+ pointer components might not have been declared. */
+ if (c->ts.type == BT_DERIVED
+ && c->ts.derived
+ && c->ts.derived->components
+ && c->attr.pointer
+ && sym != c->ts.derived)
+ add_dt_to_dt_list (c->ts.derived);
+
+ if (c->attr.pointer || c->attr.allocatable || c->as == NULL)
continue;
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)
+ || !gfc_is_constant_expr (c->as->lower[i])
|| c->as->upper[i] == NULL
|| (resolve_index_expr (c->as->upper[i]) == FAILURE)
|| !gfc_is_constant_expr (c->as->upper[i]))
return FAILURE;
/* Add derived type to the derived type list. */
- 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 = gfc_derived_types;
- dt_list->derived = sym;
- gfc_derived_types = dt_list;
- }
+ add_dt_to_dt_list (sym);
return SUCCESS;
}
-static try
+static gfc_try
resolve_fl_namelist (gfc_symbol *sym)
{
gfc_namelist *nl;
}
-static try
+static gfc_try
resolve_fl_parameter (gfc_symbol *sym)
{
/* A parameter array's shape needs to be constant. */
sym->ts.interface = ifc;
sym->attr.function = ifc->attr.function;
sym->attr.subroutine = ifc->attr.subroutine;
+ sym->attr.allocatable = ifc->attr.allocatable;
+ sym->attr.pointer = ifc->attr.pointer;
+ sym->attr.pure = ifc->attr.pure;
+ sym->attr.elemental = ifc->attr.elemental;
+ sym->attr.dimension = ifc->attr.dimension;
+ sym->attr.recursive = ifc->attr.recursive;
+ sym->attr.always_explicit = ifc->attr.always_explicit;
+ sym->as = gfc_copy_array_spec (ifc->as);
copy_formal_args (sym, ifc);
}
else if (sym->ts.interface->name[0] != '\0')
type to avoid spurious warnings. */
if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic)
{
- if (gfc_intrinsic_name (sym->name, 0))
+ gfc_intrinsic_sym* isym;
+ const char* symstd;
+
+ /* We already know this one is an intrinsic, so we don't call
+ gfc_is_intrinsic for full checking but rather use gfc_find_function and
+ gfc_find_subroutine directly to check whether it is a function or
+ subroutine. */
+
+ if ((isym = gfc_find_function (sym->name)))
{
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);
+ 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))
+ else if ((isym = gfc_find_subroutine (sym->name)))
{
if (sym->ts.type != BT_UNKNOWN)
{
- gfc_error ("Intrinsic subroutine '%s' at %L shall not have a type specifier",
- sym->name, &sym->declared_at);
+ 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);
+ gfc_error ("'%s' declared INTRINSIC at %L does not exist",
+ sym->name, &sym->declared_at);
+ return;
+ }
+
+ /* Check it is actually available in the standard settings. */
+ if (gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at)
+ == FAILURE)
+ {
+ gfc_error ("The intrinsic '%s' declared INTRINSIC at %L is not"
+ " available in the current standard settings but %s. Use"
+ " an appropriate -std=* option or enable -fall-intrinsics"
+ " in order to use it.",
+ sym->name, &sym->declared_at, symstd);
return;
}
}
sym->attr.use_assoc == 0 && sym->attr.dummy == 0 &&
sym->attr.flavor != FL_PROCEDURE && sym->attr.flavor != FL_DERIVED)
{
- try t = SUCCESS;
+ gfc_try t = SUCCESS;
/* First, make sure the variable is declared at the
module-level scope (J3/04-007, Section 15.3). */
/* Advance the values structure to point to the next value in the data list. */
-static try
+static gfc_try
next_data_value (void)
{
}
-static try
+static gfc_try
check_data_variable (gfc_data_variable *var, locus *where)
{
gfc_expr *e;
mpz_t size;
mpz_t offset;
- try t;
+ gfc_try t;
ar_type mark = AR_UNKNOWN;
int i;
mpz_t section_index[GFC_MAX_DIMENSIONS];
}
-static try traverse_data_var (gfc_data_variable *, locus *);
+static gfc_try traverse_data_var (gfc_data_variable *, locus *);
/* Iterate over a list of elements in a DATA statement. */
-static try
+static gfc_try
traverse_data_list (gfc_data_variable *var, locus *where)
{
mpz_t trip;
iterator_stack frame;
gfc_expr *e, *start, *end, *step;
- try retval = SUCCESS;
+ gfc_try retval = SUCCESS;
mpz_init (frame.value);
/* Type resolve variables in the variable list of a DATA statement. */
-static try
+static gfc_try
traverse_data_var (gfc_data_variable *var, locus *where)
{
- try t;
+ gfc_try t;
for (; var; var = var->next)
{
This is separate from the assignment checking because data lists should
only be resolved once. */
-static try
+static gfc_try
resolve_data_variables (gfc_data_variable *d)
{
for (; d; d = d->next)
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
+/* Determines if a variable is not 'pure', i.e., not assignable within a pure
procedure. Returns zero if assignment is OK, nonzero if there is a
problem. */
int
/* Resolve derived type EQUIVALENCE object. */
-static try
+static gfc_try
resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
{
gfc_symbol *d;
/* Shall not be an object of sequence derived type containing a pointer
in the structure. */
- if (c->pointer)
+ if (c->attr.pointer)
{
gfc_error ("Derived type variable '%s' at %L with pointer "
"component(s) cannot be an EQUIVALENCE object",
sym = e->symtree->n.sym;
- if (sym->attr.protected)
+ if (sym->attr.is_protected)
cnt_protected++;
if (cnt_protected > 0 && cnt_protected != object)
{
gfc_resolve_uops (symtree->left);
gfc_resolve_uops (symtree->right);
- for (itr = symtree->n.uop->operator; itr; itr = itr->next)
+ for (itr = symtree->n.uop->op; itr; itr = itr->next)
{
sym = itr->sym;
if (!sym->attr.function)
OSDN Git Service
