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. */
/* 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;
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);
}
-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;
/* 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);
}
-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. */
/* 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)
/* 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;
/* Resolve a variable expression. */
-static try
+static gfc_try
resolve_variable (gfc_expr *e)
{
gfc_symbol *sym;
- try t;
+ gfc_try t;
t = SUCCESS;
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;
/* 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;
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;
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)
{
int omp_workshare_save;
int forall_save;
code_stack frame;
- try t;
+ gfc_try t;
frame.prev = cs_base;
frame.head = code;
/* 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;
}
}
+ 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;
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;
}
/* Resolve the components of a derived type. */
-static try
+static gfc_try
resolve_fl_derived (gfc_symbol *sym)
{
gfc_component *c;
}
-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. */
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)
/* 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;
OSDN Git Service
