1 /* Perform type resolution on the various stuctures.
2 Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation,
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor,Boston, MA
28 #include "arith.h" /* For gfc_compare_expr(). */
29 #include "dependency.h"
31 /* Types used in equivalence statements. */
35 SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
39 /* Stack to push the current if we descend into a block during
40 resolution. See resolve_branch() and resolve_code(). */
42 typedef struct code_stack
44 struct gfc_code *head, *current;
45 struct code_stack *prev;
49 static code_stack *cs_base = NULL;
52 /* Nonzero if we're inside a FORALL block. */
54 static int forall_flag;
56 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
58 static int omp_workshare_flag;
60 /* Nonzero if we are processing a formal arglist. The corresponding function
61 resets the flag each time that it is read. */
62 static int formal_arg_flag = 0;
64 /* True if we are resolving a specification expression. */
65 static int specification_expr = 0;
67 /* The id of the last entry seen. */
68 static int current_entry_id;
71 gfc_is_formal_arg (void)
73 return formal_arg_flag;
76 /* Resolve types of formal argument lists. These have to be done early so that
77 the formal argument lists of module procedures can be copied to the
78 containing module before the individual procedures are resolved
79 individually. We also resolve argument lists of procedures in interface
80 blocks because they are self-contained scoping units.
82 Since a dummy argument cannot be a non-dummy procedure, the only
83 resort left for untyped names are the IMPLICIT types. */
86 resolve_formal_arglist (gfc_symbol * proc)
88 gfc_formal_arglist *f;
92 if (proc->result != NULL)
97 if (gfc_elemental (proc)
98 || sym->attr.pointer || sym->attr.allocatable
99 || (sym->as && sym->as->rank > 0))
100 proc->attr.always_explicit = 1;
104 for (f = proc->formal; f; f = f->next)
110 /* Alternate return placeholder. */
111 if (gfc_elemental (proc))
112 gfc_error ("Alternate return specifier in elemental subroutine "
113 "'%s' at %L is not allowed", proc->name,
115 if (proc->attr.function)
116 gfc_error ("Alternate return specifier in function "
117 "'%s' at %L is not allowed", proc->name,
122 if (sym->attr.if_source != IFSRC_UNKNOWN)
123 resolve_formal_arglist (sym);
125 if (sym->attr.subroutine || sym->attr.external || sym->attr.intrinsic)
127 if (gfc_pure (proc) && !gfc_pure (sym))
130 ("Dummy procedure '%s' of PURE procedure at %L must also "
131 "be PURE", sym->name, &sym->declared_at);
135 if (gfc_elemental (proc))
138 ("Dummy procedure at %L not allowed in ELEMENTAL procedure",
146 if (sym->ts.type == BT_UNKNOWN)
148 if (!sym->attr.function || sym->result == sym)
149 gfc_set_default_type (sym, 1, sym->ns);
152 gfc_resolve_array_spec (sym->as, 0);
154 /* We can't tell if an array with dimension (:) is assumed or deferred
155 shape until we know if it has the pointer or allocatable attributes.
157 if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
158 && !(sym->attr.pointer || sym->attr.allocatable))
160 sym->as->type = AS_ASSUMED_SHAPE;
161 for (i = 0; i < sym->as->rank; i++)
162 sym->as->lower[i] = gfc_int_expr (1);
165 if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
166 || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
167 || sym->attr.optional)
168 proc->attr.always_explicit = 1;
170 /* If the flavor is unknown at this point, it has to be a variable.
171 A procedure specification would have already set the type. */
173 if (sym->attr.flavor == FL_UNKNOWN)
174 gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
178 if (proc->attr.function && !sym->attr.pointer
179 && sym->attr.flavor != FL_PROCEDURE
180 && sym->attr.intent != INTENT_IN)
182 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
183 "INTENT(IN)", sym->name, proc->name,
186 if (proc->attr.subroutine && !sym->attr.pointer
187 && sym->attr.intent == INTENT_UNKNOWN)
190 ("Argument '%s' of pure subroutine '%s' at %L must have "
191 "its INTENT specified", sym->name, proc->name,
196 if (gfc_elemental (proc))
201 ("Argument '%s' of elemental procedure at %L must be scalar",
202 sym->name, &sym->declared_at);
206 if (sym->attr.pointer)
209 ("Argument '%s' of elemental procedure at %L cannot have "
210 "the POINTER attribute", sym->name, &sym->declared_at);
215 /* Each dummy shall be specified to be scalar. */
216 if (proc->attr.proc == PROC_ST_FUNCTION)
221 ("Argument '%s' of statement function at %L must be scalar",
222 sym->name, &sym->declared_at);
226 if (sym->ts.type == BT_CHARACTER)
228 gfc_charlen *cl = sym->ts.cl;
229 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
232 ("Character-valued argument '%s' of statement function at "
233 "%L must have constant length",
234 sym->name, &sym->declared_at);
244 /* Work function called when searching for symbols that have argument lists
245 associated with them. */
248 find_arglists (gfc_symbol * sym)
251 if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
254 resolve_formal_arglist (sym);
258 /* Given a namespace, resolve all formal argument lists within the namespace.
262 resolve_formal_arglists (gfc_namespace * ns)
268 gfc_traverse_ns (ns, find_arglists);
273 resolve_contained_fntype (gfc_symbol * sym, gfc_namespace * ns)
277 /* If this namespace is not a function, ignore it. */
279 || !(sym->attr.function
280 || sym->attr.flavor == FL_VARIABLE))
283 /* Try to find out of what the return type is. */
284 if (sym->result != NULL)
287 if (sym->ts.type == BT_UNKNOWN)
289 t = gfc_set_default_type (sym, 0, ns);
291 if (t == FAILURE && !sym->attr.untyped)
293 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
294 sym->name, &sym->declared_at); /* FIXME */
295 sym->attr.untyped = 1;
299 /*Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character type,
300 lists the only ways a character length value of * can be used: dummy arguments
301 of procedures, named constants, and function results in external functions.
302 Internal function results are not on that list; ergo, not permitted. */
304 if (sym->ts.type == BT_CHARACTER)
306 gfc_charlen *cl = sym->ts.cl;
307 if (!cl || !cl->length)
308 gfc_error ("Character-valued internal function '%s' at %L must "
309 "not be assumed length", sym->name, &sym->declared_at);
314 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
315 introduce duplicates. */
318 merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
320 gfc_formal_arglist *f, *new_arglist;
323 for (; new_args != NULL; new_args = new_args->next)
325 new_sym = new_args->sym;
326 /* See if this arg is already in the formal argument list. */
327 for (f = proc->formal; f; f = f->next)
329 if (new_sym == f->sym)
336 /* Add a new argument. Argument order is not important. */
337 new_arglist = gfc_get_formal_arglist ();
338 new_arglist->sym = new_sym;
339 new_arglist->next = proc->formal;
340 proc->formal = new_arglist;
345 /* Resolve alternate entry points. If a symbol has multiple entry points we
346 create a new master symbol for the main routine, and turn the existing
347 symbol into an entry point. */
350 resolve_entries (gfc_namespace * ns)
352 gfc_namespace *old_ns;
356 char name[GFC_MAX_SYMBOL_LEN + 1];
357 static int master_count = 0;
359 if (ns->proc_name == NULL)
362 /* No need to do anything if this procedure doesn't have alternate entry
367 /* We may already have resolved alternate entry points. */
368 if (ns->proc_name->attr.entry_master)
371 /* If this isn't a procedure something has gone horribly wrong. */
372 gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
374 /* Remember the current namespace. */
375 old_ns = gfc_current_ns;
379 /* Add the main entry point to the list of entry points. */
380 el = gfc_get_entry_list ();
381 el->sym = ns->proc_name;
383 el->next = ns->entries;
385 ns->proc_name->attr.entry = 1;
387 /* If it is a module function, it needs to be in the right namespace
388 so that gfc_get_fake_result_decl can gather up the results. The
389 need for this arose in get_proc_name, where these beasts were
390 left in their own namespace, to keep prior references linked to
391 the entry declaration.*/
392 if (ns->proc_name->attr.function
394 && ns->parent->proc_name->attr.flavor == FL_MODULE)
397 /* Add an entry statement for it. */
404 /* Create a new symbol for the master function. */
405 /* Give the internal function a unique name (within this file).
406 Also include the function name so the user has some hope of figuring
407 out what is going on. */
408 snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
409 master_count++, ns->proc_name->name);
410 gfc_get_ha_symbol (name, &proc);
411 gcc_assert (proc != NULL);
413 gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
414 if (ns->proc_name->attr.subroutine)
415 gfc_add_subroutine (&proc->attr, proc->name, NULL);
419 gfc_typespec *ts, *fts;
420 gfc_array_spec *as, *fas;
421 gfc_add_function (&proc->attr, proc->name, NULL);
423 fas = ns->entries->sym->as;
424 fas = fas ? fas : ns->entries->sym->result->as;
425 fts = &ns->entries->sym->result->ts;
426 if (fts->type == BT_UNKNOWN)
427 fts = gfc_get_default_type (ns->entries->sym->result, NULL);
428 for (el = ns->entries->next; el; el = el->next)
430 ts = &el->sym->result->ts;
432 as = as ? as : el->sym->result->as;
433 if (ts->type == BT_UNKNOWN)
434 ts = gfc_get_default_type (el->sym->result, NULL);
436 if (! gfc_compare_types (ts, fts)
437 || (el->sym->result->attr.dimension
438 != ns->entries->sym->result->attr.dimension)
439 || (el->sym->result->attr.pointer
440 != ns->entries->sym->result->attr.pointer))
443 else if (as && fas && gfc_compare_array_spec (as, fas) == 0)
444 gfc_error ("Procedure %s at %L has entries with mismatched "
445 "array specifications", ns->entries->sym->name,
446 &ns->entries->sym->declared_at);
451 sym = ns->entries->sym->result;
452 /* All result types the same. */
454 if (sym->attr.dimension)
455 gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
456 if (sym->attr.pointer)
457 gfc_add_pointer (&proc->attr, NULL);
461 /* Otherwise the result will be passed through a union by
463 proc->attr.mixed_entry_master = 1;
464 for (el = ns->entries; el; el = el->next)
466 sym = el->sym->result;
467 if (sym->attr.dimension)
469 if (el == ns->entries)
471 ("FUNCTION result %s can't be an array in FUNCTION %s at %L",
472 sym->name, ns->entries->sym->name, &sym->declared_at);
475 ("ENTRY result %s can't be an array in FUNCTION %s at %L",
476 sym->name, ns->entries->sym->name, &sym->declared_at);
478 else if (sym->attr.pointer)
480 if (el == ns->entries)
482 ("FUNCTION result %s can't be a POINTER in FUNCTION %s at %L",
483 sym->name, ns->entries->sym->name, &sym->declared_at);
486 ("ENTRY result %s can't be a POINTER in FUNCTION %s at %L",
487 sym->name, ns->entries->sym->name, &sym->declared_at);
492 if (ts->type == BT_UNKNOWN)
493 ts = gfc_get_default_type (sym, NULL);
497 if (ts->kind == gfc_default_integer_kind)
501 if (ts->kind == gfc_default_real_kind
502 || ts->kind == gfc_default_double_kind)
506 if (ts->kind == gfc_default_complex_kind)
510 if (ts->kind == gfc_default_logical_kind)
514 /* We will issue error elsewhere. */
522 if (el == ns->entries)
524 ("FUNCTION result %s can't be of type %s in FUNCTION %s at %L",
525 sym->name, gfc_typename (ts), ns->entries->sym->name,
529 ("ENTRY result %s can't be of type %s in FUNCTION %s at %L",
530 sym->name, gfc_typename (ts), ns->entries->sym->name,
537 proc->attr.access = ACCESS_PRIVATE;
538 proc->attr.entry_master = 1;
540 /* Merge all the entry point arguments. */
541 for (el = ns->entries; el; el = el->next)
542 merge_argument_lists (proc, el->sym->formal);
544 /* Use the master function for the function body. */
545 ns->proc_name = proc;
547 /* Finalize the new symbols. */
548 gfc_commit_symbols ();
550 /* Restore the original namespace. */
551 gfc_current_ns = old_ns;
555 /* Resolve contained function types. Because contained functions can call one
556 another, they have to be worked out before any of the contained procedures
559 The good news is that if a function doesn't already have a type, the only
560 way it can get one is through an IMPLICIT type or a RESULT variable, because
561 by definition contained functions are contained namespace they're contained
562 in, not in a sibling or parent namespace. */
565 resolve_contained_functions (gfc_namespace * ns)
567 gfc_namespace *child;
570 resolve_formal_arglists (ns);
572 for (child = ns->contained; child; child = child->sibling)
574 /* Resolve alternate entry points first. */
575 resolve_entries (child);
577 /* Then check function return types. */
578 resolve_contained_fntype (child->proc_name, child);
579 for (el = child->entries; el; el = el->next)
580 resolve_contained_fntype (el->sym, child);
585 /* Resolve all of the elements of a structure constructor and make sure that
586 the types are correct. */
589 resolve_structure_cons (gfc_expr * expr)
591 gfc_constructor *cons;
597 cons = expr->value.constructor;
598 /* A constructor may have references if it is the result of substituting a
599 parameter variable. In this case we just pull out the component we
602 comp = expr->ref->u.c.sym->components;
604 comp = expr->ts.derived->components;
606 for (; comp; comp = comp->next, cons = cons->next)
611 if (gfc_resolve_expr (cons->expr) == FAILURE)
617 if (cons->expr->expr_type != EXPR_NULL
618 && comp->as && comp->as->rank != cons->expr->rank
619 && (comp->allocatable || cons->expr->rank))
621 gfc_error ("The rank of the element in the derived type "
622 "constructor at %L does not match that of the "
623 "component (%d/%d)", &cons->expr->where,
624 cons->expr->rank, comp->as ? comp->as->rank : 0);
628 /* If we don't have the right type, try to convert it. */
630 if (!gfc_compare_types (&cons->expr->ts, &comp->ts))
633 if (comp->pointer && cons->expr->ts.type != BT_UNKNOWN)
634 gfc_error ("The element in the derived type constructor at %L, "
635 "for pointer component '%s', is %s but should be %s",
636 &cons->expr->where, comp->name,
637 gfc_basic_typename (cons->expr->ts.type),
638 gfc_basic_typename (comp->ts.type));
640 t = gfc_convert_type (cons->expr, &comp->ts, 1);
643 if (!comp->pointer || cons->expr->expr_type == EXPR_NULL)
646 a = gfc_expr_attr (cons->expr);
648 if (!a.pointer && !a.target)
651 gfc_error ("The element in the derived type constructor at %L, "
652 "for pointer component '%s' should be a POINTER or "
653 "a TARGET", &cons->expr->where, comp->name);
662 /****************** Expression name resolution ******************/
664 /* Returns 0 if a symbol was not declared with a type or
665 attribute declaration statement, nonzero otherwise. */
668 was_declared (gfc_symbol * sym)
674 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
677 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
678 || a.optional || a.pointer || a.save || a.target || a.volatile_ || a.value
679 || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
686 /* Determine if a symbol is generic or not. */
689 generic_sym (gfc_symbol * sym)
693 if (sym->attr.generic ||
694 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
697 if (was_declared (sym) || sym->ns->parent == NULL)
700 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
702 return (s == NULL) ? 0 : generic_sym (s);
706 /* Determine if a symbol is specific or not. */
709 specific_sym (gfc_symbol * sym)
713 if (sym->attr.if_source == IFSRC_IFBODY
714 || sym->attr.proc == PROC_MODULE
715 || sym->attr.proc == PROC_INTERNAL
716 || sym->attr.proc == PROC_ST_FUNCTION
717 || (sym->attr.intrinsic &&
718 gfc_specific_intrinsic (sym->name))
719 || sym->attr.external)
722 if (was_declared (sym) || sym->ns->parent == NULL)
725 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
727 return (s == NULL) ? 0 : specific_sym (s);
731 /* Figure out if the procedure is specific, generic or unknown. */
734 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
738 procedure_kind (gfc_symbol * sym)
741 if (generic_sym (sym))
742 return PTYPE_GENERIC;
744 if (specific_sym (sym))
745 return PTYPE_SPECIFIC;
747 return PTYPE_UNKNOWN;
750 /* Check references to assumed size arrays. The flag need_full_assumed_size
751 is nonzero when matching actual arguments. */
753 static int need_full_assumed_size = 0;
756 check_assumed_size_reference (gfc_symbol * sym, gfc_expr * e)
762 if (need_full_assumed_size
763 || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
766 for (ref = e->ref; ref; ref = ref->next)
767 if (ref->type == REF_ARRAY)
768 for (dim = 0; dim < ref->u.ar.as->rank; dim++)
769 last = (ref->u.ar.end[dim] == NULL) && (ref->u.ar.type == DIMEN_ELEMENT);
773 gfc_error ("The upper bound in the last dimension must "
774 "appear in the reference to the assumed size "
775 "array '%s' at %L", sym->name, &e->where);
782 /* Look for bad assumed size array references in argument expressions
783 of elemental and array valued intrinsic procedures. Since this is
784 called from procedure resolution functions, it only recurses at
788 resolve_assumed_size_actual (gfc_expr *e)
793 switch (e->expr_type)
797 && check_assumed_size_reference (e->symtree->n.sym, e))
802 if (resolve_assumed_size_actual (e->value.op.op1)
803 || resolve_assumed_size_actual (e->value.op.op2))
814 /* Resolve an actual argument list. Most of the time, this is just
815 resolving the expressions in the list.
816 The exception is that we sometimes have to decide whether arguments
817 that look like procedure arguments are really simple variable
821 resolve_actual_arglist (gfc_actual_arglist * arg)
824 gfc_symtree *parent_st;
827 for (; arg; arg = arg->next)
833 /* Check the label is a valid branching target. */
836 if (arg->label->defined == ST_LABEL_UNKNOWN)
838 gfc_error ("Label %d referenced at %L is never defined",
839 arg->label->value, &arg->label->where);
846 if (e->ts.type != BT_PROCEDURE)
848 if (gfc_resolve_expr (e) != SUCCESS)
853 /* See if the expression node should really be a variable
856 sym = e->symtree->n.sym;
858 if (sym->attr.flavor == FL_PROCEDURE
859 || sym->attr.intrinsic
860 || sym->attr.external)
864 /* If a procedure is not already determined to be something else
865 check if it is intrinsic. */
866 if (!sym->attr.intrinsic
867 && !(sym->attr.external || sym->attr.use_assoc
868 || sym->attr.if_source == IFSRC_IFBODY)
869 && gfc_intrinsic_name (sym->name, sym->attr.subroutine))
870 sym->attr.intrinsic = 1;
872 if (sym->attr.proc == PROC_ST_FUNCTION)
874 gfc_error ("Statement function '%s' at %L is not allowed as an "
875 "actual argument", sym->name, &e->where);
878 actual_ok = gfc_intrinsic_actual_ok (sym->name, sym->attr.subroutine);
879 if (sym->attr.intrinsic && actual_ok == 0)
881 gfc_error ("Intrinsic '%s' at %L is not allowed as an "
882 "actual argument", sym->name, &e->where);
885 if (sym->attr.contained && !sym->attr.use_assoc
886 && sym->ns->proc_name->attr.flavor != FL_MODULE)
888 gfc_error ("Internal procedure '%s' is not allowed as an "
889 "actual argument at %L", sym->name, &e->where);
892 if (sym->attr.elemental && !sym->attr.intrinsic)
894 gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
895 "allowed as an actual argument at %L", sym->name,
899 if (sym->attr.generic)
901 gfc_error ("GENERIC non-INTRINSIC procedure '%s' is not "
902 "allowed as an actual argument at %L", sym->name,
906 /* If the symbol is the function that names the current (or
907 parent) scope, then we really have a variable reference. */
909 if (sym->attr.function && sym->result == sym
910 && (sym->ns->proc_name == sym
911 || (sym->ns->parent != NULL
912 && sym->ns->parent->proc_name == sym)))
918 /* See if the name is a module procedure in a parent unit. */
920 if (was_declared (sym) || sym->ns->parent == NULL)
923 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
925 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
929 if (parent_st == NULL)
932 sym = parent_st->n.sym;
933 e->symtree = parent_st; /* Point to the right thing. */
935 if (sym->attr.flavor == FL_PROCEDURE
936 || sym->attr.intrinsic
937 || sym->attr.external)
943 e->expr_type = EXPR_VARIABLE;
947 e->rank = sym->as->rank;
948 e->ref = gfc_get_ref ();
949 e->ref->type = REF_ARRAY;
950 e->ref->u.ar.type = AR_FULL;
951 e->ref->u.ar.as = sym->as;
959 /* Do the checks of the actual argument list that are specific to elemental
960 procedures. If called with c == NULL, we have a function, otherwise if
961 expr == NULL, we have a subroutine. */
963 resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
965 gfc_actual_arglist *arg0;
966 gfc_actual_arglist *arg;
967 gfc_symbol *esym = NULL;
968 gfc_intrinsic_sym *isym = NULL;
970 gfc_intrinsic_arg *iformal = NULL;
971 gfc_formal_arglist *eformal = NULL;
972 bool formal_optional = false;
973 bool set_by_optional = false;
977 /* Is this an elemental procedure? */
978 if (expr && expr->value.function.actual != NULL)
980 if (expr->value.function.esym != NULL
981 && expr->value.function.esym->attr.elemental)
983 arg0 = expr->value.function.actual;
984 esym = expr->value.function.esym;
986 else if (expr->value.function.isym != NULL
987 && expr->value.function.isym->elemental)
989 arg0 = expr->value.function.actual;
990 isym = expr->value.function.isym;
995 else if (c && c->ext.actual != NULL
996 && c->symtree->n.sym->attr.elemental)
998 arg0 = c->ext.actual;
999 esym = c->symtree->n.sym;
1004 /* The rank of an elemental is the rank of its array argument(s). */
1005 for (arg = arg0; arg; arg = arg->next)
1007 if (arg->expr != NULL && arg->expr->rank > 0)
1009 rank = arg->expr->rank;
1010 if (arg->expr->expr_type == EXPR_VARIABLE
1011 && arg->expr->symtree->n.sym->attr.optional)
1012 set_by_optional = true;
1014 /* Function specific; set the result rank and shape. */
1018 if (!expr->shape && arg->expr->shape)
1020 expr->shape = gfc_get_shape (rank);
1021 for (i = 0; i < rank; i++)
1022 mpz_init_set (expr->shape[i], arg->expr->shape[i]);
1029 /* If it is an array, it shall not be supplied as an actual argument
1030 to an elemental procedure unless an array of the same rank is supplied
1031 as an actual argument corresponding to a nonoptional dummy argument of
1032 that elemental procedure(12.4.1.5). */
1033 formal_optional = false;
1035 iformal = isym->formal;
1037 eformal = esym->formal;
1039 for (arg = arg0; arg; arg = arg->next)
1043 if (eformal->sym && eformal->sym->attr.optional)
1044 formal_optional = true;
1045 eformal = eformal->next;
1047 else if (isym && iformal)
1049 if (iformal->optional)
1050 formal_optional = true;
1051 iformal = iformal->next;
1054 formal_optional = true;
1056 if (pedantic && arg->expr != NULL
1057 && arg->expr->expr_type == EXPR_VARIABLE
1058 && arg->expr->symtree->n.sym->attr.optional
1061 && (set_by_optional || arg->expr->rank != rank)
1062 && !(isym && isym->generic_id == GFC_ISYM_CONVERSION))
1064 gfc_warning ("'%s' at %L is an array and OPTIONAL; IF IT IS "
1065 "MISSING, it cannot be the actual argument of an "
1066 "ELEMENTAL procedure unless there is a non-optional"
1067 "argument with the same rank (12.4.1.5)",
1068 arg->expr->symtree->n.sym->name, &arg->expr->where);
1073 for (arg = arg0; arg; arg = arg->next)
1075 if (arg->expr == NULL || arg->expr->rank == 0)
1078 /* Being elemental, the last upper bound of an assumed size array
1079 argument must be present. */
1080 if (resolve_assumed_size_actual (arg->expr))
1086 /* Elemental subroutine array actual arguments must conform. */
1089 if (gfc_check_conformance ("elemental subroutine", arg->expr, e)
1101 /* Go through each actual argument in ACTUAL and see if it can be
1102 implemented as an inlined, non-copying intrinsic. FNSYM is the
1103 function being called, or NULL if not known. */
1106 find_noncopying_intrinsics (gfc_symbol * fnsym, gfc_actual_arglist * actual)
1108 gfc_actual_arglist *ap;
1111 for (ap = actual; ap; ap = ap->next)
1113 && (expr = gfc_get_noncopying_intrinsic_argument (ap->expr))
1114 && !gfc_check_fncall_dependency (expr, INTENT_IN, fnsym, actual))
1115 ap->expr->inline_noncopying_intrinsic = 1;
1118 /* This function does the checking of references to global procedures
1119 as defined in sections 18.1 and 14.1, respectively, of the Fortran
1120 77 and 95 standards. It checks for a gsymbol for the name, making
1121 one if it does not already exist. If it already exists, then the
1122 reference being resolved must correspond to the type of gsymbol.
1123 Otherwise, the new symbol is equipped with the attributes of the
1124 reference. The corresponding code that is called in creating
1125 global entities is parse.c. */
1128 resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
1133 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
1135 gsym = gfc_get_gsymbol (sym->name);
1137 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
1138 global_used (gsym, where);
1140 if (gsym->type == GSYM_UNKNOWN)
1143 gsym->where = *where;
1149 /************* Function resolution *************/
1151 /* Resolve a function call known to be generic.
1152 Section 14.1.2.4.1. */
1155 resolve_generic_f0 (gfc_expr * expr, gfc_symbol * sym)
1159 if (sym->attr.generic)
1162 gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
1165 expr->value.function.name = s->name;
1166 expr->value.function.esym = s;
1168 if (s->ts.type != BT_UNKNOWN)
1170 else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
1171 expr->ts = s->result->ts;
1174 expr->rank = s->as->rank;
1175 else if (s->result != NULL && s->result->as != NULL)
1176 expr->rank = s->result->as->rank;
1181 /* TODO: Need to search for elemental references in generic interface */
1184 if (sym->attr.intrinsic)
1185 return gfc_intrinsic_func_interface (expr, 0);
1192 resolve_generic_f (gfc_expr * expr)
1197 sym = expr->symtree->n.sym;
1201 m = resolve_generic_f0 (expr, sym);
1204 else if (m == MATCH_ERROR)
1208 if (sym->ns->parent == NULL)
1210 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1214 if (!generic_sym (sym))
1218 /* Last ditch attempt. */
1220 if (!gfc_generic_intrinsic (expr->symtree->n.sym->name))
1222 gfc_error ("There is no specific function for the generic '%s' at %L",
1223 expr->symtree->n.sym->name, &expr->where);
1227 m = gfc_intrinsic_func_interface (expr, 0);
1232 ("Generic function '%s' at %L is not consistent with a specific "
1233 "intrinsic interface", expr->symtree->n.sym->name, &expr->where);
1239 /* Resolve a function call known to be specific. */
1242 resolve_specific_f0 (gfc_symbol * sym, gfc_expr * expr)
1246 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1248 if (sym->attr.dummy)
1250 sym->attr.proc = PROC_DUMMY;
1254 sym->attr.proc = PROC_EXTERNAL;
1258 if (sym->attr.proc == PROC_MODULE
1259 || sym->attr.proc == PROC_ST_FUNCTION
1260 || sym->attr.proc == PROC_INTERNAL)
1263 if (sym->attr.intrinsic)
1265 m = gfc_intrinsic_func_interface (expr, 1);
1270 ("Function '%s' at %L is INTRINSIC but is not compatible with "
1271 "an intrinsic", sym->name, &expr->where);
1279 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1282 expr->value.function.name = sym->name;
1283 expr->value.function.esym = sym;
1284 if (sym->as != NULL)
1285 expr->rank = sym->as->rank;
1292 resolve_specific_f (gfc_expr * expr)
1297 sym = expr->symtree->n.sym;
1301 m = resolve_specific_f0 (sym, expr);
1304 if (m == MATCH_ERROR)
1307 if (sym->ns->parent == NULL)
1310 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1316 gfc_error ("Unable to resolve the specific function '%s' at %L",
1317 expr->symtree->n.sym->name, &expr->where);
1323 /* Resolve a procedure call not known to be generic nor specific. */
1326 resolve_unknown_f (gfc_expr * expr)
1331 sym = expr->symtree->n.sym;
1333 if (sym->attr.dummy)
1335 sym->attr.proc = PROC_DUMMY;
1336 expr->value.function.name = sym->name;
1340 /* See if we have an intrinsic function reference. */
1342 if (gfc_intrinsic_name (sym->name, 0))
1344 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
1349 /* The reference is to an external name. */
1351 sym->attr.proc = PROC_EXTERNAL;
1352 expr->value.function.name = sym->name;
1353 expr->value.function.esym = expr->symtree->n.sym;
1355 if (sym->as != NULL)
1356 expr->rank = sym->as->rank;
1358 /* Type of the expression is either the type of the symbol or the
1359 default type of the symbol. */
1362 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1364 if (sym->ts.type != BT_UNKNOWN)
1368 ts = gfc_get_default_type (sym, sym->ns);
1370 if (ts->type == BT_UNKNOWN)
1372 gfc_error ("Function '%s' at %L has no IMPLICIT type",
1373 sym->name, &expr->where);
1384 /* Figure out if a function reference is pure or not. Also set the name
1385 of the function for a potential error message. Return nonzero if the
1386 function is PURE, zero if not. */
1389 pure_function (gfc_expr * e, const char **name)
1393 if (e->value.function.esym)
1395 pure = gfc_pure (e->value.function.esym);
1396 *name = e->value.function.esym->name;
1398 else if (e->value.function.isym)
1400 pure = e->value.function.isym->pure
1401 || e->value.function.isym->elemental;
1402 *name = e->value.function.isym->name;
1406 /* Implicit functions are not pure. */
1408 *name = e->value.function.name;
1415 /* Resolve a function call, which means resolving the arguments, then figuring
1416 out which entity the name refers to. */
1417 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
1418 to INTENT(OUT) or INTENT(INOUT). */
1421 resolve_function (gfc_expr * expr)
1423 gfc_actual_arglist *arg;
1431 sym = expr->symtree->n.sym;
1433 /* If the procedure is not internal, a statement function or a module
1434 procedure,it must be external and should be checked for usage. */
1435 if (sym && !sym->attr.dummy && !sym->attr.contained
1436 && sym->attr.proc != PROC_ST_FUNCTION
1437 && !sym->attr.use_assoc)
1438 resolve_global_procedure (sym, &expr->where, 0);
1440 /* Switch off assumed size checking and do this again for certain kinds
1441 of procedure, once the procedure itself is resolved. */
1442 need_full_assumed_size++;
1444 if (resolve_actual_arglist (expr->value.function.actual) == FAILURE)
1447 /* Resume assumed_size checking. */
1448 need_full_assumed_size--;
1450 if (sym && sym->ts.type == BT_CHARACTER
1452 && sym->ts.cl->length == NULL
1454 && expr->value.function.esym == NULL
1455 && !sym->attr.contained)
1457 /* Internal procedures are taken care of in resolve_contained_fntype. */
1458 gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
1459 "be used at %L since it is not a dummy argument",
1460 sym->name, &expr->where);
1464 /* See if function is already resolved. */
1466 if (expr->value.function.name != NULL)
1468 if (expr->ts.type == BT_UNKNOWN)
1474 /* Apply the rules of section 14.1.2. */
1476 switch (procedure_kind (sym))
1479 t = resolve_generic_f (expr);
1482 case PTYPE_SPECIFIC:
1483 t = resolve_specific_f (expr);
1487 t = resolve_unknown_f (expr);
1491 gfc_internal_error ("resolve_function(): bad function type");
1495 /* If the expression is still a function (it might have simplified),
1496 then we check to see if we are calling an elemental function. */
1498 if (expr->expr_type != EXPR_FUNCTION)
1501 temp = need_full_assumed_size;
1502 need_full_assumed_size = 0;
1504 if (resolve_elemental_actual (expr, NULL) == FAILURE)
1507 if (omp_workshare_flag
1508 && expr->value.function.esym
1509 && ! gfc_elemental (expr->value.function.esym))
1511 gfc_error ("User defined non-ELEMENTAL function '%s' at %L not allowed"
1512 " in WORKSHARE construct", expr->value.function.esym->name,
1517 #define GENERIC_ID expr->value.function.isym->generic_id
1518 else if (expr->value.function.actual != NULL
1519 && expr->value.function.isym != NULL
1520 && GENERIC_ID != GFC_ISYM_LBOUND
1521 && GENERIC_ID != GFC_ISYM_LEN
1522 && GENERIC_ID != GFC_ISYM_LOC
1523 && GENERIC_ID != GFC_ISYM_PRESENT)
1525 /* Array intrinsics must also have the last upper bound of an
1526 assumed size array argument. UBOUND and SIZE have to be
1527 excluded from the check if the second argument is anything
1530 inquiry = GENERIC_ID == GFC_ISYM_UBOUND
1531 || GENERIC_ID == GFC_ISYM_SIZE;
1533 for (arg = expr->value.function.actual; arg; arg = arg->next)
1535 if (inquiry && arg->next != NULL && arg->next->expr
1536 && arg->next->expr->expr_type != EXPR_CONSTANT)
1539 if (arg->expr != NULL
1540 && arg->expr->rank > 0
1541 && resolve_assumed_size_actual (arg->expr))
1547 need_full_assumed_size = temp;
1549 if (!pure_function (expr, &name) && name)
1554 ("reference to non-PURE function '%s' at %L inside a "
1555 "FORALL %s", name, &expr->where, forall_flag == 2 ?
1559 else if (gfc_pure (NULL))
1561 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
1562 "procedure within a PURE procedure", name, &expr->where);
1567 /* Functions without the RECURSIVE attribution are not allowed to
1568 * call themselves. */
1569 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
1571 gfc_symbol *esym, *proc;
1572 esym = expr->value.function.esym;
1573 proc = gfc_current_ns->proc_name;
1576 gfc_error ("Function '%s' at %L cannot call itself, as it is not "
1577 "RECURSIVE", name, &expr->where);
1581 if (esym->attr.entry && esym->ns->entries && proc->ns->entries
1582 && esym->ns->entries->sym == proc->ns->entries->sym)
1584 gfc_error ("Call to ENTRY '%s' at %L is recursive, but function "
1585 "'%s' is not declared as RECURSIVE",
1586 esym->name, &expr->where, esym->ns->entries->sym->name);
1591 /* Character lengths of use associated functions may contains references to
1592 symbols not referenced from the current program unit otherwise. Make sure
1593 those symbols are marked as referenced. */
1595 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym
1596 && expr->value.function.esym->attr.use_assoc)
1598 gfc_expr_set_symbols_referenced (expr->ts.cl->length);
1602 find_noncopying_intrinsics (expr->value.function.esym,
1603 expr->value.function.actual);
1608 /************* Subroutine resolution *************/
1611 pure_subroutine (gfc_code * c, gfc_symbol * sym)
1618 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
1619 sym->name, &c->loc);
1620 else if (gfc_pure (NULL))
1621 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
1627 resolve_generic_s0 (gfc_code * c, gfc_symbol * sym)
1631 if (sym->attr.generic)
1633 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
1636 c->resolved_sym = s;
1637 pure_subroutine (c, s);
1641 /* TODO: Need to search for elemental references in generic interface. */
1644 if (sym->attr.intrinsic)
1645 return gfc_intrinsic_sub_interface (c, 0);
1652 resolve_generic_s (gfc_code * c)
1657 sym = c->symtree->n.sym;
1661 m = resolve_generic_s0 (c, sym);
1664 else if (m == MATCH_ERROR)
1668 if (sym->ns->parent == NULL)
1670 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1674 if (!generic_sym (sym))
1678 /* Last ditch attempt. */
1679 sym = c->symtree->n.sym;
1680 if (!gfc_generic_intrinsic (sym->name))
1683 ("There is no specific subroutine for the generic '%s' at %L",
1684 sym->name, &c->loc);
1688 m = gfc_intrinsic_sub_interface (c, 0);
1692 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
1693 "intrinsic subroutine interface", sym->name, &c->loc);
1699 /* Resolve a subroutine call known to be specific. */
1702 resolve_specific_s0 (gfc_code * c, gfc_symbol * sym)
1706 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1708 if (sym->attr.dummy)
1710 sym->attr.proc = PROC_DUMMY;
1714 sym->attr.proc = PROC_EXTERNAL;
1718 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
1721 if (sym->attr.intrinsic)
1723 m = gfc_intrinsic_sub_interface (c, 1);
1727 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
1728 "with an intrinsic", sym->name, &c->loc);
1736 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
1738 c->resolved_sym = sym;
1739 pure_subroutine (c, sym);
1746 resolve_specific_s (gfc_code * c)
1751 sym = c->symtree->n.sym;
1755 m = resolve_specific_s0 (c, sym);
1758 if (m == MATCH_ERROR)
1761 if (sym->ns->parent == NULL)
1764 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1770 sym = c->symtree->n.sym;
1771 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
1772 sym->name, &c->loc);
1778 /* Resolve a subroutine call not known to be generic nor specific. */
1781 resolve_unknown_s (gfc_code * c)
1785 sym = c->symtree->n.sym;
1787 if (sym->attr.dummy)
1789 sym->attr.proc = PROC_DUMMY;
1793 /* See if we have an intrinsic function reference. */
1795 if (gfc_intrinsic_name (sym->name, 1))
1797 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
1802 /* The reference is to an external name. */
1805 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
1807 c->resolved_sym = sym;
1809 pure_subroutine (c, sym);
1815 /* Resolve a subroutine call. Although it was tempting to use the same code
1816 for functions, subroutines and functions are stored differently and this
1817 makes things awkward. */
1820 resolve_call (gfc_code * c)
1824 if (c->symtree && c->symtree->n.sym
1825 && c->symtree->n.sym->ts.type != BT_UNKNOWN)
1827 gfc_error ("'%s' at %L has a type, which is not consistent with "
1828 "the CALL at %L", c->symtree->n.sym->name,
1829 &c->symtree->n.sym->declared_at, &c->loc);
1833 /* If the procedure is not internal or module, it must be external and
1834 should be checked for usage. */
1835 if (c->symtree && c->symtree->n.sym
1836 && !c->symtree->n.sym->attr.dummy
1837 && !c->symtree->n.sym->attr.contained
1838 && !c->symtree->n.sym->attr.use_assoc)
1839 resolve_global_procedure (c->symtree->n.sym, &c->loc, 1);
1841 /* Subroutines without the RECURSIVE attribution are not allowed to
1842 * call themselves. */
1843 if (c->symtree && c->symtree->n.sym && !c->symtree->n.sym->attr.recursive)
1845 gfc_symbol *csym, *proc;
1846 csym = c->symtree->n.sym;
1847 proc = gfc_current_ns->proc_name;
1850 gfc_error ("SUBROUTINE '%s' at %L cannot call itself, as it is not "
1851 "RECURSIVE", csym->name, &c->loc);
1855 if (csym->attr.entry && csym->ns->entries && proc->ns->entries
1856 && csym->ns->entries->sym == proc->ns->entries->sym)
1858 gfc_error ("Call to ENTRY '%s' at %L is recursive, but subroutine "
1859 "'%s' is not declared as RECURSIVE",
1860 csym->name, &c->loc, csym->ns->entries->sym->name);
1865 /* Switch off assumed size checking and do this again for certain kinds
1866 of procedure, once the procedure itself is resolved. */
1867 need_full_assumed_size++;
1869 if (resolve_actual_arglist (c->ext.actual) == FAILURE)
1872 /* Resume assumed_size checking. */
1873 need_full_assumed_size--;
1877 if (c->resolved_sym == NULL)
1878 switch (procedure_kind (c->symtree->n.sym))
1881 t = resolve_generic_s (c);
1884 case PTYPE_SPECIFIC:
1885 t = resolve_specific_s (c);
1889 t = resolve_unknown_s (c);
1893 gfc_internal_error ("resolve_subroutine(): bad function type");
1896 /* Some checks of elemental subroutine actual arguments. */
1897 if (resolve_elemental_actual (NULL, c) == FAILURE)
1901 find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
1905 /* Compare the shapes of two arrays that have non-NULL shapes. If both
1906 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
1907 match. If both op1->shape and op2->shape are non-NULL return FAILURE
1908 if their shapes do not match. If either op1->shape or op2->shape is
1909 NULL, return SUCCESS. */
1912 compare_shapes (gfc_expr * op1, gfc_expr * op2)
1919 if (op1->shape != NULL && op2->shape != NULL)
1921 for (i = 0; i < op1->rank; i++)
1923 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
1925 gfc_error ("Shapes for operands at %L and %L are not conformable",
1926 &op1->where, &op2->where);
1936 /* Resolve an operator expression node. This can involve replacing the
1937 operation with a user defined function call. */
1940 resolve_operator (gfc_expr * e)
1942 gfc_expr *op1, *op2;
1946 /* Resolve all subnodes-- give them types. */
1948 switch (e->value.op.operator)
1951 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
1954 /* Fall through... */
1957 case INTRINSIC_UPLUS:
1958 case INTRINSIC_UMINUS:
1959 case INTRINSIC_PARENTHESES:
1960 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
1965 /* Typecheck the new node. */
1967 op1 = e->value.op.op1;
1968 op2 = e->value.op.op2;
1970 switch (e->value.op.operator)
1972 case INTRINSIC_UPLUS:
1973 case INTRINSIC_UMINUS:
1974 if (op1->ts.type == BT_INTEGER
1975 || op1->ts.type == BT_REAL
1976 || op1->ts.type == BT_COMPLEX)
1982 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
1983 gfc_op2string (e->value.op.operator), gfc_typename (&e->ts));
1986 case INTRINSIC_PLUS:
1987 case INTRINSIC_MINUS:
1988 case INTRINSIC_TIMES:
1989 case INTRINSIC_DIVIDE:
1990 case INTRINSIC_POWER:
1991 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
1993 gfc_type_convert_binary (e);
1998 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
1999 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2000 gfc_typename (&op2->ts));
2003 case INTRINSIC_CONCAT:
2004 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
2006 e->ts.type = BT_CHARACTER;
2007 e->ts.kind = op1->ts.kind;
2012 _("Operands of string concatenation operator at %%L are %s/%s"),
2013 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
2019 case INTRINSIC_NEQV:
2020 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
2022 e->ts.type = BT_LOGICAL;
2023 e->ts.kind = gfc_kind_max (op1, op2);
2024 if (op1->ts.kind < e->ts.kind)
2025 gfc_convert_type (op1, &e->ts, 2);
2026 else if (op2->ts.kind < e->ts.kind)
2027 gfc_convert_type (op2, &e->ts, 2);
2031 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
2032 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2033 gfc_typename (&op2->ts));
2038 if (op1->ts.type == BT_LOGICAL)
2040 e->ts.type = BT_LOGICAL;
2041 e->ts.kind = op1->ts.kind;
2045 sprintf (msg, _("Operand of .NOT. operator at %%L is %s"),
2046 gfc_typename (&op1->ts));
2053 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
2055 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
2059 /* Fall through... */
2063 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
2065 e->ts.type = BT_LOGICAL;
2066 e->ts.kind = gfc_default_logical_kind;
2070 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
2072 gfc_type_convert_binary (e);
2074 e->ts.type = BT_LOGICAL;
2075 e->ts.kind = gfc_default_logical_kind;
2079 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
2081 _("Logicals at %%L must be compared with %s instead of %s"),
2082 e->value.op.operator == INTRINSIC_EQ ? ".EQV." : ".NEQV.",
2083 gfc_op2string (e->value.op.operator));
2086 _("Operands of comparison operator '%s' at %%L are %s/%s"),
2087 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
2088 gfc_typename (&op2->ts));
2092 case INTRINSIC_USER:
2094 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
2095 e->value.op.uop->name, gfc_typename (&op1->ts));
2097 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
2098 e->value.op.uop->name, gfc_typename (&op1->ts),
2099 gfc_typename (&op2->ts));
2103 case INTRINSIC_PARENTHESES:
2107 gfc_internal_error ("resolve_operator(): Bad intrinsic");
2110 /* Deal with arrayness of an operand through an operator. */
2114 switch (e->value.op.operator)
2116 case INTRINSIC_PLUS:
2117 case INTRINSIC_MINUS:
2118 case INTRINSIC_TIMES:
2119 case INTRINSIC_DIVIDE:
2120 case INTRINSIC_POWER:
2121 case INTRINSIC_CONCAT:
2125 case INTRINSIC_NEQV:
2133 if (op1->rank == 0 && op2->rank == 0)
2136 if (op1->rank == 0 && op2->rank != 0)
2138 e->rank = op2->rank;
2140 if (e->shape == NULL)
2141 e->shape = gfc_copy_shape (op2->shape, op2->rank);
2144 if (op1->rank != 0 && op2->rank == 0)
2146 e->rank = op1->rank;
2148 if (e->shape == NULL)
2149 e->shape = gfc_copy_shape (op1->shape, op1->rank);
2152 if (op1->rank != 0 && op2->rank != 0)
2154 if (op1->rank == op2->rank)
2156 e->rank = op1->rank;
2157 if (e->shape == NULL)
2159 t = compare_shapes(op1, op2);
2163 e->shape = gfc_copy_shape (op1->shape, op1->rank);
2168 gfc_error ("Inconsistent ranks for operator at %L and %L",
2169 &op1->where, &op2->where);
2172 /* Allow higher level expressions to work. */
2180 case INTRINSIC_UPLUS:
2181 case INTRINSIC_UMINUS:
2182 case INTRINSIC_PARENTHESES:
2183 e->rank = op1->rank;
2185 if (e->shape == NULL)
2186 e->shape = gfc_copy_shape (op1->shape, op1->rank);
2188 /* Simply copy arrayness attribute */
2195 /* Attempt to simplify the expression. */
2198 t = gfc_simplify_expr (e, 0);
2199 /* Some calls do not succeed in simplification and return FAILURE
2200 even though there is no error; eg. variable references to
2201 PARAMETER arrays. */
2202 if (!gfc_is_constant_expr (e))
2209 if (gfc_extend_expr (e) == SUCCESS)
2212 gfc_error (msg, &e->where);
2218 /************** Array resolution subroutines **************/
2222 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
2225 /* Compare two integer expressions. */
2228 compare_bound (gfc_expr * a, gfc_expr * b)
2232 if (a == NULL || a->expr_type != EXPR_CONSTANT
2233 || b == NULL || b->expr_type != EXPR_CONSTANT)
2236 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
2237 gfc_internal_error ("compare_bound(): Bad expression");
2239 i = mpz_cmp (a->value.integer, b->value.integer);
2249 /* Compare an integer expression with an integer. */
2252 compare_bound_int (gfc_expr * a, int b)
2256 if (a == NULL || a->expr_type != EXPR_CONSTANT)
2259 if (a->ts.type != BT_INTEGER)
2260 gfc_internal_error ("compare_bound_int(): Bad expression");
2262 i = mpz_cmp_si (a->value.integer, b);
2272 /* Compare an integer expression with a mpz_t. */
2275 compare_bound_mpz_t (gfc_expr * a, mpz_t b)
2279 if (a == NULL || a->expr_type != EXPR_CONSTANT)
2282 if (a->ts.type != BT_INTEGER)
2283 gfc_internal_error ("compare_bound_int(): Bad expression");
2285 i = mpz_cmp (a->value.integer, b);
2295 /* Compute the last value of a sequence given by a triplet.
2296 Return 0 if it wasn't able to compute the last value, or if the
2297 sequence if empty, and 1 otherwise. */
2300 compute_last_value_for_triplet (gfc_expr * start, gfc_expr * end,
2301 gfc_expr * stride, mpz_t last)
2305 if (start == NULL || start->expr_type != EXPR_CONSTANT
2306 || end == NULL || end->expr_type != EXPR_CONSTANT
2307 || (stride != NULL && stride->expr_type != EXPR_CONSTANT))
2310 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER
2311 || (stride != NULL && stride->ts.type != BT_INTEGER))
2314 if (stride == NULL || compare_bound_int(stride, 1) == CMP_EQ)
2316 if (compare_bound (start, end) == CMP_GT)
2318 mpz_set (last, end->value.integer);
2322 if (compare_bound_int (stride, 0) == CMP_GT)
2324 /* Stride is positive */
2325 if (mpz_cmp (start->value.integer, end->value.integer) > 0)
2330 /* Stride is negative */
2331 if (mpz_cmp (start->value.integer, end->value.integer) < 0)
2336 mpz_sub (rem, end->value.integer, start->value.integer);
2337 mpz_tdiv_r (rem, rem, stride->value.integer);
2338 mpz_sub (last, end->value.integer, rem);
2345 /* Compare a single dimension of an array reference to the array
2349 check_dimension (int i, gfc_array_ref * ar, gfc_array_spec * as)
2353 /* Given start, end and stride values, calculate the minimum and
2354 maximum referenced indexes. */
2362 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
2364 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
2370 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
2372 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
2376 #define AR_START (ar->start[i] ? ar->start[i] : as->lower[i])
2377 #define AR_END (ar->end[i] ? ar->end[i] : as->upper[i])
2379 if (compare_bound (AR_START, AR_END) == CMP_EQ
2380 && (compare_bound (AR_START, as->lower[i]) == CMP_LT
2381 || compare_bound (AR_START, as->upper[i]) == CMP_GT))
2384 if (((compare_bound_int (ar->stride[i], 0) == CMP_GT
2385 || ar->stride[i] == NULL)
2386 && compare_bound (AR_START, AR_END) != CMP_GT)
2387 || (compare_bound_int (ar->stride[i], 0) == CMP_LT
2388 && compare_bound (AR_START, AR_END) != CMP_LT))
2390 if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
2392 if (compare_bound (AR_START, as->upper[i]) == CMP_GT)
2396 mpz_init (last_value);
2397 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i],
2400 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT
2401 || compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
2403 mpz_clear (last_value);
2407 mpz_clear (last_value);
2415 gfc_internal_error ("check_dimension(): Bad array reference");
2421 gfc_warning ("Array reference at %L is out of bounds", &ar->c_where[i]);
2426 /* Compare an array reference with an array specification. */
2429 compare_spec_to_ref (gfc_array_ref * ar)
2436 /* TODO: Full array sections are only allowed as actual parameters. */
2437 if (as->type == AS_ASSUMED_SIZE
2438 && (/*ar->type == AR_FULL
2439 ||*/ (ar->type == AR_SECTION
2440 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
2442 gfc_error ("Rightmost upper bound of assumed size array section"
2443 " not specified at %L", &ar->where);
2447 if (ar->type == AR_FULL)
2450 if (as->rank != ar->dimen)
2452 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
2453 &ar->where, ar->dimen, as->rank);
2457 for (i = 0; i < as->rank; i++)
2458 if (check_dimension (i, ar, as) == FAILURE)
2465 /* Resolve one part of an array index. */
2468 gfc_resolve_index (gfc_expr * index, int check_scalar)
2475 if (gfc_resolve_expr (index) == FAILURE)
2478 if (check_scalar && index->rank != 0)
2480 gfc_error ("Array index at %L must be scalar", &index->where);
2484 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
2486 gfc_error ("Array index at %L must be of INTEGER type",
2491 if (index->ts.type == BT_REAL)
2492 if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L",
2493 &index->where) == FAILURE)
2496 if (index->ts.kind != gfc_index_integer_kind
2497 || index->ts.type != BT_INTEGER)
2500 ts.type = BT_INTEGER;
2501 ts.kind = gfc_index_integer_kind;
2503 gfc_convert_type_warn (index, &ts, 2, 0);
2509 /* Resolve a dim argument to an intrinsic function. */
2512 gfc_resolve_dim_arg (gfc_expr *dim)
2517 if (gfc_resolve_expr (dim) == FAILURE)
2522 gfc_error ("Argument dim at %L must be scalar", &dim->where);
2526 if (dim->ts.type != BT_INTEGER)
2528 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
2531 if (dim->ts.kind != gfc_index_integer_kind)
2535 ts.type = BT_INTEGER;
2536 ts.kind = gfc_index_integer_kind;
2538 gfc_convert_type_warn (dim, &ts, 2, 0);
2544 /* Given an expression that contains array references, update those array
2545 references to point to the right array specifications. While this is
2546 filled in during matching, this information is difficult to save and load
2547 in a module, so we take care of it here.
2549 The idea here is that the original array reference comes from the
2550 base symbol. We traverse the list of reference structures, setting
2551 the stored reference to references. Component references can
2552 provide an additional array specification. */
2555 find_array_spec (gfc_expr * e)
2559 gfc_symbol *derived;
2562 as = e->symtree->n.sym->as;
2565 for (ref = e->ref; ref; ref = ref->next)
2570 gfc_internal_error ("find_array_spec(): Missing spec");
2577 if (derived == NULL)
2578 derived = e->symtree->n.sym->ts.derived;
2580 c = derived->components;
2582 for (; c; c = c->next)
2583 if (c == ref->u.c.component)
2585 /* Track the sequence of component references. */
2586 if (c->ts.type == BT_DERIVED)
2587 derived = c->ts.derived;
2592 gfc_internal_error ("find_array_spec(): Component not found");
2597 gfc_internal_error ("find_array_spec(): unused as(1)");
2608 gfc_internal_error ("find_array_spec(): unused as(2)");
2612 /* Resolve an array reference. */
2615 resolve_array_ref (gfc_array_ref * ar)
2617 int i, check_scalar;
2620 for (i = 0; i < ar->dimen; i++)
2622 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
2624 if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
2626 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
2628 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
2633 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
2637 ar->dimen_type[i] = DIMEN_ELEMENT;
2641 ar->dimen_type[i] = DIMEN_VECTOR;
2642 if (e->expr_type == EXPR_VARIABLE
2643 && e->symtree->n.sym->ts.type == BT_DERIVED)
2644 ar->start[i] = gfc_get_parentheses (e);
2648 gfc_error ("Array index at %L is an array of rank %d",
2649 &ar->c_where[i], e->rank);
2654 /* If the reference type is unknown, figure out what kind it is. */
2656 if (ar->type == AR_UNKNOWN)
2658 ar->type = AR_ELEMENT;
2659 for (i = 0; i < ar->dimen; i++)
2660 if (ar->dimen_type[i] == DIMEN_RANGE
2661 || ar->dimen_type[i] == DIMEN_VECTOR)
2663 ar->type = AR_SECTION;
2668 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
2676 resolve_substring (gfc_ref * ref)
2679 if (ref->u.ss.start != NULL)
2681 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
2684 if (ref->u.ss.start->ts.type != BT_INTEGER)
2686 gfc_error ("Substring start index at %L must be of type INTEGER",
2687 &ref->u.ss.start->where);
2691 if (ref->u.ss.start->rank != 0)
2693 gfc_error ("Substring start index at %L must be scalar",
2694 &ref->u.ss.start->where);
2698 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT
2699 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
2700 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
2702 gfc_error ("Substring start index at %L is less than one",
2703 &ref->u.ss.start->where);
2708 if (ref->u.ss.end != NULL)
2710 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
2713 if (ref->u.ss.end->ts.type != BT_INTEGER)
2715 gfc_error ("Substring end index at %L must be of type INTEGER",
2716 &ref->u.ss.end->where);
2720 if (ref->u.ss.end->rank != 0)
2722 gfc_error ("Substring end index at %L must be scalar",
2723 &ref->u.ss.end->where);
2727 if (ref->u.ss.length != NULL
2728 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT
2729 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ
2730 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT))
2732 gfc_error ("Substring end index at %L exceeds the string length",
2733 &ref->u.ss.start->where);
2742 /* Resolve subtype references. */
2745 resolve_ref (gfc_expr * expr)
2747 int current_part_dimension, n_components, seen_part_dimension;
2750 for (ref = expr->ref; ref; ref = ref->next)
2751 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
2753 find_array_spec (expr);
2757 for (ref = expr->ref; ref; ref = ref->next)
2761 if (resolve_array_ref (&ref->u.ar) == FAILURE)
2769 resolve_substring (ref);
2773 /* Check constraints on part references. */
2775 current_part_dimension = 0;
2776 seen_part_dimension = 0;
2779 for (ref = expr->ref; ref; ref = ref->next)
2784 switch (ref->u.ar.type)
2788 current_part_dimension = 1;
2792 current_part_dimension = 0;
2796 gfc_internal_error ("resolve_ref(): Bad array reference");
2802 if (current_part_dimension || seen_part_dimension)
2804 if (ref->u.c.component->pointer)
2807 ("Component to the right of a part reference with nonzero "
2808 "rank must not have the POINTER attribute at %L",
2812 else if (ref->u.c.component->allocatable)
2815 ("Component to the right of a part reference with nonzero "
2816 "rank must not have the ALLOCATABLE attribute at %L",
2829 if (((ref->type == REF_COMPONENT && n_components > 1)
2830 || ref->next == NULL)
2831 && current_part_dimension
2832 && seen_part_dimension)
2835 gfc_error ("Two or more part references with nonzero rank must "
2836 "not be specified at %L", &expr->where);
2840 if (ref->type == REF_COMPONENT)
2842 if (current_part_dimension)
2843 seen_part_dimension = 1;
2845 /* reset to make sure */
2846 current_part_dimension = 0;
2854 /* Given an expression, determine its shape. This is easier than it sounds.
2855 Leaves the shape array NULL if it is not possible to determine the shape. */
2858 expression_shape (gfc_expr * e)
2860 mpz_t array[GFC_MAX_DIMENSIONS];
2863 if (e->rank == 0 || e->shape != NULL)
2866 for (i = 0; i < e->rank; i++)
2867 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
2870 e->shape = gfc_get_shape (e->rank);
2872 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
2877 for (i--; i >= 0; i--)
2878 mpz_clear (array[i]);
2882 /* Given a variable expression node, compute the rank of the expression by
2883 examining the base symbol and any reference structures it may have. */
2886 expression_rank (gfc_expr * e)
2893 if (e->expr_type == EXPR_ARRAY)
2895 /* Constructors can have a rank different from one via RESHAPE(). */
2897 if (e->symtree == NULL)
2903 e->rank = (e->symtree->n.sym->as == NULL)
2904 ? 0 : e->symtree->n.sym->as->rank;
2910 for (ref = e->ref; ref; ref = ref->next)
2912 if (ref->type != REF_ARRAY)
2915 if (ref->u.ar.type == AR_FULL)
2917 rank = ref->u.ar.as->rank;
2921 if (ref->u.ar.type == AR_SECTION)
2923 /* Figure out the rank of the section. */
2925 gfc_internal_error ("expression_rank(): Two array specs");
2927 for (i = 0; i < ref->u.ar.dimen; i++)
2928 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
2929 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
2939 expression_shape (e);
2943 /* Resolve a variable expression. */
2946 resolve_variable (gfc_expr * e)
2953 if (e->symtree == NULL)
2956 if (e->ref && resolve_ref (e) == FAILURE)
2959 sym = e->symtree->n.sym;
2960 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
2962 e->ts.type = BT_PROCEDURE;
2966 if (sym->ts.type != BT_UNKNOWN)
2967 gfc_variable_attr (e, &e->ts);
2970 /* Must be a simple variable reference. */
2971 if (gfc_set_default_type (sym, 1, sym->ns) == FAILURE)
2976 if (check_assumed_size_reference (sym, e))
2979 /* Deal with forward references to entries during resolve_code, to
2980 satisfy, at least partially, 12.5.2.5. */
2981 if (gfc_current_ns->entries
2982 && current_entry_id == sym->entry_id
2985 && cs_base->current->op != EXEC_ENTRY)
2987 gfc_entry_list *entry;
2988 gfc_formal_arglist *formal;
2992 /* If the symbol is a dummy... */
2993 if (sym->attr.dummy)
2995 entry = gfc_current_ns->entries;
2998 /* ...test if the symbol is a parameter of previous entries. */
2999 for (; entry && entry->id <= current_entry_id; entry = entry->next)
3000 for (formal = entry->sym->formal; formal; formal = formal->next)
3002 if (formal->sym && sym->name == formal->sym->name)
3006 /* If it has not been seen as a dummy, this is an error. */
3009 if (specification_expr)
3010 gfc_error ("Variable '%s',used in a specification expression, "
3011 "is referenced at %L before the ENTRY statement "
3012 "in which it is a parameter",
3013 sym->name, &cs_base->current->loc);
3015 gfc_error ("Variable '%s' is used at %L before the ENTRY "
3016 "statement in which it is a parameter",
3017 sym->name, &cs_base->current->loc);
3022 /* Now do the same check on the specification expressions. */
3023 specification_expr = 1;
3024 if (sym->ts.type == BT_CHARACTER
3025 && gfc_resolve_expr (sym->ts.cl->length) == FAILURE)
3029 for (n = 0; n < sym->as->rank; n++)
3031 specification_expr = 1;
3032 if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
3034 specification_expr = 1;
3035 if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
3038 specification_expr = 0;
3041 /* Update the symbol's entry level. */
3042 sym->entry_id = current_entry_id + 1;
3049 /* Resolve an expression. That is, make sure that types of operands agree
3050 with their operators, intrinsic operators are converted to function calls
3051 for overloaded types and unresolved function references are resolved. */
3054 gfc_resolve_expr (gfc_expr * e)
3061 switch (e->expr_type)
3064 t = resolve_operator (e);
3068 t = resolve_function (e);
3072 t = resolve_variable (e);
3074 expression_rank (e);
3077 case EXPR_SUBSTRING:
3078 t = resolve_ref (e);
3088 if (resolve_ref (e) == FAILURE)
3091 t = gfc_resolve_array_constructor (e);
3092 /* Also try to expand a constructor. */
3095 expression_rank (e);
3096 gfc_expand_constructor (e);
3099 /* This provides the opportunity for the length of constructors with character
3100 valued function elements to propogate the string length to the expression. */
3101 if (e->ts.type == BT_CHARACTER)
3102 gfc_resolve_character_array_constructor (e);
3106 case EXPR_STRUCTURE:
3107 t = resolve_ref (e);
3111 t = resolve_structure_cons (e);
3115 t = gfc_simplify_expr (e, 0);
3119 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
3126 /* Resolve an expression from an iterator. They must be scalar and have
3127 INTEGER or (optionally) REAL type. */
3130 gfc_resolve_iterator_expr (gfc_expr * expr, bool real_ok,
3131 const char * name_msgid)
3133 if (gfc_resolve_expr (expr) == FAILURE)
3136 if (expr->rank != 0)
3138 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
3142 if (!(expr->ts.type == BT_INTEGER
3143 || (expr->ts.type == BT_REAL && real_ok)))
3146 gfc_error ("%s at %L must be INTEGER or REAL", _(name_msgid),
3149 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
3156 /* Resolve the expressions in an iterator structure. If REAL_OK is
3157 false allow only INTEGER type iterators, otherwise allow REAL types. */
3160 gfc_resolve_iterator (gfc_iterator * iter, bool real_ok)
3163 if (iter->var->ts.type == BT_REAL)
3164 gfc_notify_std (GFC_STD_F95_DEL,
3165 "Obsolete: REAL DO loop iterator at %L",
3168 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
3172 if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
3174 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
3179 if (gfc_resolve_iterator_expr (iter->start, real_ok,
3180 "Start expression in DO loop") == FAILURE)
3183 if (gfc_resolve_iterator_expr (iter->end, real_ok,
3184 "End expression in DO loop") == FAILURE)
3187 if (gfc_resolve_iterator_expr (iter->step, real_ok,
3188 "Step expression in DO loop") == FAILURE)
3191 if (iter->step->expr_type == EXPR_CONSTANT)
3193 if ((iter->step->ts.type == BT_INTEGER
3194 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
3195 || (iter->step->ts.type == BT_REAL
3196 && mpfr_sgn (iter->step->value.real) == 0))
3198 gfc_error ("Step expression in DO loop at %L cannot be zero",
3199 &iter->step->where);
3204 /* Convert start, end, and step to the same type as var. */
3205 if (iter->start->ts.kind != iter->var->ts.kind
3206 || iter->start->ts.type != iter->var->ts.type)
3207 gfc_convert_type (iter->start, &iter->var->ts, 2);
3209 if (iter->end->ts.kind != iter->var->ts.kind
3210 || iter->end->ts.type != iter->var->ts.type)
3211 gfc_convert_type (iter->end, &iter->var->ts, 2);
3213 if (iter->step->ts.kind != iter->var->ts.kind
3214 || iter->step->ts.type != iter->var->ts.type)
3215 gfc_convert_type (iter->step, &iter->var->ts, 2);
3221 /* Resolve a list of FORALL iterators. The FORALL index-name is constrained
3222 to be a scalar INTEGER variable. The subscripts and stride are scalar
3223 INTEGERs, and if stride is a constant it must be nonzero. */
3226 resolve_forall_iterators (gfc_forall_iterator * iter)
3231 if (gfc_resolve_expr (iter->var) == SUCCESS
3232 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0))
3233 gfc_error ("FORALL index-name at %L must be a scalar INTEGER",
3236 if (gfc_resolve_expr (iter->start) == SUCCESS
3237 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0))
3238 gfc_error ("FORALL start expression at %L must be a scalar INTEGER",
3239 &iter->start->where);
3240 if (iter->var->ts.kind != iter->start->ts.kind)
3241 gfc_convert_type (iter->start, &iter->var->ts, 2);
3243 if (gfc_resolve_expr (iter->end) == SUCCESS
3244 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0))
3245 gfc_error ("FORALL end expression at %L must be a scalar INTEGER",
3247 if (iter->var->ts.kind != iter->end->ts.kind)
3248 gfc_convert_type (iter->end, &iter->var->ts, 2);
3250 if (gfc_resolve_expr (iter->stride) == SUCCESS)
3252 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0)
3253 gfc_error ("FORALL stride expression at %L must be a scalar %s",
3254 &iter->stride->where, "INTEGER");
3256 if (iter->stride->expr_type == EXPR_CONSTANT
3257 && mpz_cmp_ui(iter->stride->value.integer, 0) == 0)
3258 gfc_error ("FORALL stride expression at %L cannot be zero",
3259 &iter->stride->where);
3261 if (iter->var->ts.kind != iter->stride->ts.kind)
3262 gfc_convert_type (iter->stride, &iter->var->ts, 2);
3269 /* Given a pointer to a symbol that is a derived type, see if any components
3270 have the POINTER attribute. The search is recursive if necessary.
3271 Returns zero if no pointer components are found, nonzero otherwise. */
3274 derived_pointer (gfc_symbol * sym)
3278 for (c = sym->components; c; c = c->next)
3283 if (c->ts.type == BT_DERIVED && derived_pointer (c->ts.derived))
3291 /* Given a pointer to a symbol that is a derived type, see if it's
3292 inaccessible, i.e. if it's defined in another module and the components are
3293 PRIVATE. The search is recursive if necessary. Returns zero if no
3294 inaccessible components are found, nonzero otherwise. */
3297 derived_inaccessible (gfc_symbol *sym)
3301 if (sym->attr.use_assoc && sym->component_access == ACCESS_PRIVATE)
3304 for (c = sym->components; c; c = c->next)
3306 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.derived))
3314 /* Resolve the argument of a deallocate expression. The expression must be
3315 a pointer or a full array. */
3318 resolve_deallocate_expr (gfc_expr * e)
3320 symbol_attribute attr;
3324 if (gfc_resolve_expr (e) == FAILURE)
3327 attr = gfc_expr_attr (e);
3331 if (e->expr_type != EXPR_VARIABLE)
3334 allocatable = e->symtree->n.sym->attr.allocatable;
3335 for (ref = e->ref; ref; ref = ref->next)
3339 if (ref->u.ar.type != AR_FULL)
3344 allocatable = (ref->u.c.component->as != NULL
3345 && ref->u.c.component->as->type == AS_DEFERRED);
3353 if (allocatable == 0)
3356 gfc_error ("Expression in DEALLOCATE statement at %L must be "
3357 "ALLOCATABLE or a POINTER", &e->where);
3360 if (e->symtree->n.sym->attr.intent == INTENT_IN)
3362 gfc_error ("Can't deallocate INTENT(IN) variable '%s' at %L",
3363 e->symtree->n.sym->name, &e->where);
3370 /* Returns true if the expression e contains a reference the symbol sym. */
3372 find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
3374 gfc_actual_arglist *arg;
3382 switch (e->expr_type)
3385 for (arg = e->value.function.actual; arg; arg = arg->next)
3386 rv = rv || find_sym_in_expr (sym, arg->expr);
3389 /* If the variable is not the same as the dependent, 'sym', and
3390 it is not marked as being declared and it is in the same
3391 namespace as 'sym', add it to the local declarations. */
3393 if (sym == e->symtree->n.sym)
3398 rv = rv || find_sym_in_expr (sym, e->value.op.op1);
3399 rv = rv || find_sym_in_expr (sym, e->value.op.op2);
3408 for (ref = e->ref; ref; ref = ref->next)
3413 for (i = 0; i < ref->u.ar.dimen; i++)
3415 rv = rv || find_sym_in_expr (sym, ref->u.ar.start[i]);
3416 rv = rv || find_sym_in_expr (sym, ref->u.ar.end[i]);
3417 rv = rv || find_sym_in_expr (sym, ref->u.ar.stride[i]);
3422 rv = rv || find_sym_in_expr (sym, ref->u.ss.start);
3423 rv = rv || find_sym_in_expr (sym, ref->u.ss.end);
3427 if (ref->u.c.component->ts.type == BT_CHARACTER
3428 && ref->u.c.component->ts.cl->length->expr_type
3430 rv = rv || find_sym_in_expr (sym, ref->u.c.component->ts.cl->length);
3432 if (ref->u.c.component->as)
3433 for (i = 0; i < ref->u.c.component->as->rank; i++)
3435 rv = rv || find_sym_in_expr (sym, ref->u.c.component->as->lower[i]);
3436 rv = rv || find_sym_in_expr (sym, ref->u.c.component->as->upper[i]);
3446 /* Given the expression node e for an allocatable/pointer of derived type to be
3447 allocated, get the expression node to be initialized afterwards (needed for
3448 derived types with default initializers, and derived types with allocatable
3449 components that need nullification.) */
3452 expr_to_initialize (gfc_expr * e)
3458 result = gfc_copy_expr (e);
3460 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
3461 for (ref = result->ref; ref; ref = ref->next)
3462 if (ref->type == REF_ARRAY && ref->next == NULL)
3464 ref->u.ar.type = AR_FULL;
3466 for (i = 0; i < ref->u.ar.dimen; i++)
3467 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
3469 result->rank = ref->u.ar.dimen;
3477 /* Resolve the expression in an ALLOCATE statement, doing the additional
3478 checks to see whether the expression is OK or not. The expression must
3479 have a trailing array reference that gives the size of the array. */
3482 resolve_allocate_expr (gfc_expr * e, gfc_code * code)
3484 int i, pointer, allocatable, dimension;
3485 symbol_attribute attr;
3486 gfc_ref *ref, *ref2;
3493 if (gfc_resolve_expr (e) == FAILURE)
3496 if (code->expr && code->expr->expr_type == EXPR_VARIABLE)
3497 sym = code->expr->symtree->n.sym;
3501 /* Make sure the expression is allocatable or a pointer. If it is
3502 pointer, the next-to-last reference must be a pointer. */
3506 if (e->expr_type != EXPR_VARIABLE)
3510 attr = gfc_expr_attr (e);
3511 pointer = attr.pointer;
3512 dimension = attr.dimension;
3517 allocatable = e->symtree->n.sym->attr.allocatable;
3518 pointer = e->symtree->n.sym->attr.pointer;
3519 dimension = e->symtree->n.sym->attr.dimension;
3521 if (sym == e->symtree->n.sym && sym->ts.type != BT_DERIVED)
3523 gfc_error ("The STAT variable '%s' in an ALLOCATE statement must "
3524 "not be allocated in the same statement at %L",
3525 sym->name, &e->where);
3529 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
3533 if (ref->next != NULL)
3538 allocatable = (ref->u.c.component->as != NULL
3539 && ref->u.c.component->as->type == AS_DEFERRED);
3541 pointer = ref->u.c.component->pointer;
3542 dimension = ref->u.c.component->dimension;
3552 if (allocatable == 0 && pointer == 0)
3554 gfc_error ("Expression in ALLOCATE statement at %L must be "
3555 "ALLOCATABLE or a POINTER", &e->where);
3559 if (e->symtree->n.sym->attr.intent == INTENT_IN)
3561 gfc_error ("Can't allocate INTENT(IN) variable '%s' at %L",
3562 e->symtree->n.sym->name, &e->where);
3566 /* Add default initializer for those derived types that need them. */
3567 if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts)))
3569 init_st = gfc_get_code ();
3570 init_st->loc = code->loc;
3571 init_st->op = EXEC_INIT_ASSIGN;
3572 init_st->expr = expr_to_initialize (e);
3573 init_st->expr2 = init_e;
3574 init_st->next = code->next;
3575 code->next = init_st;
3578 if (pointer && dimension == 0)
3581 /* Make sure the next-to-last reference node is an array specification. */
3583 if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
3585 gfc_error ("Array specification required in ALLOCATE statement "
3586 "at %L", &e->where);
3590 /* Make sure that the array section reference makes sense in the
3591 context of an ALLOCATE specification. */
3595 for (i = 0; i < ar->dimen; i++)
3597 if (ref2->u.ar.type == AR_ELEMENT)
3600 switch (ar->dimen_type[i])
3606 if (ar->start[i] != NULL
3607 && ar->end[i] != NULL
3608 && ar->stride[i] == NULL)
3611 /* Fall Through... */
3615 gfc_error ("Bad array specification in ALLOCATE statement at %L",
3622 for (a = code->ext.alloc_list; a; a = a->next)
3624 sym = a->expr->symtree->n.sym;
3626 /* TODO - check derived type components. */
3627 if (sym->ts.type == BT_DERIVED)
3630 if ((ar->start[i] != NULL && find_sym_in_expr (sym, ar->start[i]))
3631 || (ar->end[i] != NULL && find_sym_in_expr (sym, ar->end[i])))
3633 gfc_error ("'%s' must not appear an the array specification at "
3634 "%L in the same ALLOCATE statement where it is "
3635 "itself allocated", sym->name, &ar->where);
3645 /************ SELECT CASE resolution subroutines ************/
3647 /* Callback function for our mergesort variant. Determines interval
3648 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
3649 op1 > op2. Assumes we're not dealing with the default case.
3650 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
3651 There are nine situations to check. */
3654 compare_cases (const gfc_case * op1, const gfc_case * op2)
3658 if (op1->low == NULL) /* op1 = (:L) */
3660 /* op2 = (:N), so overlap. */
3662 /* op2 = (M:) or (M:N), L < M */
3663 if (op2->low != NULL
3664 && gfc_compare_expr (op1->high, op2->low) < 0)
3667 else if (op1->high == NULL) /* op1 = (K:) */
3669 /* op2 = (M:), so overlap. */
3671 /* op2 = (:N) or (M:N), K > N */
3672 if (op2->high != NULL
3673 && gfc_compare_expr (op1->low, op2->high) > 0)
3676 else /* op1 = (K:L) */
3678 if (op2->low == NULL) /* op2 = (:N), K > N */
3679 retval = (gfc_compare_expr (op1->low, op2->high) > 0) ? 1 : 0;
3680 else if (op2->high == NULL) /* op2 = (M:), L < M */
3681 retval = (gfc_compare_expr (op1->high, op2->low) < 0) ? -1 : 0;
3682 else /* op2 = (M:N) */
3686 if (gfc_compare_expr (op1->high, op2->low) < 0)
3689 else if (gfc_compare_expr (op1->low, op2->high) > 0)
3698 /* Merge-sort a double linked case list, detecting overlap in the
3699 process. LIST is the head of the double linked case list before it
3700 is sorted. Returns the head of the sorted list if we don't see any
3701 overlap, or NULL otherwise. */
3704 check_case_overlap (gfc_case * list)
3706 gfc_case *p, *q, *e, *tail;
3707 int insize, nmerges, psize, qsize, cmp, overlap_seen;
3709 /* If the passed list was empty, return immediately. */
3716 /* Loop unconditionally. The only exit from this loop is a return
3717 statement, when we've finished sorting the case list. */
3724 /* Count the number of merges we do in this pass. */
3727 /* Loop while there exists a merge to be done. */
3732 /* Count this merge. */
3735 /* Cut the list in two pieces by stepping INSIZE places
3736 forward in the list, starting from P. */
3739 for (i = 0; i < insize; i++)
3748 /* Now we have two lists. Merge them! */
3749 while (psize > 0 || (qsize > 0 && q != NULL))
3752 /* See from which the next case to merge comes from. */
3755 /* P is empty so the next case must come from Q. */
3760 else if (qsize == 0 || q == NULL)
3769 cmp = compare_cases (p, q);
3772 /* The whole case range for P is less than the
3780 /* The whole case range for Q is greater than
3781 the case range for P. */
3788 /* The cases overlap, or they are the same
3789 element in the list. Either way, we must
3790 issue an error and get the next case from P. */
3791 /* FIXME: Sort P and Q by line number. */
3792 gfc_error ("CASE label at %L overlaps with CASE "
3793 "label at %L", &p->where, &q->where);
3801 /* Add the next element to the merged list. */
3810 /* P has now stepped INSIZE places along, and so has Q. So
3811 they're the same. */
3816 /* If we have done only one merge or none at all, we've
3817 finished sorting the cases. */
3826 /* Otherwise repeat, merging lists twice the size. */
3832 /* Check to see if an expression is suitable for use in a CASE statement.
3833 Makes sure that all case expressions are scalar constants of the same
3834 type. Return FAILURE if anything is wrong. */
3837 validate_case_label_expr (gfc_expr * e, gfc_expr * case_expr)
3839 if (e == NULL) return SUCCESS;
3841 if (e->ts.type != case_expr->ts.type)
3843 gfc_error ("Expression in CASE statement at %L must be of type %s",
3844 &e->where, gfc_basic_typename (case_expr->ts.type));
3848 /* C805 (R808) For a given case-construct, each case-value shall be of
3849 the same type as case-expr. For character type, length differences
3850 are allowed, but the kind type parameters shall be the same. */
3852 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
3854 gfc_error("Expression in CASE statement at %L must be kind %d",
3855 &e->where, case_expr->ts.kind);
3859 /* Convert the case value kind to that of case expression kind, if needed.
3860 FIXME: Should a warning be issued? */
3861 if (e->ts.kind != case_expr->ts.kind)
3862 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
3866 gfc_error ("Expression in CASE statement at %L must be scalar",
3875 /* Given a completely parsed select statement, we:
3877 - Validate all expressions and code within the SELECT.
3878 - Make sure that the selection expression is not of the wrong type.
3879 - Make sure that no case ranges overlap.
3880 - Eliminate unreachable cases and unreachable code resulting from
3881 removing case labels.
3883 The standard does allow unreachable cases, e.g. CASE (5:3). But
3884 they are a hassle for code generation, and to prevent that, we just
3885 cut them out here. This is not necessary for overlapping cases
3886 because they are illegal and we never even try to generate code.
3888 We have the additional caveat that a SELECT construct could have
3889 been a computed GOTO in the source code. Fortunately we can fairly
3890 easily work around that here: The case_expr for a "real" SELECT CASE
3891 is in code->expr1, but for a computed GOTO it is in code->expr2. All
3892 we have to do is make sure that the case_expr is a scalar integer
3896 resolve_select (gfc_code * code)
3899 gfc_expr *case_expr;
3900 gfc_case *cp, *default_case, *tail, *head;
3901 int seen_unreachable;
3907 if (code->expr == NULL)
3909 /* This was actually a computed GOTO statement. */
3910 case_expr = code->expr2;
3911 if (case_expr->ts.type != BT_INTEGER
3912 || case_expr->rank != 0)
3913 gfc_error ("Selection expression in computed GOTO statement "
3914 "at %L must be a scalar integer expression",
3917 /* Further checking is not necessary because this SELECT was built
3918 by the compiler, so it should always be OK. Just move the
3919 case_expr from expr2 to expr so that we can handle computed
3920 GOTOs as normal SELECTs from here on. */
3921 code->expr = code->expr2;
3926 case_expr = code->expr;
3928 type = case_expr->ts.type;
3929 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
3931 gfc_error ("Argument of SELECT statement at %L cannot be %s",
3932 &case_expr->where, gfc_typename (&case_expr->ts));
3934 /* Punt. Going on here just produce more garbage error messages. */
3938 if (case_expr->rank != 0)
3940 gfc_error ("Argument of SELECT statement at %L must be a scalar "
3941 "expression", &case_expr->where);
3947 /* PR 19168 has a long discussion concerning a mismatch of the kinds
3948 of the SELECT CASE expression and its CASE values. Walk the lists
3949 of case values, and if we find a mismatch, promote case_expr to
3950 the appropriate kind. */
3952 if (type == BT_LOGICAL || type == BT_INTEGER)
3954 for (body = code->block; body; body = body->block)
3956 /* Walk the case label list. */
3957 for (cp = body->ext.case_list; cp; cp = cp->next)
3959 /* Intercept the DEFAULT case. It does not have a kind. */
3960 if (cp->low == NULL && cp->high == NULL)
3963 /* Unreachable case ranges are discarded, so ignore. */
3964 if (cp->low != NULL && cp->high != NULL
3965 && cp->low != cp->high
3966 && gfc_compare_expr (cp->low, cp->high) > 0)
3969 /* FIXME: Should a warning be issued? */
3971 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
3972 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
3974 if (cp->high != NULL
3975 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
3976 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
3981 /* Assume there is no DEFAULT case. */
3982 default_case = NULL;
3987 for (body = code->block; body; body = body->block)
3989 /* Assume the CASE list is OK, and all CASE labels can be matched. */
3991 seen_unreachable = 0;
3993 /* Walk the case label list, making sure that all case labels
3995 for (cp = body->ext.case_list; cp; cp = cp->next)
3997 /* Count the number of cases in the whole construct. */
4000 /* Intercept the DEFAULT case. */
4001 if (cp->low == NULL && cp->high == NULL)
4003 if (default_case != NULL)
4005 gfc_error ("The DEFAULT CASE at %L cannot be followed "
4006 "by a second DEFAULT CASE at %L",
4007 &default_case->where, &cp->where);
4018 /* Deal with single value cases and case ranges. Errors are
4019 issued from the validation function. */
4020 if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
4021 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
4027 if (type == BT_LOGICAL
4028 && ((cp->low == NULL || cp->high == NULL)
4029 || cp->low != cp->high))
4032 ("Logical range in CASE statement at %L is not allowed",
4038 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT)
4041 value = cp->low->value.logical == 0 ? 2 : 1;
4042 if (value & seen_logical)
4044 gfc_error ("constant logical value in CASE statement "
4045 "is repeated at %L",
4050 seen_logical |= value;
4053 if (cp->low != NULL && cp->high != NULL
4054 && cp->low != cp->high
4055 && gfc_compare_expr (cp->low, cp->high) > 0)
4057 if (gfc_option.warn_surprising)
4058 gfc_warning ("Range specification at %L can never "
4059 "be matched", &cp->where);
4061 cp->unreachable = 1;
4062 seen_unreachable = 1;
4066 /* If the case range can be matched, it can also overlap with
4067 other cases. To make sure it does not, we put it in a
4068 double linked list here. We sort that with a merge sort
4069 later on to detect any overlapping cases. */
4073 head->right = head->left = NULL;
4078 tail->right->left = tail;
4085 /* It there was a failure in the previous case label, give up
4086 for this case label list. Continue with the next block. */
4090 /* See if any case labels that are unreachable have been seen.
4091 If so, we eliminate them. This is a bit of a kludge because
4092 the case lists for a single case statement (label) is a
4093 single forward linked lists. */
4094 if (seen_unreachable)
4096 /* Advance until the first case in the list is reachable. */
4097 while (body->ext.case_list != NULL
4098 && body->ext.case_list->unreachable)
4100 gfc_case *n = body->ext.case_list;
4101 body->ext.case_list = body->ext.case_list->next;
4103 gfc_free_case_list (n);
4106 /* Strip all other unreachable cases. */
4107 if (body->ext.case_list)
4109 for (cp = body->ext.case_list; cp->next; cp = cp->next)
4111 if (cp->next->unreachable)
4113 gfc_case *n = cp->next;
4114 cp->next = cp->next->next;
4116 gfc_free_case_list (n);
4123 /* See if there were overlapping cases. If the check returns NULL,
4124 there was overlap. In that case we don't do anything. If head
4125 is non-NULL, we prepend the DEFAULT case. The sorted list can
4126 then used during code generation for SELECT CASE constructs with
4127 a case expression of a CHARACTER type. */
4130 head = check_case_overlap (head);
4132 /* Prepend the default_case if it is there. */
4133 if (head != NULL && default_case)
4135 default_case->left = NULL;
4136 default_case->right = head;
4137 head->left = default_case;
4141 /* Eliminate dead blocks that may be the result if we've seen
4142 unreachable case labels for a block. */
4143 for (body = code; body && body->block; body = body->block)
4145 if (body->block->ext.case_list == NULL)
4147 /* Cut the unreachable block from the code chain. */
4148 gfc_code *c = body->block;
4149 body->block = c->block;
4151 /* Kill the dead block, but not the blocks below it. */
4153 gfc_free_statements (c);
4157 /* More than two cases is legal but insane for logical selects.
4158 Issue a warning for it. */
4159 if (gfc_option.warn_surprising && type == BT_LOGICAL
4161 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
4166 /* Resolve a transfer statement. This is making sure that:
4167 -- a derived type being transferred has only non-pointer components
4168 -- a derived type being transferred doesn't have private components, unless
4169 it's being transferred from the module where the type was defined
4170 -- we're not trying to transfer a whole assumed size array. */
4173 resolve_transfer (gfc_code * code)
4182 if (exp->expr_type != EXPR_VARIABLE
4183 && exp->expr_type != EXPR_FUNCTION)
4186 sym = exp->symtree->n.sym;
4189 /* Go to actual component transferred. */
4190 for (ref = code->expr->ref; ref; ref = ref->next)
4191 if (ref->type == REF_COMPONENT)
4192 ts = &ref->u.c.component->ts;
4194 if (ts->type == BT_DERIVED)
4196 /* Check that transferred derived type doesn't contain POINTER
4198 if (derived_pointer (ts->derived))
4200 gfc_error ("Data transfer element at %L cannot have "
4201 "POINTER components", &code->loc);
4205 if (ts->derived->attr.alloc_comp)
4207 gfc_error ("Data transfer element at %L cannot have "
4208 "ALLOCATABLE components", &code->loc);
4212 if (derived_inaccessible (ts->derived))
4214 gfc_error ("Data transfer element at %L cannot have "
4215 "PRIVATE components",&code->loc);
4220 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
4221 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
4223 gfc_error ("Data transfer element at %L cannot be a full reference to "
4224 "an assumed-size array", &code->loc);
4230 /*********** Toplevel code resolution subroutines ***********/
4232 /* Given a branch to a label and a namespace, if the branch is conforming.
4233 The code node described where the branch is located. */
4236 resolve_branch (gfc_st_label * label, gfc_code * code)
4238 gfc_code *block, *found;
4246 /* Step one: is this a valid branching target? */
4248 if (lp->defined == ST_LABEL_UNKNOWN)
4250 gfc_error ("Label %d referenced at %L is never defined", lp->value,
4255 if (lp->defined != ST_LABEL_TARGET)
4257 gfc_error ("Statement at %L is not a valid branch target statement "
4258 "for the branch statement at %L", &lp->where, &code->loc);
4262 /* Step two: make sure this branch is not a branch to itself ;-) */
4264 if (code->here == label)
4266 gfc_warning ("Branch at %L causes an infinite loop", &code->loc);
4270 /* Step three: Try to find the label in the parse tree. To do this,
4271 we traverse the tree block-by-block: first the block that
4272 contains this GOTO, then the block that it is nested in, etc. We
4273 can ignore other blocks because branching into another block is
4278 for (stack = cs_base; stack; stack = stack->prev)
4280 for (block = stack->head; block; block = block->next)
4282 if (block->here == label)
4295 /* The label is not in an enclosing block, so illegal. This was
4296 allowed in Fortran 66, so we allow it as extension. We also
4297 forego further checks if we run into this. */
4298 gfc_notify_std (GFC_STD_LEGACY,
4299 "Label at %L is not in the same block as the "
4300 "GOTO statement at %L", &lp->where, &code->loc);
4304 /* Step four: Make sure that the branching target is legal if
4305 the statement is an END {SELECT,DO,IF}. */
4307 if (found->op == EXEC_NOP)
4309 for (stack = cs_base; stack; stack = stack->prev)
4310 if (stack->current->next == found)
4314 gfc_notify_std (GFC_STD_F95_DEL,
4315 "Obsolete: GOTO at %L jumps to END of construct at %L",
4316 &code->loc, &found->loc);
4321 /* Check whether EXPR1 has the same shape as EXPR2. */
4324 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
4326 mpz_t shape[GFC_MAX_DIMENSIONS];
4327 mpz_t shape2[GFC_MAX_DIMENSIONS];
4328 try result = FAILURE;
4331 /* Compare the rank. */
4332 if (expr1->rank != expr2->rank)
4335 /* Compare the size of each dimension. */
4336 for (i=0; i<expr1->rank; i++)
4338 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
4341 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
4344 if (mpz_cmp (shape[i], shape2[i]))
4348 /* When either of the two expression is an assumed size array, we
4349 ignore the comparison of dimension sizes. */
4354 for (i--; i>=0; i--)
4356 mpz_clear (shape[i]);
4357 mpz_clear (shape2[i]);
4363 /* Check whether a WHERE assignment target or a WHERE mask expression
4364 has the same shape as the outmost WHERE mask expression. */
4367 resolve_where (gfc_code *code, gfc_expr *mask)
4373 cblock = code->block;
4375 /* Store the first WHERE mask-expr of the WHERE statement or construct.
4376 In case of nested WHERE, only the outmost one is stored. */
4377 if (mask == NULL) /* outmost WHERE */
4379 else /* inner WHERE */
4386 /* Check if the mask-expr has a consistent shape with the
4387 outmost WHERE mask-expr. */
4388 if (resolve_where_shape (cblock->expr, e) == FAILURE)
4389 gfc_error ("WHERE mask at %L has inconsistent shape",
4390 &cblock->expr->where);
4393 /* the assignment statement of a WHERE statement, or the first
4394 statement in where-body-construct of a WHERE construct */
4395 cnext = cblock->next;
4400 /* WHERE assignment statement */
4403 /* Check shape consistent for WHERE assignment target. */
4404 if (e && resolve_where_shape (cnext->expr, e) == FAILURE)
4405 gfc_error ("WHERE assignment target at %L has "
4406 "inconsistent shape", &cnext->expr->where);
4409 /* WHERE or WHERE construct is part of a where-body-construct */
4411 resolve_where (cnext, e);
4415 gfc_error ("Unsupported statement inside WHERE at %L",
4418 /* the next statement within the same where-body-construct */
4419 cnext = cnext->next;
4421 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
4422 cblock = cblock->block;
4427 /* Check whether the FORALL index appears in the expression or not. */
4430 gfc_find_forall_index (gfc_expr *expr, gfc_symbol *symbol)
4434 gfc_actual_arglist *args;
4437 switch (expr->expr_type)
4440 gcc_assert (expr->symtree->n.sym);
4442 /* A scalar assignment */
4445 if (expr->symtree->n.sym == symbol)
4451 /* the expr is array ref, substring or struct component. */
4458 /* Check if the symbol appears in the array subscript. */
4460 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
4463 if (gfc_find_forall_index (ar.start[i], symbol) == SUCCESS)
4467 if (gfc_find_forall_index (ar.end[i], symbol) == SUCCESS)
4471 if (gfc_find_forall_index (ar.stride[i], symbol) == SUCCESS)
4477 if (expr->symtree->n.sym == symbol)
4480 /* Check if the symbol appears in the substring section. */
4481 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
4483 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
4491 gfc_error("expression reference type error at %L", &expr->where);
4497 /* If the expression is a function call, then check if the symbol
4498 appears in the actual arglist of the function. */
4500 for (args = expr->value.function.actual; args; args = args->next)
4502 if (gfc_find_forall_index(args->expr,symbol) == SUCCESS)
4507 /* It seems not to happen. */
4508 case EXPR_SUBSTRING:
4512 gcc_assert (expr->ref->type == REF_SUBSTRING);
4513 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
4515 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
4520 /* It seems not to happen. */
4521 case EXPR_STRUCTURE:
4523 gfc_error ("Unsupported statement while finding forall index in "
4528 /* Find the FORALL index in the first operand. */
4529 if (expr->value.op.op1)
4531 if (gfc_find_forall_index (expr->value.op.op1, symbol) == SUCCESS)
4535 /* Find the FORALL index in the second operand. */
4536 if (expr->value.op.op2)
4538 if (gfc_find_forall_index (expr->value.op.op2, symbol) == SUCCESS)
4551 /* Resolve assignment in FORALL construct.
4552 NVAR is the number of FORALL index variables, and VAR_EXPR records the
4553 FORALL index variables. */
4556 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
4560 for (n = 0; n < nvar; n++)
4562 gfc_symbol *forall_index;
4564 forall_index = var_expr[n]->symtree->n.sym;
4566 /* Check whether the assignment target is one of the FORALL index
4568 if ((code->expr->expr_type == EXPR_VARIABLE)
4569 && (code->expr->symtree->n.sym == forall_index))
4570 gfc_error ("Assignment to a FORALL index variable at %L",
4571 &code->expr->where);
4574 /* If one of the FORALL index variables doesn't appear in the
4575 assignment target, then there will be a many-to-one
4577 if (gfc_find_forall_index (code->expr, forall_index) == FAILURE)
4578 gfc_error ("The FORALL with index '%s' cause more than one "
4579 "assignment to this object at %L",
4580 var_expr[n]->symtree->name, &code->expr->where);
4586 /* Resolve WHERE statement in FORALL construct. */
4589 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr){
4593 cblock = code->block;
4596 /* the assignment statement of a WHERE statement, or the first
4597 statement in where-body-construct of a WHERE construct */
4598 cnext = cblock->next;
4603 /* WHERE assignment statement */
4605 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
4608 /* WHERE or WHERE construct is part of a where-body-construct */
4610 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
4614 gfc_error ("Unsupported statement inside WHERE at %L",
4617 /* the next statement within the same where-body-construct */
4618 cnext = cnext->next;
4620 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
4621 cblock = cblock->block;
4626 /* Traverse the FORALL body to check whether the following errors exist:
4627 1. For assignment, check if a many-to-one assignment happens.
4628 2. For WHERE statement, check the WHERE body to see if there is any
4629 many-to-one assignment. */
4632 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
4636 c = code->block->next;
4642 case EXEC_POINTER_ASSIGN:
4643 gfc_resolve_assign_in_forall (c, nvar, var_expr);
4646 /* Because the gfc_resolve_blocks() will handle the nested FORALL,
4647 there is no need to handle it here. */
4651 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
4656 /* The next statement in the FORALL body. */
4662 /* Given a FORALL construct, first resolve the FORALL iterator, then call
4663 gfc_resolve_forall_body to resolve the FORALL body. */
4666 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
4668 static gfc_expr **var_expr;
4669 static int total_var = 0;
4670 static int nvar = 0;
4671 gfc_forall_iterator *fa;
4672 gfc_symbol *forall_index;
4676 /* Start to resolve a FORALL construct */
4677 if (forall_save == 0)
4679 /* Count the total number of FORALL index in the nested FORALL
4680 construct in order to allocate the VAR_EXPR with proper size. */
4682 while ((next != NULL) && (next->op == EXEC_FORALL))
4684 for (fa = next->ext.forall_iterator; fa; fa = fa->next)
4686 next = next->block->next;
4689 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
4690 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
4693 /* The information about FORALL iterator, including FORALL index start, end
4694 and stride. The FORALL index can not appear in start, end or stride. */
4695 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
4697 /* Check if any outer FORALL index name is the same as the current
4699 for (i = 0; i < nvar; i++)
4701 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
4703 gfc_error ("An outer FORALL construct already has an index "
4704 "with this name %L", &fa->var->where);
4708 /* Record the current FORALL index. */
4709 var_expr[nvar] = gfc_copy_expr (fa->var);
4711 forall_index = fa->var->symtree->n.sym;
4713 /* Check if the FORALL index appears in start, end or stride. */
4714 if (gfc_find_forall_index (fa->start, forall_index) == SUCCESS)
4715 gfc_error ("A FORALL index must not appear in a limit or stride "
4716 "expression in the same FORALL at %L", &fa->start->where);
4717 if (gfc_find_forall_index (fa->end, forall_index) == SUCCESS)
4718 gfc_error ("A FORALL index must not appear in a limit or stride "
4719 "expression in the same FORALL at %L", &fa->end->where);
4720 if (gfc_find_forall_index (fa->stride, forall_index) == SUCCESS)
4721 gfc_error ("A FORALL index must not appear in a limit or stride "
4722 "expression in the same FORALL at %L", &fa->stride->where);
4726 /* Resolve the FORALL body. */
4727 gfc_resolve_forall_body (code, nvar, var_expr);
4729 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
4730 gfc_resolve_blocks (code->block, ns);
4732 /* Free VAR_EXPR after the whole FORALL construct resolved. */
4733 for (i = 0; i < total_var; i++)
4734 gfc_free_expr (var_expr[i]);
4736 /* Reset the counters. */
4742 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
4745 static void resolve_code (gfc_code *, gfc_namespace *);
4748 gfc_resolve_blocks (gfc_code * b, gfc_namespace * ns)
4752 for (; b; b = b->block)
4754 t = gfc_resolve_expr (b->expr);
4755 if (gfc_resolve_expr (b->expr2) == FAILURE)
4761 if (t == SUCCESS && b->expr != NULL
4762 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank != 0))
4764 ("IF clause at %L requires a scalar LOGICAL expression",
4771 && (b->expr->ts.type != BT_LOGICAL
4772 || b->expr->rank == 0))
4774 ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
4779 resolve_branch (b->label, b);
4791 case EXEC_OMP_ATOMIC:
4792 case EXEC_OMP_CRITICAL:
4794 case EXEC_OMP_MASTER:
4795 case EXEC_OMP_ORDERED:
4796 case EXEC_OMP_PARALLEL:
4797 case EXEC_OMP_PARALLEL_DO:
4798 case EXEC_OMP_PARALLEL_SECTIONS:
4799 case EXEC_OMP_PARALLEL_WORKSHARE:
4800 case EXEC_OMP_SECTIONS:
4801 case EXEC_OMP_SINGLE:
4802 case EXEC_OMP_WORKSHARE:
4806 gfc_internal_error ("resolve_block(): Bad block type");
4809 resolve_code (b->next, ns);
4814 /* Given a block of code, recursively resolve everything pointed to by this
4818 resolve_code (gfc_code * code, gfc_namespace * ns)
4820 int omp_workshare_save;
4826 frame.prev = cs_base;
4830 for (; code; code = code->next)
4832 frame.current = code;
4833 forall_save = forall_flag;
4835 if (code->op == EXEC_FORALL)
4838 gfc_resolve_forall (code, ns, forall_save);
4841 else if (code->block)
4843 omp_workshare_save = -1;
4846 case EXEC_OMP_PARALLEL_WORKSHARE:
4847 omp_workshare_save = omp_workshare_flag;
4848 omp_workshare_flag = 1;
4849 gfc_resolve_omp_parallel_blocks (code, ns);
4851 case EXEC_OMP_PARALLEL:
4852 case EXEC_OMP_PARALLEL_DO:
4853 case EXEC_OMP_PARALLEL_SECTIONS:
4854 omp_workshare_save = omp_workshare_flag;
4855 omp_workshare_flag = 0;
4856 gfc_resolve_omp_parallel_blocks (code, ns);
4859 gfc_resolve_omp_do_blocks (code, ns);
4861 case EXEC_OMP_WORKSHARE:
4862 omp_workshare_save = omp_workshare_flag;
4863 omp_workshare_flag = 1;
4866 gfc_resolve_blocks (code->block, ns);
4870 if (omp_workshare_save != -1)
4871 omp_workshare_flag = omp_workshare_save;
4874 t = gfc_resolve_expr (code->expr);
4875 forall_flag = forall_save;
4877 if (gfc_resolve_expr (code->expr2) == FAILURE)
4892 /* Keep track of which entry we are up to. */
4893 current_entry_id = code->ext.entry->id;
4897 resolve_where (code, NULL);
4901 if (code->expr != NULL)
4903 if (code->expr->ts.type != BT_INTEGER)
4904 gfc_error ("ASSIGNED GOTO statement at %L requires an INTEGER "
4905 "variable", &code->expr->where);
4906 else if (code->expr->symtree->n.sym->attr.assign != 1)
4907 gfc_error ("Variable '%s' has not been assigned a target label "
4908 "at %L", code->expr->symtree->n.sym->name,
4909 &code->expr->where);
4912 resolve_branch (code->label, code);
4916 if (code->expr != NULL
4917 && (code->expr->ts.type != BT_INTEGER || code->expr->rank))
4918 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
4919 "INTEGER return specifier", &code->expr->where);
4922 case EXEC_INIT_ASSIGN:
4929 if (gfc_extend_assign (code, ns) == SUCCESS)
4931 if (gfc_pure (NULL) && !gfc_pure (code->symtree->n.sym))
4933 gfc_error ("Subroutine '%s' called instead of assignment at "
4934 "%L must be PURE", code->symtree->n.sym->name,
4941 if (gfc_pure (NULL))
4943 if (gfc_impure_variable (code->expr->symtree->n.sym))
4946 ("Cannot assign to variable '%s' in PURE procedure at %L",
4947 code->expr->symtree->n.sym->name, &code->expr->where);
4951 if (code->expr2->ts.type == BT_DERIVED
4952 && derived_pointer (code->expr2->ts.derived))
4955 ("Right side of assignment at %L is a derived type "
4956 "containing a POINTER in a PURE procedure",
4957 &code->expr2->where);
4962 gfc_check_assign (code->expr, code->expr2, 1);
4965 case EXEC_LABEL_ASSIGN:
4966 if (code->label->defined == ST_LABEL_UNKNOWN)
4967 gfc_error ("Label %d referenced at %L is never defined",
4968 code->label->value, &code->label->where);
4970 && (code->expr->expr_type != EXPR_VARIABLE
4971 || code->expr->symtree->n.sym->ts.type != BT_INTEGER
4972 || code->expr->symtree->n.sym->ts.kind
4973 != gfc_default_integer_kind
4974 || code->expr->symtree->n.sym->as != NULL))
4975 gfc_error ("ASSIGN statement at %L requires a scalar "
4976 "default INTEGER variable", &code->expr->where);
4979 case EXEC_POINTER_ASSIGN:
4983 gfc_check_pointer_assign (code->expr, code->expr2);
4986 case EXEC_ARITHMETIC_IF:
4988 && code->expr->ts.type != BT_INTEGER
4989 && code->expr->ts.type != BT_REAL)
4990 gfc_error ("Arithmetic IF statement at %L requires a numeric "
4991 "expression", &code->expr->where);
4993 resolve_branch (code->label, code);
4994 resolve_branch (code->label2, code);
4995 resolve_branch (code->label3, code);
4999 if (t == SUCCESS && code->expr != NULL
5000 && (code->expr->ts.type != BT_LOGICAL
5001 || code->expr->rank != 0))
5002 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
5003 &code->expr->where);
5008 resolve_call (code);
5012 /* Select is complicated. Also, a SELECT construct could be
5013 a transformed computed GOTO. */
5014 resolve_select (code);
5018 if (code->ext.iterator != NULL)
5020 gfc_iterator *iter = code->ext.iterator;
5021 if (gfc_resolve_iterator (iter, true) != FAILURE)
5022 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym);
5027 if (code->expr == NULL)
5028 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
5030 && (code->expr->rank != 0
5031 || code->expr->ts.type != BT_LOGICAL))
5032 gfc_error ("Exit condition of DO WHILE loop at %L must be "
5033 "a scalar LOGICAL expression", &code->expr->where);
5037 if (t == SUCCESS && code->expr != NULL
5038 && code->expr->ts.type != BT_INTEGER)
5039 gfc_error ("STAT tag in ALLOCATE statement at %L must be "
5040 "of type INTEGER", &code->expr->where);
5042 for (a = code->ext.alloc_list; a; a = a->next)
5043 resolve_allocate_expr (a->expr, code);
5047 case EXEC_DEALLOCATE:
5048 if (t == SUCCESS && code->expr != NULL
5049 && code->expr->ts.type != BT_INTEGER)
5051 ("STAT tag in DEALLOCATE statement at %L must be of type "
5052 "INTEGER", &code->expr->where);
5054 for (a = code->ext.alloc_list; a; a = a->next)
5055 resolve_deallocate_expr (a->expr);
5060 if (gfc_resolve_open (code->ext.open) == FAILURE)
5063 resolve_branch (code->ext.open->err, code);
5067 if (gfc_resolve_close (code->ext.close) == FAILURE)
5070 resolve_branch (code->ext.close->err, code);
5073 case EXEC_BACKSPACE:
5077 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
5080 resolve_branch (code->ext.filepos->err, code);
5084 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
5087 resolve_branch (code->ext.inquire->err, code);
5091 gcc_assert (code->ext.inquire != NULL);
5092 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
5095 resolve_branch (code->ext.inquire->err, code);
5100 if (gfc_resolve_dt (code->ext.dt) == FAILURE)
5103 resolve_branch (code->ext.dt->err, code);
5104 resolve_branch (code->ext.dt->end, code);
5105 resolve_branch (code->ext.dt->eor, code);
5109 resolve_transfer (code);
5113 resolve_forall_iterators (code->ext.forall_iterator);
5115 if (code->expr != NULL && code->expr->ts.type != BT_LOGICAL)
5117 ("FORALL mask clause at %L requires a LOGICAL expression",
5118 &code->expr->where);
5121 case EXEC_OMP_ATOMIC:
5122 case EXEC_OMP_BARRIER:
5123 case EXEC_OMP_CRITICAL:
5124 case EXEC_OMP_FLUSH:
5126 case EXEC_OMP_MASTER:
5127 case EXEC_OMP_ORDERED:
5128 case EXEC_OMP_SECTIONS:
5129 case EXEC_OMP_SINGLE:
5130 case EXEC_OMP_WORKSHARE:
5131 gfc_resolve_omp_directive (code, ns);
5134 case EXEC_OMP_PARALLEL:
5135 case EXEC_OMP_PARALLEL_DO:
5136 case EXEC_OMP_PARALLEL_SECTIONS:
5137 case EXEC_OMP_PARALLEL_WORKSHARE:
5138 omp_workshare_save = omp_workshare_flag;
5139 omp_workshare_flag = 0;
5140 gfc_resolve_omp_directive (code, ns);
5141 omp_workshare_flag = omp_workshare_save;
5145 gfc_internal_error ("resolve_code(): Bad statement code");
5149 cs_base = frame.prev;
5153 /* Resolve initial values and make sure they are compatible with
5157 resolve_values (gfc_symbol * sym)
5160 if (sym->value == NULL)
5163 if (gfc_resolve_expr (sym->value) == FAILURE)
5166 gfc_check_assign_symbol (sym, sym->value);
5170 /* Resolve an index expression. */
5173 resolve_index_expr (gfc_expr * e)
5175 if (gfc_resolve_expr (e) == FAILURE)
5178 if (gfc_simplify_expr (e, 0) == FAILURE)
5181 if (gfc_specification_expr (e) == FAILURE)
5187 /* Resolve a charlen structure. */
5190 resolve_charlen (gfc_charlen *cl)
5197 specification_expr = 1;
5199 if (resolve_index_expr (cl->length) == FAILURE)
5201 specification_expr = 0;
5209 /* Test for non-constant shape arrays. */
5212 is_non_constant_shape_array (gfc_symbol *sym)
5218 not_constant = false;
5219 if (sym->as != NULL)
5221 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
5222 has not been simplified; parameter array references. Do the
5223 simplification now. */
5224 for (i = 0; i < sym->as->rank; i++)
5226 e = sym->as->lower[i];
5227 if (e && (resolve_index_expr (e) == FAILURE
5228 || !gfc_is_constant_expr (e)))
5229 not_constant = true;
5231 e = sym->as->upper[i];
5232 if (e && (resolve_index_expr (e) == FAILURE
5233 || !gfc_is_constant_expr (e)))
5234 not_constant = true;
5237 return not_constant;
5241 /* Assign the default initializer to a derived type variable or result. */
5244 apply_default_init (gfc_symbol *sym)
5247 gfc_expr *init = NULL;
5249 gfc_namespace *ns = sym->ns;
5251 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
5254 if (sym->ts.type == BT_DERIVED && sym->ts.derived)
5255 init = gfc_default_initializer (&sym->ts);
5260 /* Search for the function namespace if this is a contained
5261 function without an explicit result. */
5262 if (sym->attr.function && sym == sym->result
5263 && sym->name != sym->ns->proc_name->name)
5266 for (;ns; ns = ns->sibling)
5267 if (strcmp (ns->proc_name->name, sym->name) == 0)
5273 gfc_free_expr (init);
5277 /* Build an l-value expression for the result. */
5278 lval = gfc_get_expr ();
5279 lval->expr_type = EXPR_VARIABLE;
5280 lval->where = sym->declared_at;
5282 lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name);
5284 /* It will always be a full array. */
5285 lval->rank = sym->as ? sym->as->rank : 0;
5288 lval->ref = gfc_get_ref ();
5289 lval->ref->type = REF_ARRAY;
5290 lval->ref->u.ar.type = AR_FULL;
5291 lval->ref->u.ar.dimen = lval->rank;
5292 lval->ref->u.ar.where = sym->declared_at;
5293 lval->ref->u.ar.as = sym->as;
5296 /* Add the code at scope entry. */
5297 init_st = gfc_get_code ();
5298 init_st->next = ns->code;
5301 /* Assign the default initializer to the l-value. */
5302 init_st->loc = sym->declared_at;
5303 init_st->op = EXEC_INIT_ASSIGN;
5304 init_st->expr = lval;
5305 init_st->expr2 = init;
5309 /* Resolution of common features of flavors variable and procedure. */
5312 resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
5314 /* Constraints on deferred shape variable. */
5315 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
5317 if (sym->attr.allocatable)
5319 if (sym->attr.dimension)
5320 gfc_error ("Allocatable array '%s' at %L must have "
5321 "a deferred shape", sym->name, &sym->declared_at);
5323 gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
5324 sym->name, &sym->declared_at);
5328 if (sym->attr.pointer && sym->attr.dimension)
5330 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
5331 sym->name, &sym->declared_at);
5338 if (!mp_flag && !sym->attr.allocatable
5339 && !sym->attr.pointer && !sym->attr.dummy)
5341 gfc_error ("Array '%s' at %L cannot have a deferred shape",
5342 sym->name, &sym->declared_at);
5349 /* Resolve symbols with flavor variable. */
5352 resolve_fl_variable (gfc_symbol *sym, int mp_flag)
5357 gfc_expr *constructor_expr;
5358 const char * auto_save_msg;
5360 auto_save_msg = "automatic object '%s' at %L cannot have the "
5363 if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
5366 /* Set this flag to check that variables are parameters of all entries.
5367 This check is effected by the call to gfc_resolve_expr through
5368 is_non_constant_shape_array. */
5369 specification_expr = 1;
5371 if (!sym->attr.use_assoc
5372 && !sym->attr.allocatable
5373 && !sym->attr.pointer
5374 && is_non_constant_shape_array (sym))
5376 /* The shape of a main program or module array needs to be constant. */
5377 if (sym->ns->proc_name
5378 && (sym->ns->proc_name->attr.flavor == FL_MODULE
5379 || sym->ns->proc_name->attr.is_main_program))
5381 gfc_error ("The module or main program array '%s' at %L must "
5382 "have constant shape", sym->name, &sym->declared_at);
5383 specification_expr = 0;
5388 if (sym->ts.type == BT_CHARACTER)
5390 /* Make sure that character string variables with assumed length are
5392 e = sym->ts.cl->length;
5393 if (e == NULL && !sym->attr.dummy && !sym->attr.result)
5395 gfc_error ("Entity with assumed character length at %L must be a "
5396 "dummy argument or a PARAMETER", &sym->declared_at);
5400 if (e && sym->attr.save && !gfc_is_constant_expr (e))
5402 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
5406 if (!gfc_is_constant_expr (e)
5407 && !(e->expr_type == EXPR_VARIABLE
5408 && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
5409 && sym->ns->proc_name
5410 && (sym->ns->proc_name->attr.flavor == FL_MODULE
5411 || sym->ns->proc_name->attr.is_main_program)
5412 && !sym->attr.use_assoc)
5414 gfc_error ("'%s' at %L must have constant character length "
5415 "in this context", sym->name, &sym->declared_at);
5420 /* Can the symbol have an initializer? */
5422 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
5423 || sym->attr.intrinsic || sym->attr.result)
5425 else if (sym->attr.dimension && !sym->attr.pointer)
5427 /* Don't allow initialization of automatic arrays. */
5428 for (i = 0; i < sym->as->rank; i++)
5430 if (sym->as->lower[i] == NULL
5431 || sym->as->lower[i]->expr_type != EXPR_CONSTANT
5432 || sym->as->upper[i] == NULL
5433 || sym->as->upper[i]->expr_type != EXPR_CONSTANT)
5440 /* Also, they must not have the SAVE attribute. */
5441 if (flag && sym->attr.save)
5443 gfc_error (auto_save_msg, sym->name, &sym->declared_at);
5448 /* Reject illegal initializers. */
5449 if (sym->value && flag)
5451 if (sym->attr.allocatable)
5452 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
5453 sym->name, &sym->declared_at);
5454 else if (sym->attr.external)
5455 gfc_error ("External '%s' at %L cannot have an initializer",
5456 sym->name, &sym->declared_at);
5457 else if (sym->attr.dummy)
5458 gfc_error ("Dummy '%s' at %L cannot have an initializer",
5459 sym->name, &sym->declared_at);
5460 else if (sym->attr.intrinsic)
5461 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
5462 sym->name, &sym->declared_at);
5463 else if (sym->attr.result)
5464 gfc_error ("Function result '%s' at %L cannot have an initializer",
5465 sym->name, &sym->declared_at);
5467 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
5468 sym->name, &sym->declared_at);
5472 /* Check to see if a derived type is blocked from being host associated
5473 by the presence of another class I symbol in the same namespace.
5474 14.6.1.3 of the standard and the discussion on comp.lang.fortran. */
5475 if (sym->ts.type == BT_DERIVED && sym->ns != sym->ts.derived->ns)
5478 gfc_find_symbol (sym->ts.derived->name, sym->ns, 0, &s);
5479 if (s && (s->attr.flavor != FL_DERIVED
5480 || !gfc_compare_derived_types (s, sym->ts.derived)))
5482 gfc_error ("The type %s cannot be host associated at %L because "
5483 "it is blocked by an incompatible object of the same "
5484 "name at %L", sym->ts.derived->name, &sym->declared_at,
5490 /* 4th constraint in section 11.3: "If an object of a type for which
5491 component-initialization is specified (R429) appears in the
5492 specification-part of a module and does not have the ALLOCATABLE
5493 or POINTER attribute, the object shall have the SAVE attribute." */
5495 constructor_expr = NULL;
5496 if (sym->ts.type == BT_DERIVED && !(sym->value || flag))
5497 constructor_expr = gfc_default_initializer (&sym->ts);
5499 if (sym->ns->proc_name
5500 && sym->ns->proc_name->attr.flavor == FL_MODULE
5502 && !sym->ns->save_all && !sym->attr.save
5503 && !sym->attr.pointer && !sym->attr.allocatable)
5505 gfc_error("Object '%s' at %L must have the SAVE attribute %s",
5506 sym->name, &sym->declared_at,
5507 "for default initialization of a component");
5511 /* Assign default initializer. */
5512 if (sym->ts.type == BT_DERIVED
5514 && !sym->attr.pointer
5515 && !sym->attr.allocatable
5516 && (!flag || sym->attr.intent == INTENT_OUT))
5517 sym->value = gfc_default_initializer (&sym->ts);
5523 /* Resolve a procedure. */
5526 resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
5528 gfc_formal_arglist *arg;
5531 if (sym->attr.ambiguous_interfaces && !sym->attr.referenced)
5532 gfc_warning ("Although not referenced, '%s' at %L has ambiguous "
5533 "interfaces", sym->name, &sym->declared_at);
5535 if (sym->attr.function
5536 && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
5539 st = gfc_find_symtree (gfc_current_ns->sym_root, sym->name);
5540 if (st && st->ambiguous
5541 && sym->attr.referenced
5542 && !sym->attr.generic)
5544 gfc_error ("Procedure %s at %L is ambiguous",
5545 sym->name, &sym->declared_at);
5549 if (sym->ts.type == BT_CHARACTER)
5551 gfc_charlen *cl = sym->ts.cl;
5552 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
5554 if (sym->attr.proc == PROC_ST_FUNCTION)
5556 gfc_error ("Character-valued statement function '%s' at %L must "
5557 "have constant length", sym->name, &sym->declared_at);
5561 if (sym->attr.external && sym->formal == NULL
5562 && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT)
5564 gfc_error ("Automatic character length function '%s' at %L must "
5565 "have an explicit interface", sym->name, &sym->declared_at);
5571 /* Ensure that derived type for are not of a private type. Internal
5572 module procedures are excluded by 2.2.3.3 - ie. they are not
5573 externally accessible and can access all the objects accessible in
5575 if (!(sym->ns->parent
5576 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)
5577 && gfc_check_access(sym->attr.access, sym->ns->default_access))
5579 for (arg = sym->formal; arg; arg = arg->next)
5582 && arg->sym->ts.type == BT_DERIVED
5583 && !arg->sym->ts.derived->attr.use_assoc
5584 && !gfc_check_access(arg->sym->ts.derived->attr.access,
5585 arg->sym->ts.derived->ns->default_access))
5587 gfc_error_now ("'%s' is of a PRIVATE type and cannot be "
5588 "a dummy argument of '%s', which is "
5589 "PUBLIC at %L", arg->sym->name, sym->name,
5591 /* Stop this message from recurring. */
5592 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
5598 /* An external symbol may not have an initializer because it is taken to be
5600 if (sym->attr.external && sym->value)
5602 gfc_error ("External object '%s' at %L may not have an initializer",
5603 sym->name, &sym->declared_at);
5607 /* An elemental function is required to return a scalar 12.7.1 */
5608 if (sym->attr.elemental && sym->attr.function && sym->as)
5610 gfc_error ("ELEMENTAL function '%s' at %L must have a scalar "
5611 "result", sym->name, &sym->declared_at);
5612 /* Reset so that the error only occurs once. */
5613 sym->attr.elemental = 0;
5617 /* 5.1.1.5 of the Standard: A function name declared with an asterisk
5618 char-len-param shall not be array-valued, pointer-valued, recursive
5619 or pure. ....snip... A character value of * may only be used in the
5620 following ways: (i) Dummy arg of procedure - dummy associates with
5621 actual length; (ii) To declare a named constant; or (iii) External
5622 function - but length must be declared in calling scoping unit. */
5623 if (sym->attr.function
5624 && sym->ts.type == BT_CHARACTER
5625 && sym->ts.cl && sym->ts.cl->length == NULL)
5627 if ((sym->as && sym->as->rank) || (sym->attr.pointer)
5628 || (sym->attr.recursive) || (sym->attr.pure))
5630 if (sym->as && sym->as->rank)
5631 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
5632 "array-valued", sym->name, &sym->declared_at);
5634 if (sym->attr.pointer)
5635 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
5636 "pointer-valued", sym->name, &sym->declared_at);
5639 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
5640 "pure", sym->name, &sym->declared_at);
5642 if (sym->attr.recursive)
5643 gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
5644 "recursive", sym->name, &sym->declared_at);
5649 /* Appendix B.2 of the standard. Contained functions give an
5650 error anyway. Fixed-form is likely to be F77/legacy. */
5651 if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
5652 gfc_notify_std (GFC_STD_F95_OBS, "CHARACTER(*) function "
5653 "'%s' at %L is obsolescent in fortran 95",
5654 sym->name, &sym->declared_at);
5660 /* Resolve the components of a derived type. */
5663 resolve_fl_derived (gfc_symbol *sym)
5666 gfc_dt_list * dt_list;
5669 for (c = sym->components; c != NULL; c = c->next)
5671 if (c->ts.type == BT_CHARACTER)
5673 if (c->ts.cl->length == NULL
5674 || (resolve_charlen (c->ts.cl) == FAILURE)
5675 || !gfc_is_constant_expr (c->ts.cl->length))
5677 gfc_error ("Character length of component '%s' needs to "
5678 "be a constant specification expression at %L",
5680 c->ts.cl->length ? &c->ts.cl->length->where : &c->loc);
5685 if (c->ts.type == BT_DERIVED
5686 && sym->component_access != ACCESS_PRIVATE
5687 && gfc_check_access(sym->attr.access, sym->ns->default_access)
5688 && !c->ts.derived->attr.use_assoc
5689 && !gfc_check_access(c->ts.derived->attr.access,
5690 c->ts.derived->ns->default_access))
5692 gfc_error ("The component '%s' is a PRIVATE type and cannot be "
5693 "a component of '%s', which is PUBLIC at %L",
5694 c->name, sym->name, &sym->declared_at);
5698 if (sym->attr.sequence)
5700 if (c->ts.type == BT_DERIVED && c->ts.derived->attr.sequence == 0)
5702 gfc_error ("Component %s of SEQUENCE type declared at %L does "
5703 "not have the SEQUENCE attribute",
5704 c->ts.derived->name, &sym->declared_at);
5709 if (c->ts.type == BT_DERIVED && c->pointer
5710 && c->ts.derived->components == NULL)
5712 gfc_error ("The pointer component '%s' of '%s' at %L is a type "
5713 "that has not been declared", c->name, sym->name,
5718 if (c->pointer || c->allocatable || c->as == NULL)
5721 for (i = 0; i < c->as->rank; i++)
5723 if (c->as->lower[i] == NULL
5724 || !gfc_is_constant_expr (c->as->lower[i])
5725 || (resolve_index_expr (c->as->lower[i]) == FAILURE)
5726 || c->as->upper[i] == NULL
5727 || (resolve_index_expr (c->as->upper[i]) == FAILURE)
5728 || !gfc_is_constant_expr (c->as->upper[i]))
5730 gfc_error ("Component '%s' of '%s' at %L must have "
5731 "constant array bounds",
5732 c->name, sym->name, &c->loc);
5738 /* Add derived type to the derived type list. */
5739 for (dt_list = sym->ns->derived_types; dt_list; dt_list = dt_list->next)
5740 if (sym == dt_list->derived)
5743 if (dt_list == NULL)
5745 dt_list = gfc_get_dt_list ();
5746 dt_list->next = sym->ns->derived_types;
5747 dt_list->derived = sym;
5748 sym->ns->derived_types = dt_list;
5756 resolve_fl_namelist (gfc_symbol *sym)
5761 /* Reject PRIVATE objects in a PUBLIC namelist. */
5762 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
5764 for (nl = sym->namelist; nl; nl = nl->next)
5766 if (!nl->sym->attr.use_assoc
5767 && !(sym->ns->parent == nl->sym->ns)
5768 && !gfc_check_access(nl->sym->attr.access,
5769 nl->sym->ns->default_access))
5771 gfc_error ("PRIVATE symbol '%s' cannot be member of "
5772 "PUBLIC namelist at %L", nl->sym->name,
5779 /* Reject namelist arrays that are not constant shape. */
5780 for (nl = sym->namelist; nl; nl = nl->next)
5782 if (is_non_constant_shape_array (nl->sym))
5784 gfc_error ("The array '%s' must have constant shape to be "
5785 "a NAMELIST object at %L", nl->sym->name,
5791 /* Namelist objects cannot have allocatable components. */
5792 for (nl = sym->namelist; nl; nl = nl->next)
5794 if (nl->sym->ts.type == BT_DERIVED
5795 && nl->sym->ts.derived->attr.alloc_comp)
5797 gfc_error ("NAMELIST object '%s' at %L cannot have ALLOCATABLE "
5798 "components", nl->sym->name, &sym->declared_at);
5803 /* 14.1.2 A module or internal procedure represent local entities
5804 of the same type as a namelist member and so are not allowed.
5805 Note that this is sometimes caught by check_conflict so the
5806 same message has been used. */
5807 for (nl = sym->namelist; nl; nl = nl->next)
5809 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE)
5812 if (sym->ns->parent && nl->sym && nl->sym->name)
5813 gfc_find_symbol (nl->sym->name, sym->ns->parent, 0, &nlsym);
5814 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
5816 gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
5817 "attribute in '%s' at %L", nlsym->name,
5828 resolve_fl_parameter (gfc_symbol *sym)
5830 /* A parameter array's shape needs to be constant. */
5831 if (sym->as != NULL && !gfc_is_compile_time_shape (sym->as))
5833 gfc_error ("Parameter array '%s' at %L cannot be automatic "
5834 "or assumed shape", sym->name, &sym->declared_at);
5838 /* Make sure a parameter that has been implicitly typed still
5839 matches the implicit type, since PARAMETER statements can precede
5840 IMPLICIT statements. */
5841 if (sym->attr.implicit_type
5842 && !gfc_compare_types (&sym->ts,
5843 gfc_get_default_type (sym, sym->ns)))
5845 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
5846 "later IMPLICIT type", sym->name, &sym->declared_at);
5850 /* Make sure the types of derived parameters are consistent. This
5851 type checking is deferred until resolution because the type may
5852 refer to a derived type from the host. */
5853 if (sym->ts.type == BT_DERIVED
5854 && !gfc_compare_types (&sym->ts, &sym->value->ts))
5856 gfc_error ("Incompatible derived type in PARAMETER at %L",
5857 &sym->value->where);
5864 /* Do anything necessary to resolve a symbol. Right now, we just
5865 assume that an otherwise unknown symbol is a variable. This sort
5866 of thing commonly happens for symbols in module. */
5869 resolve_symbol (gfc_symbol * sym)
5871 /* Zero if we are checking a formal namespace. */
5872 static int formal_ns_flag = 1;
5873 int formal_ns_save, check_constant, mp_flag;
5874 gfc_symtree *symtree;
5875 gfc_symtree *this_symtree;
5879 if (sym->attr.flavor == FL_UNKNOWN)
5882 /* If we find that a flavorless symbol is an interface in one of the
5883 parent namespaces, find its symtree in this namespace, free the
5884 symbol and set the symtree to point to the interface symbol. */
5885 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
5887 symtree = gfc_find_symtree (ns->sym_root, sym->name);
5888 if (symtree && symtree->n.sym->generic)
5890 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
5894 gfc_free_symbol (sym);
5895 symtree->n.sym->refs++;
5896 this_symtree->n.sym = symtree->n.sym;
5901 /* Otherwise give it a flavor according to such attributes as
5903 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
5904 sym->attr.flavor = FL_VARIABLE;
5907 sym->attr.flavor = FL_PROCEDURE;
5908 if (sym->attr.dimension)
5909 sym->attr.function = 1;
5913 if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
5916 /* Symbols that are module procedures with results (functions) have
5917 the types and array specification copied for type checking in
5918 procedures that call them, as well as for saving to a module
5919 file. These symbols can't stand the scrutiny that their results
5921 mp_flag = (sym->result != NULL && sym->result != sym);
5923 /* Assign default type to symbols that need one and don't have one. */
5924 if (sym->ts.type == BT_UNKNOWN)
5926 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
5927 gfc_set_default_type (sym, 1, NULL);
5929 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
5931 /* The specific case of an external procedure should emit an error
5932 in the case that there is no implicit type. */
5934 gfc_set_default_type (sym, sym->attr.external, NULL);
5937 /* Result may be in another namespace. */
5938 resolve_symbol (sym->result);
5940 sym->ts = sym->result->ts;
5941 sym->as = gfc_copy_array_spec (sym->result->as);
5942 sym->attr.dimension = sym->result->attr.dimension;
5943 sym->attr.pointer = sym->result->attr.pointer;
5944 sym->attr.allocatable = sym->result->attr.allocatable;
5949 /* Assumed size arrays and assumed shape arrays must be dummy
5953 && (sym->as->type == AS_ASSUMED_SIZE
5954 || sym->as->type == AS_ASSUMED_SHAPE)
5955 && sym->attr.dummy == 0)
5957 if (sym->as->type == AS_ASSUMED_SIZE)
5958 gfc_error ("Assumed size array at %L must be a dummy argument",
5961 gfc_error ("Assumed shape array at %L must be a dummy argument",
5966 /* Make sure symbols with known intent or optional are really dummy
5967 variable. Because of ENTRY statement, this has to be deferred
5968 until resolution time. */
5970 if (!sym->attr.dummy
5971 && (sym->attr.optional
5972 || sym->attr.intent != INTENT_UNKNOWN))
5974 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
5978 if (sym->attr.value && !sym->attr.dummy)
5980 gfc_error ("'%s' at %L cannot have the VALUE attribute because "
5981 "it is not a dummy", sym->name, &sym->declared_at);
5986 /* If a derived type symbol has reached this point, without its
5987 type being declared, we have an error. Notice that most
5988 conditions that produce undefined derived types have already
5989 been dealt with. However, the likes of:
5990 implicit type(t) (t) ..... call foo (t) will get us here if
5991 the type is not declared in the scope of the implicit
5992 statement. Change the type to BT_UNKNOWN, both because it is so
5993 and to prevent an ICE. */
5994 if (sym->ts.type == BT_DERIVED
5995 && sym->ts.derived->components == NULL)
5997 gfc_error ("The derived type '%s' at %L is of type '%s', "
5998 "which has not been defined", sym->name,
5999 &sym->declared_at, sym->ts.derived->name);
6000 sym->ts.type = BT_UNKNOWN;
6004 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
6005 default initialization is defined (5.1.2.4.4). */
6006 if (sym->ts.type == BT_DERIVED
6008 && sym->attr.intent == INTENT_OUT
6010 && sym->as->type == AS_ASSUMED_SIZE)
6012 for (c = sym->ts.derived->components; c; c = c->next)
6016 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
6017 "ASSUMED SIZE and so cannot have a default initializer",
6018 sym->name, &sym->declared_at);
6024 switch (sym->attr.flavor)
6027 if (resolve_fl_variable (sym, mp_flag) == FAILURE)
6032 if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
6037 if (resolve_fl_namelist (sym) == FAILURE)
6042 if (resolve_fl_parameter (sym) == FAILURE)
6050 /* Make sure that intrinsic exist */
6051 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic
6052 && ! gfc_intrinsic_name(sym->name, 0)
6053 && ! gfc_intrinsic_name(sym->name, 1))
6054 gfc_error("Intrinsic at %L does not exist", &sym->declared_at);
6056 /* Resolve array specifier. Check as well some constraints
6057 on COMMON blocks. */
6059 check_constant = sym->attr.in_common && !sym->attr.pointer;
6061 /* Set the formal_arg_flag so that check_conflict will not throw
6062 an error for host associated variables in the specification
6063 expression for an array_valued function. */
6064 if (sym->attr.function && sym->as)
6065 formal_arg_flag = 1;
6067 gfc_resolve_array_spec (sym->as, check_constant);
6069 formal_arg_flag = 0;
6071 /* Resolve formal namespaces. */
6073 if (formal_ns_flag && sym != NULL && sym->formal_ns != NULL)
6075 formal_ns_save = formal_ns_flag;
6077 gfc_resolve (sym->formal_ns);
6078 formal_ns_flag = formal_ns_save;
6081 /* Check threadprivate restrictions. */
6082 if (sym->attr.threadprivate && !sym->attr.save
6083 && (!sym->attr.in_common
6084 && sym->module == NULL
6085 && (sym->ns->proc_name == NULL
6086 || sym->ns->proc_name->attr.flavor != FL_MODULE)))
6087 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
6089 /* If we have come this far we can apply default-initializers, as
6090 described in 14.7.5, to those variables that have not already
6091 been assigned one. */
6092 if (sym->ts.type == BT_DERIVED
6093 && sym->attr.referenced
6094 && sym->ns == gfc_current_ns
6096 && !sym->attr.allocatable
6097 && !sym->attr.alloc_comp)
6099 symbol_attribute *a = &sym->attr;
6101 if ((!a->save && !a->dummy && !a->pointer
6102 && !a->in_common && !a->use_assoc
6103 && !(a->function && sym != sym->result))
6105 (a->dummy && a->intent == INTENT_OUT))
6106 apply_default_init (sym);
6112 /************* Resolve DATA statements *************/
6116 gfc_data_value *vnode;
6122 /* Advance the values structure to point to the next value in the data list. */
6125 next_data_value (void)
6127 while (values.left == 0)
6129 if (values.vnode->next == NULL)
6132 values.vnode = values.vnode->next;
6133 values.left = values.vnode->repeat;
6141 check_data_variable (gfc_data_variable * var, locus * where)
6147 ar_type mark = AR_UNKNOWN;
6149 mpz_t section_index[GFC_MAX_DIMENSIONS];
6153 if (gfc_resolve_expr (var->expr) == FAILURE)
6157 mpz_init_set_si (offset, 0);
6160 if (e->expr_type != EXPR_VARIABLE)
6161 gfc_internal_error ("check_data_variable(): Bad expression");
6163 if (e->symtree->n.sym->ns->is_block_data
6164 && !e->symtree->n.sym->attr.in_common)
6166 gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
6167 e->symtree->n.sym->name, &e->symtree->n.sym->declared_at);
6172 mpz_init_set_ui (size, 1);
6179 /* Find the array section reference. */
6180 for (ref = e->ref; ref; ref = ref->next)
6182 if (ref->type != REF_ARRAY)
6184 if (ref->u.ar.type == AR_ELEMENT)
6190 /* Set marks according to the reference pattern. */
6191 switch (ref->u.ar.type)
6199 /* Get the start position of array section. */
6200 gfc_get_section_index (ar, section_index, &offset);
6208 if (gfc_array_size (e, &size) == FAILURE)
6210 gfc_error ("Nonconstant array section at %L in DATA statement",
6219 while (mpz_cmp_ui (size, 0) > 0)
6221 if (next_data_value () == FAILURE)
6223 gfc_error ("DATA statement at %L has more variables than values",
6229 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
6233 /* If we have more than one element left in the repeat count,
6234 and we have more than one element left in the target variable,
6235 then create a range assignment. */
6236 /* ??? Only done for full arrays for now, since array sections
6238 if (mark == AR_FULL && ref && ref->next == NULL
6239 && values.left > 1 && mpz_cmp_ui (size, 1) > 0)
6243 if (mpz_cmp_ui (size, values.left) >= 0)
6245 mpz_init_set_ui (range, values.left);
6246 mpz_sub_ui (size, size, values.left);
6251 mpz_init_set (range, size);
6252 values.left -= mpz_get_ui (size);
6253 mpz_set_ui (size, 0);
6256 gfc_assign_data_value_range (var->expr, values.vnode->expr,
6259 mpz_add (offset, offset, range);
6263 /* Assign initial value to symbol. */
6267 mpz_sub_ui (size, size, 1);
6269 gfc_assign_data_value (var->expr, values.vnode->expr, offset);
6271 if (mark == AR_FULL)
6272 mpz_add_ui (offset, offset, 1);
6274 /* Modify the array section indexes and recalculate the offset
6275 for next element. */
6276 else if (mark == AR_SECTION)
6277 gfc_advance_section (section_index, ar, &offset);
6281 if (mark == AR_SECTION)
6283 for (i = 0; i < ar->dimen; i++)
6284 mpz_clear (section_index[i]);
6294 static try traverse_data_var (gfc_data_variable *, locus *);
6296 /* Iterate over a list of elements in a DATA statement. */
6299 traverse_data_list (gfc_data_variable * var, locus * where)
6302 iterator_stack frame;
6305 mpz_init (frame.value);
6307 mpz_init_set (trip, var->iter.end->value.integer);
6308 mpz_sub (trip, trip, var->iter.start->value.integer);
6309 mpz_add (trip, trip, var->iter.step->value.integer);
6311 mpz_div (trip, trip, var->iter.step->value.integer);
6313 mpz_set (frame.value, var->iter.start->value.integer);
6315 frame.prev = iter_stack;
6316 frame.variable = var->iter.var->symtree;
6317 iter_stack = &frame;
6319 while (mpz_cmp_ui (trip, 0) > 0)
6321 if (traverse_data_var (var->list, where) == FAILURE)
6327 e = gfc_copy_expr (var->expr);
6328 if (gfc_simplify_expr (e, 1) == FAILURE)
6334 mpz_add (frame.value, frame.value, var->iter.step->value.integer);
6336 mpz_sub_ui (trip, trip, 1);
6340 mpz_clear (frame.value);
6342 iter_stack = frame.prev;
6347 /* Type resolve variables in the variable list of a DATA statement. */
6350 traverse_data_var (gfc_data_variable * var, locus * where)
6354 for (; var; var = var->next)
6356 if (var->expr == NULL)
6357 t = traverse_data_list (var, where);
6359 t = check_data_variable (var, where);
6369 /* Resolve the expressions and iterators associated with a data statement.
6370 This is separate from the assignment checking because data lists should
6371 only be resolved once. */
6374 resolve_data_variables (gfc_data_variable * d)
6376 for (; d; d = d->next)
6378 if (d->list == NULL)
6380 if (gfc_resolve_expr (d->expr) == FAILURE)
6385 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
6388 if (d->iter.start->expr_type != EXPR_CONSTANT
6389 || d->iter.end->expr_type != EXPR_CONSTANT
6390 || d->iter.step->expr_type != EXPR_CONSTANT)
6391 gfc_internal_error ("resolve_data_variables(): Bad iterator");
6393 if (resolve_data_variables (d->list) == FAILURE)
6402 /* Resolve a single DATA statement. We implement this by storing a pointer to
6403 the value list into static variables, and then recursively traversing the
6404 variables list, expanding iterators and such. */
6407 resolve_data (gfc_data * d)
6409 if (resolve_data_variables (d->var) == FAILURE)
6412 values.vnode = d->value;
6413 values.left = (d->value == NULL) ? 0 : d->value->repeat;
6415 if (traverse_data_var (d->var, &d->where) == FAILURE)
6418 /* At this point, we better not have any values left. */
6420 if (next_data_value () == SUCCESS)
6421 gfc_error ("DATA statement at %L has more values than variables",
6426 /* Determines if a variable is not 'pure', ie not assignable within a pure
6427 procedure. Returns zero if assignment is OK, nonzero if there is a problem.
6431 gfc_impure_variable (gfc_symbol * sym)
6433 if (sym->attr.use_assoc || sym->attr.in_common)
6436 if (sym->ns != gfc_current_ns)
6437 return !sym->attr.function;
6439 /* TODO: Check storage association through EQUIVALENCE statements */
6445 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
6446 symbol of the current procedure. */
6449 gfc_pure (gfc_symbol * sym)
6451 symbol_attribute attr;
6454 sym = gfc_current_ns->proc_name;
6460 return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental);
6464 /* Test whether the current procedure is elemental or not. */
6467 gfc_elemental (gfc_symbol * sym)
6469 symbol_attribute attr;
6472 sym = gfc_current_ns->proc_name;
6477 return attr.flavor == FL_PROCEDURE && attr.elemental;
6481 /* Warn about unused labels. */
6484 warn_unused_fortran_label (gfc_st_label * label)
6489 warn_unused_fortran_label (label->left);
6491 if (label->defined == ST_LABEL_UNKNOWN)
6494 switch (label->referenced)
6496 case ST_LABEL_UNKNOWN:
6497 gfc_warning ("Label %d at %L defined but not used", label->value,
6501 case ST_LABEL_BAD_TARGET:
6502 gfc_warning ("Label %d at %L defined but cannot be used",
6503 label->value, &label->where);
6510 warn_unused_fortran_label (label->right);
6514 /* Returns the sequence type of a symbol or sequence. */
6517 sequence_type (gfc_typespec ts)
6526 if (ts.derived->components == NULL)
6527 return SEQ_NONDEFAULT;
6529 result = sequence_type (ts.derived->components->ts);
6530 for (c = ts.derived->components->next; c; c = c->next)
6531 if (sequence_type (c->ts) != result)
6537 if (ts.kind != gfc_default_character_kind)
6538 return SEQ_NONDEFAULT;
6540 return SEQ_CHARACTER;
6543 if (ts.kind != gfc_default_integer_kind)
6544 return SEQ_NONDEFAULT;
6549 if (!(ts.kind == gfc_default_real_kind
6550 || ts.kind == gfc_default_double_kind))
6551 return SEQ_NONDEFAULT;
6556 if (ts.kind != gfc_default_complex_kind)
6557 return SEQ_NONDEFAULT;
6562 if (ts.kind != gfc_default_logical_kind)
6563 return SEQ_NONDEFAULT;
6568 return SEQ_NONDEFAULT;
6573 /* Resolve derived type EQUIVALENCE object. */
6576 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
6579 gfc_component *c = derived->components;
6584 /* Shall not be an object of nonsequence derived type. */
6585 if (!derived->attr.sequence)
6587 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
6588 "attribute to be an EQUIVALENCE object", sym->name, &e->where);
6592 /* Shall not have allocatable components. */
6593 if (derived->attr.alloc_comp)
6595 gfc_error ("Derived type variable '%s' at %L cannot have ALLOCATABLE "
6596 "components to be an EQUIVALENCE object",sym->name, &e->where);
6600 for (; c ; c = c->next)
6603 if (d && (resolve_equivalence_derived (c->ts.derived, sym, e) == FAILURE))
6606 /* Shall not be an object of sequence derived type containing a pointer
6607 in the structure. */
6610 gfc_error ("Derived type variable '%s' at %L with pointer component(s) "
6611 "cannot be an EQUIVALENCE object", sym->name, &e->where);
6617 gfc_error ("Derived type variable '%s' at %L with default initializer "
6618 "cannot be an EQUIVALENCE object", sym->name, &e->where);
6626 /* Resolve equivalence object.
6627 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
6628 an allocatable array, an object of nonsequence derived type, an object of
6629 sequence derived type containing a pointer at any level of component
6630 selection, an automatic object, a function name, an entry name, a result
6631 name, a named constant, a structure component, or a subobject of any of
6632 the preceding objects. A substring shall not have length zero. A
6633 derived type shall not have components with default initialization nor
6634 shall two objects of an equivalence group be initialized.
6635 Either all or none of the objects shall have an protected attribute.
6636 The simple constraints are done in symbol.c(check_conflict) and the rest
6637 are implemented here. */
6640 resolve_equivalence (gfc_equiv *eq)
6643 gfc_symbol *derived;
6644 gfc_symbol *first_sym;
6647 locus *last_where = NULL;
6648 seq_type eq_type, last_eq_type;
6649 gfc_typespec *last_ts;
6650 int object, cnt_protected;
6651 const char *value_name;
6655 last_ts = &eq->expr->symtree->n.sym->ts;
6657 first_sym = eq->expr->symtree->n.sym;
6661 for (object = 1; eq; eq = eq->eq, object++)
6665 e->ts = e->symtree->n.sym->ts;
6666 /* match_varspec might not know yet if it is seeing
6667 array reference or substring reference, as it doesn't
6669 if (e->ref && e->ref->type == REF_ARRAY)
6671 gfc_ref *ref = e->ref;
6672 sym = e->symtree->n.sym;
6674 if (sym->attr.dimension)
6676 ref->u.ar.as = sym->as;
6680 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
6681 if (e->ts.type == BT_CHARACTER
6683 && ref->type == REF_ARRAY
6684 && ref->u.ar.dimen == 1
6685 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
6686 && ref->u.ar.stride[0] == NULL)
6688 gfc_expr *start = ref->u.ar.start[0];
6689 gfc_expr *end = ref->u.ar.end[0];
6692 /* Optimize away the (:) reference. */
6693 if (start == NULL && end == NULL)
6698 e->ref->next = ref->next;
6703 ref->type = REF_SUBSTRING;
6705 start = gfc_int_expr (1);
6706 ref->u.ss.start = start;
6707 if (end == NULL && e->ts.cl)
6708 end = gfc_copy_expr (e->ts.cl->length);
6709 ref->u.ss.end = end;
6710 ref->u.ss.length = e->ts.cl;
6717 /* Any further ref is an error. */
6720 gcc_assert (ref->type == REF_ARRAY);
6721 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
6727 if (gfc_resolve_expr (e) == FAILURE)
6730 sym = e->symtree->n.sym;
6732 if (sym->attr.protected)
6734 if (cnt_protected > 0 && cnt_protected != object)
6736 gfc_error ("Either all or none of the objects in the "
6737 "EQUIVALENCE set at %L shall have the "
6738 "PROTECTED attribute",
6743 /* An equivalence statement cannot have more than one initialized
6747 if (value_name != NULL)
6749 gfc_error ("Initialized objects '%s' and '%s' cannot both "
6750 "be in the EQUIVALENCE statement at %L",
6751 value_name, sym->name, &e->where);
6755 value_name = sym->name;
6758 /* Shall not equivalence common block variables in a PURE procedure. */
6759 if (sym->ns->proc_name
6760 && sym->ns->proc_name->attr.pure
6761 && sym->attr.in_common)
6763 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
6764 "object in the pure procedure '%s'",
6765 sym->name, &e->where, sym->ns->proc_name->name);
6769 /* Shall not be a named constant. */
6770 if (e->expr_type == EXPR_CONSTANT)
6772 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
6773 "object", sym->name, &e->where);
6777 derived = e->ts.derived;
6778 if (derived && resolve_equivalence_derived (derived, sym, e) == FAILURE)
6781 /* Check that the types correspond correctly:
6783 A numeric sequence structure may be equivalenced to another sequence
6784 structure, an object of default integer type, default real type, double
6785 precision real type, default logical type such that components of the
6786 structure ultimately only become associated to objects of the same
6787 kind. A character sequence structure may be equivalenced to an object
6788 of default character kind or another character sequence structure.
6789 Other objects may be equivalenced only to objects of the same type and
6792 /* Identical types are unconditionally OK. */
6793 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
6794 goto identical_types;
6796 last_eq_type = sequence_type (*last_ts);
6797 eq_type = sequence_type (sym->ts);
6799 /* Since the pair of objects is not of the same type, mixed or
6800 non-default sequences can be rejected. */
6802 msg = "Sequence %s with mixed components in EQUIVALENCE "
6803 "statement at %L with different type objects";
6805 && last_eq_type == SEQ_MIXED
6806 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
6807 last_where) == FAILURE)
6808 || (eq_type == SEQ_MIXED
6809 && gfc_notify_std (GFC_STD_GNU, msg,sym->name,
6810 &e->where) == FAILURE))
6813 msg = "Non-default type object or sequence %s in EQUIVALENCE "
6814 "statement at %L with objects of different type";
6816 && last_eq_type == SEQ_NONDEFAULT
6817 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
6818 last_where) == FAILURE)
6819 || (eq_type == SEQ_NONDEFAULT
6820 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
6821 &e->where) == FAILURE))
6824 msg ="Non-CHARACTER object '%s' in default CHARACTER "
6825 "EQUIVALENCE statement at %L";
6826 if (last_eq_type == SEQ_CHARACTER
6827 && eq_type != SEQ_CHARACTER
6828 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
6829 &e->where) == FAILURE)
6832 msg ="Non-NUMERIC object '%s' in default NUMERIC "
6833 "EQUIVALENCE statement at %L";
6834 if (last_eq_type == SEQ_NUMERIC
6835 && eq_type != SEQ_NUMERIC
6836 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
6837 &e->where) == FAILURE)
6842 last_where = &e->where;
6847 /* Shall not be an automatic array. */
6848 if (e->ref->type == REF_ARRAY
6849 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
6851 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
6852 "an EQUIVALENCE object", sym->name, &e->where);
6859 /* Shall not be a structure component. */
6860 if (r->type == REF_COMPONENT)
6862 gfc_error ("Structure component '%s' at %L cannot be an "
6863 "EQUIVALENCE object",
6864 r->u.c.component->name, &e->where);
6868 /* A substring shall not have length zero. */
6869 if (r->type == REF_SUBSTRING)
6871 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
6873 gfc_error ("Substring at %L has length zero",
6874 &r->u.ss.start->where);
6884 /* Resolve function and ENTRY types, issue diagnostics if needed. */
6887 resolve_fntype (gfc_namespace * ns)
6892 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
6895 /* If there are any entries, ns->proc_name is the entry master
6896 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
6898 sym = ns->entries->sym;
6900 sym = ns->proc_name;
6901 if (sym->result == sym
6902 && sym->ts.type == BT_UNKNOWN
6903 && gfc_set_default_type (sym, 0, NULL) == FAILURE
6904 && !sym->attr.untyped)
6906 gfc_error ("Function '%s' at %L has no IMPLICIT type",
6907 sym->name, &sym->declared_at);
6908 sym->attr.untyped = 1;
6911 if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.use_assoc
6912 && !gfc_check_access (sym->ts.derived->attr.access,
6913 sym->ts.derived->ns->default_access)
6914 && gfc_check_access (sym->attr.access, sym->ns->default_access))
6916 gfc_error ("PUBLIC function '%s' at %L cannot be of PRIVATE type '%s'",
6917 sym->name, &sym->declared_at, sym->ts.derived->name);
6920 /* Make sure that the type of a module derived type function is in the
6921 module namespace, by copying it from the namespace's derived type
6922 list, if necessary. */
6923 if (sym->ts.type == BT_DERIVED
6924 && sym->ns->proc_name->attr.flavor == FL_MODULE
6925 && sym->ts.derived->ns
6926 && sym->ns != sym->ts.derived->ns)
6928 gfc_dt_list *dt = sym->ns->derived_types;
6930 for (; dt; dt = dt->next)
6931 if (gfc_compare_derived_types (sym->ts.derived, dt->derived))
6932 sym->ts.derived = dt->derived;
6936 for (el = ns->entries->next; el; el = el->next)
6938 if (el->sym->result == el->sym
6939 && el->sym->ts.type == BT_UNKNOWN
6940 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
6941 && !el->sym->attr.untyped)
6943 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
6944 el->sym->name, &el->sym->declared_at);
6945 el->sym->attr.untyped = 1;
6950 /* 12.3.2.1.1 Defined operators. */
6953 gfc_resolve_uops(gfc_symtree *symtree)
6957 gfc_formal_arglist *formal;
6959 if (symtree == NULL)
6962 gfc_resolve_uops (symtree->left);
6963 gfc_resolve_uops (symtree->right);
6965 for (itr = symtree->n.uop->operator; itr; itr = itr->next)
6968 if (!sym->attr.function)
6969 gfc_error("User operator procedure '%s' at %L must be a FUNCTION",
6970 sym->name, &sym->declared_at);
6972 if (sym->ts.type == BT_CHARACTER
6973 && !(sym->ts.cl && sym->ts.cl->length)
6974 && !(sym->result && sym->result->ts.cl && sym->result->ts.cl->length))
6975 gfc_error("User operator procedure '%s' at %L cannot be assumed character "
6976 "length", sym->name, &sym->declared_at);
6978 formal = sym->formal;
6979 if (!formal || !formal->sym)
6981 gfc_error("User operator procedure '%s' at %L must have at least "
6982 "one argument", sym->name, &sym->declared_at);
6986 if (formal->sym->attr.intent != INTENT_IN)
6987 gfc_error ("First argument of operator interface at %L must be "
6988 "INTENT(IN)", &sym->declared_at);
6990 if (formal->sym->attr.optional)
6991 gfc_error ("First argument of operator interface at %L cannot be "
6992 "optional", &sym->declared_at);
6994 formal = formal->next;
6995 if (!formal || !formal->sym)
6998 if (formal->sym->attr.intent != INTENT_IN)
6999 gfc_error ("Second argument of operator interface at %L must be "
7000 "INTENT(IN)", &sym->declared_at);
7002 if (formal->sym->attr.optional)
7003 gfc_error ("Second argument of operator interface at %L cannot be "
7004 "optional", &sym->declared_at);
7007 gfc_error ("Operator interface at %L must have, at most, two "
7008 "arguments", &sym->declared_at);
7013 /* Examine all of the expressions associated with a program unit,
7014 assign types to all intermediate expressions, make sure that all
7015 assignments are to compatible types and figure out which names
7016 refer to which functions or subroutines. It doesn't check code
7017 block, which is handled by resolve_code. */
7020 resolve_types (gfc_namespace * ns)
7027 gfc_current_ns = ns;
7029 resolve_entries (ns);
7031 resolve_contained_functions (ns);
7033 gfc_traverse_ns (ns, resolve_symbol);
7035 resolve_fntype (ns);
7037 for (n = ns->contained; n; n = n->sibling)
7039 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
7040 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
7041 "also be PURE", n->proc_name->name,
7042 &n->proc_name->declared_at);
7048 gfc_check_interfaces (ns);
7050 for (cl = ns->cl_list; cl; cl = cl->next)
7051 resolve_charlen (cl);
7053 gfc_traverse_ns (ns, resolve_values);
7059 for (d = ns->data; d; d = d->next)
7063 gfc_traverse_ns (ns, gfc_formalize_init_value);
7065 for (eq = ns->equiv; eq; eq = eq->next)
7066 resolve_equivalence (eq);
7068 /* Warn about unused labels. */
7069 if (warn_unused_label)
7070 warn_unused_fortran_label (ns->st_labels);
7072 gfc_resolve_uops (ns->uop_root);
7076 /* Call resolve_code recursively. */
7079 resolve_codes (gfc_namespace * ns)
7083 for (n = ns->contained; n; n = n->sibling)
7086 gfc_current_ns = ns;
7088 /* Set to an out of range value. */
7089 current_entry_id = -1;
7090 resolve_code (ns->code, ns);
7094 /* This function is called after a complete program unit has been compiled.
7095 Its purpose is to examine all of the expressions associated with a program
7096 unit, assign types to all intermediate expressions, make sure that all
7097 assignments are to compatible types and figure out which names refer to
7098 which functions or subroutines. */
7101 gfc_resolve (gfc_namespace * ns)
7103 gfc_namespace *old_ns;
7105 old_ns = gfc_current_ns;
7110 gfc_current_ns = old_ns;