1 /* Perform type resolution on the various stuctures.
2 Copyright (C) 2001, 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 2, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING. If not, write to the Free
19 Software Foundation, 51 Franklin Street, Fifth Floor,Boston, MA
26 #include "arith.h" /* For gfc_compare_expr(). */
28 /* Types used in equivalence statements. */
32 SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED
36 /* Stack to push the current if we descend into a block during
37 resolution. See resolve_branch() and resolve_code(). */
39 typedef struct code_stack
41 struct gfc_code *head, *current;
42 struct code_stack *prev;
46 static code_stack *cs_base = NULL;
49 /* Nonzero if we're inside a FORALL block */
51 static int forall_flag;
53 /* Nonzero if we are processing a formal arglist. The corresponding function
54 resets the flag each time that it is read. */
55 static int formal_arg_flag = 0;
58 gfc_is_formal_arg (void)
60 return formal_arg_flag;
63 /* Resolve types of formal argument lists. These have to be done early so that
64 the formal argument lists of module procedures can be copied to the
65 containing module before the individual procedures are resolved
66 individually. We also resolve argument lists of procedures in interface
67 blocks because they are self-contained scoping units.
69 Since a dummy argument cannot be a non-dummy procedure, the only
70 resort left for untyped names are the IMPLICIT types. */
73 resolve_formal_arglist (gfc_symbol * proc)
75 gfc_formal_arglist *f;
79 /* TODO: Procedures whose return character length parameter is not constant
80 or assumed must also have explicit interfaces. */
81 if (proc->result != NULL)
86 if (gfc_elemental (proc)
87 || sym->attr.pointer || sym->attr.allocatable
88 || (sym->as && sym->as->rank > 0))
89 proc->attr.always_explicit = 1;
93 for (f = proc->formal; f; f = f->next)
99 /* Alternate return placeholder. */
100 if (gfc_elemental (proc))
101 gfc_error ("Alternate return specifier in elemental subroutine "
102 "'%s' at %L is not allowed", proc->name,
104 if (proc->attr.function)
105 gfc_error ("Alternate return specifier in function "
106 "'%s' at %L is not allowed", proc->name,
111 if (sym->attr.if_source != IFSRC_UNKNOWN)
112 resolve_formal_arglist (sym);
114 if (sym->attr.subroutine || sym->attr.external || sym->attr.intrinsic)
116 if (gfc_pure (proc) && !gfc_pure (sym))
119 ("Dummy procedure '%s' of PURE procedure at %L must also "
120 "be PURE", sym->name, &sym->declared_at);
124 if (gfc_elemental (proc))
127 ("Dummy procedure at %L not allowed in ELEMENTAL procedure",
135 if (sym->ts.type == BT_UNKNOWN)
137 if (!sym->attr.function || sym->result == sym)
138 gfc_set_default_type (sym, 1, sym->ns);
141 /* Set the type of the RESULT, then copy. */
142 if (sym->result->ts.type == BT_UNKNOWN)
143 gfc_set_default_type (sym->result, 1, sym->result->ns);
145 sym->ts = sym->result->ts;
147 sym->as = gfc_copy_array_spec (sym->result->as);
151 gfc_resolve_array_spec (sym->as, 0);
153 /* We can't tell if an array with dimension (:) is assumed or deferred
154 shape until we know if it has the pointer or allocatable attributes.
156 if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
157 && !(sym->attr.pointer || sym->attr.allocatable))
159 sym->as->type = AS_ASSUMED_SHAPE;
160 for (i = 0; i < sym->as->rank; i++)
161 sym->as->lower[i] = gfc_int_expr (1);
164 if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
165 || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
166 || sym->attr.optional)
167 proc->attr.always_explicit = 1;
169 /* If the flavor is unknown at this point, it has to be a variable.
170 A procedure specification would have already set the type. */
172 if (sym->attr.flavor == FL_UNKNOWN)
173 gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
177 if (proc->attr.function && !sym->attr.pointer
178 && sym->attr.flavor != FL_PROCEDURE
179 && sym->attr.intent != INTENT_IN)
181 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
182 "INTENT(IN)", sym->name, proc->name,
185 if (proc->attr.subroutine && !sym->attr.pointer
186 && sym->attr.intent == INTENT_UNKNOWN)
189 ("Argument '%s' of pure subroutine '%s' at %L must have "
190 "its INTENT specified", sym->name, proc->name,
195 if (gfc_elemental (proc))
200 ("Argument '%s' of elemental procedure at %L must be scalar",
201 sym->name, &sym->declared_at);
205 if (sym->attr.pointer)
208 ("Argument '%s' of elemental procedure at %L cannot have "
209 "the POINTER attribute", sym->name, &sym->declared_at);
214 /* Each dummy shall be specified to be scalar. */
215 if (proc->attr.proc == PROC_ST_FUNCTION)
220 ("Argument '%s' of statement function at %L must be scalar",
221 sym->name, &sym->declared_at);
225 if (sym->ts.type == BT_CHARACTER)
227 gfc_charlen *cl = sym->ts.cl;
228 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
231 ("Character-valued argument '%s' of statement function at "
232 "%L must has constant length",
233 sym->name, &sym->declared_at);
243 /* Work function called when searching for symbols that have argument lists
244 associated with them. */
247 find_arglists (gfc_symbol * sym)
250 if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
253 resolve_formal_arglist (sym);
257 /* Given a namespace, resolve all formal argument lists within the namespace.
261 resolve_formal_arglists (gfc_namespace * ns)
267 gfc_traverse_ns (ns, find_arglists);
272 resolve_contained_fntype (gfc_symbol * sym, gfc_namespace * ns)
276 /* If this namespace is not a function, ignore it. */
278 || !(sym->attr.function
279 || sym->attr.flavor == FL_VARIABLE))
282 /* Try to find out of what the return type is. */
283 if (sym->result != NULL)
286 if (sym->ts.type == BT_UNKNOWN)
288 t = gfc_set_default_type (sym, 0, ns);
290 if (t == FAILURE && !sym->attr.untyped)
292 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
293 sym->name, &sym->declared_at); /* FIXME */
294 sym->attr.untyped = 1;
300 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
301 introduce duplicates. */
304 merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
306 gfc_formal_arglist *f, *new_arglist;
309 for (; new_args != NULL; new_args = new_args->next)
311 new_sym = new_args->sym;
312 /* See if ths arg is already in the formal argument list. */
313 for (f = proc->formal; f; f = f->next)
315 if (new_sym == f->sym)
322 /* Add a new argument. Argument order is not important. */
323 new_arglist = gfc_get_formal_arglist ();
324 new_arglist->sym = new_sym;
325 new_arglist->next = proc->formal;
326 proc->formal = new_arglist;
331 /* Resolve alternate entry points. If a symbol has multiple entry points we
332 create a new master symbol for the main routine, and turn the existing
333 symbol into an entry point. */
336 resolve_entries (gfc_namespace * ns)
338 gfc_namespace *old_ns;
342 char name[GFC_MAX_SYMBOL_LEN + 1];
343 static int master_count = 0;
345 if (ns->proc_name == NULL)
348 /* No need to do anything if this procedure doesn't have alternate entry
353 /* We may already have resolved alternate entry points. */
354 if (ns->proc_name->attr.entry_master)
357 /* If this isn't a procedure something has gone horribly wrong. */
358 gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
360 /* Remember the current namespace. */
361 old_ns = gfc_current_ns;
365 /* Add the main entry point to the list of entry points. */
366 el = gfc_get_entry_list ();
367 el->sym = ns->proc_name;
369 el->next = ns->entries;
371 ns->proc_name->attr.entry = 1;
373 /* Add an entry statement for it. */
380 /* Create a new symbol for the master function. */
381 /* Give the internal function a unique name (within this file).
382 Also include the function name so the user has some hope of figuring
383 out what is going on. */
384 snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
385 master_count++, ns->proc_name->name);
386 gfc_get_ha_symbol (name, &proc);
387 gcc_assert (proc != NULL);
389 gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
390 if (ns->proc_name->attr.subroutine)
391 gfc_add_subroutine (&proc->attr, proc->name, NULL);
395 gfc_typespec *ts, *fts;
397 gfc_add_function (&proc->attr, proc->name, NULL);
399 fts = &ns->entries->sym->result->ts;
400 if (fts->type == BT_UNKNOWN)
401 fts = gfc_get_default_type (ns->entries->sym->result, NULL);
402 for (el = ns->entries->next; el; el = el->next)
404 ts = &el->sym->result->ts;
405 if (ts->type == BT_UNKNOWN)
406 ts = gfc_get_default_type (el->sym->result, NULL);
407 if (! gfc_compare_types (ts, fts)
408 || (el->sym->result->attr.dimension
409 != ns->entries->sym->result->attr.dimension)
410 || (el->sym->result->attr.pointer
411 != ns->entries->sym->result->attr.pointer))
417 sym = ns->entries->sym->result;
418 /* All result types the same. */
420 if (sym->attr.dimension)
421 gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL);
422 if (sym->attr.pointer)
423 gfc_add_pointer (&proc->attr, NULL);
427 /* Otherwise the result will be passed through a union by
429 proc->attr.mixed_entry_master = 1;
430 for (el = ns->entries; el; el = el->next)
432 sym = el->sym->result;
433 if (sym->attr.dimension)
435 if (el == ns->entries)
437 ("FUNCTION result %s can't be an array in FUNCTION %s at %L",
438 sym->name, ns->entries->sym->name, &sym->declared_at);
441 ("ENTRY result %s can't be an array in FUNCTION %s at %L",
442 sym->name, ns->entries->sym->name, &sym->declared_at);
444 else if (sym->attr.pointer)
446 if (el == ns->entries)
448 ("FUNCTION result %s can't be a POINTER in FUNCTION %s at %L",
449 sym->name, ns->entries->sym->name, &sym->declared_at);
452 ("ENTRY result %s can't be a POINTER in FUNCTION %s at %L",
453 sym->name, ns->entries->sym->name, &sym->declared_at);
458 if (ts->type == BT_UNKNOWN)
459 ts = gfc_get_default_type (sym, NULL);
463 if (ts->kind == gfc_default_integer_kind)
467 if (ts->kind == gfc_default_real_kind
468 || ts->kind == gfc_default_double_kind)
472 if (ts->kind == gfc_default_complex_kind)
476 if (ts->kind == gfc_default_logical_kind)
480 /* We will issue error elsewhere. */
488 if (el == ns->entries)
490 ("FUNCTION result %s can't be of type %s in FUNCTION %s at %L",
491 sym->name, gfc_typename (ts), ns->entries->sym->name,
495 ("ENTRY result %s can't be of type %s in FUNCTION %s at %L",
496 sym->name, gfc_typename (ts), ns->entries->sym->name,
503 proc->attr.access = ACCESS_PRIVATE;
504 proc->attr.entry_master = 1;
506 /* Merge all the entry point arguments. */
507 for (el = ns->entries; el; el = el->next)
508 merge_argument_lists (proc, el->sym->formal);
510 /* Use the master function for the function body. */
511 ns->proc_name = proc;
513 /* Finalize the new symbols. */
514 gfc_commit_symbols ();
516 /* Restore the original namespace. */
517 gfc_current_ns = old_ns;
521 /* Resolve contained function types. Because contained functions can call one
522 another, they have to be worked out before any of the contained procedures
525 The good news is that if a function doesn't already have a type, the only
526 way it can get one is through an IMPLICIT type or a RESULT variable, because
527 by definition contained functions are contained namespace they're contained
528 in, not in a sibling or parent namespace. */
531 resolve_contained_functions (gfc_namespace * ns)
533 gfc_namespace *child;
536 resolve_formal_arglists (ns);
538 for (child = ns->contained; child; child = child->sibling)
540 /* Resolve alternate entry points first. */
541 resolve_entries (child);
543 /* Then check function return types. */
544 resolve_contained_fntype (child->proc_name, child);
545 for (el = child->entries; el; el = el->next)
546 resolve_contained_fntype (el->sym, child);
551 /* Resolve all of the elements of a structure constructor and make sure that
552 the types are correct. */
555 resolve_structure_cons (gfc_expr * expr)
557 gfc_constructor *cons;
562 cons = expr->value.constructor;
563 /* A constructor may have references if it is the result of substituting a
564 parameter variable. In this case we just pull out the component we
567 comp = expr->ref->u.c.sym->components;
569 comp = expr->ts.derived->components;
571 for (; comp; comp = comp->next, cons = cons->next)
579 if (gfc_resolve_expr (cons->expr) == FAILURE)
585 /* If we don't have the right type, try to convert it. */
587 if (!gfc_compare_types (&cons->expr->ts, &comp->ts)
588 && gfc_convert_type (cons->expr, &comp->ts, 1) == FAILURE)
597 /****************** Expression name resolution ******************/
599 /* Returns 0 if a symbol was not declared with a type or
600 attribute declaration statement, nonzero otherwise. */
603 was_declared (gfc_symbol * sym)
609 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
612 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
613 || a.optional || a.pointer || a.save || a.target
614 || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
621 /* Determine if a symbol is generic or not. */
624 generic_sym (gfc_symbol * sym)
628 if (sym->attr.generic ||
629 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
632 if (was_declared (sym) || sym->ns->parent == NULL)
635 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
637 return (s == NULL) ? 0 : generic_sym (s);
641 /* Determine if a symbol is specific or not. */
644 specific_sym (gfc_symbol * sym)
648 if (sym->attr.if_source == IFSRC_IFBODY
649 || sym->attr.proc == PROC_MODULE
650 || sym->attr.proc == PROC_INTERNAL
651 || sym->attr.proc == PROC_ST_FUNCTION
652 || (sym->attr.intrinsic &&
653 gfc_specific_intrinsic (sym->name))
654 || sym->attr.external)
657 if (was_declared (sym) || sym->ns->parent == NULL)
660 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
662 return (s == NULL) ? 0 : specific_sym (s);
666 /* Figure out if the procedure is specific, generic or unknown. */
669 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
673 procedure_kind (gfc_symbol * sym)
676 if (generic_sym (sym))
677 return PTYPE_GENERIC;
679 if (specific_sym (sym))
680 return PTYPE_SPECIFIC;
682 return PTYPE_UNKNOWN;
686 /* Resolve an actual argument list. Most of the time, this is just
687 resolving the expressions in the list.
688 The exception is that we sometimes have to decide whether arguments
689 that look like procedure arguments are really simple variable
693 resolve_actual_arglist (gfc_actual_arglist * arg)
696 gfc_symtree *parent_st;
699 for (; arg; arg = arg->next)
705 /* Check the label is a valid branching target. */
708 if (arg->label->defined == ST_LABEL_UNKNOWN)
710 gfc_error ("Label %d referenced at %L is never defined",
711 arg->label->value, &arg->label->where);
718 if (e->ts.type != BT_PROCEDURE)
720 if (gfc_resolve_expr (e) != SUCCESS)
725 /* See if the expression node should really be a variable
728 sym = e->symtree->n.sym;
730 if (sym->attr.flavor == FL_PROCEDURE
731 || sym->attr.intrinsic
732 || sym->attr.external)
735 if (sym->attr.proc == PROC_ST_FUNCTION)
737 gfc_error ("Statement function '%s' at %L is not allowed as an "
738 "actual argument", sym->name, &e->where);
741 /* If the symbol is the function that names the current (or
742 parent) scope, then we really have a variable reference. */
744 if (sym->attr.function && sym->result == sym
745 && (sym->ns->proc_name == sym
746 || (sym->ns->parent != NULL
747 && sym->ns->parent->proc_name == sym)))
753 /* See if the name is a module procedure in a parent unit. */
755 if (was_declared (sym) || sym->ns->parent == NULL)
758 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
760 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
764 if (parent_st == NULL)
767 sym = parent_st->n.sym;
768 e->symtree = parent_st; /* Point to the right thing. */
770 if (sym->attr.flavor == FL_PROCEDURE
771 || sym->attr.intrinsic
772 || sym->attr.external)
778 e->expr_type = EXPR_VARIABLE;
782 e->rank = sym->as->rank;
783 e->ref = gfc_get_ref ();
784 e->ref->type = REF_ARRAY;
785 e->ref->u.ar.type = AR_FULL;
786 e->ref->u.ar.as = sym->as;
794 /************* Function resolution *************/
796 /* Resolve a function call known to be generic.
797 Section 14.1.2.4.1. */
800 resolve_generic_f0 (gfc_expr * expr, gfc_symbol * sym)
804 if (sym->attr.generic)
807 gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
810 expr->value.function.name = s->name;
811 expr->value.function.esym = s;
814 expr->rank = s->as->rank;
818 /* TODO: Need to search for elemental references in generic interface */
821 if (sym->attr.intrinsic)
822 return gfc_intrinsic_func_interface (expr, 0);
829 resolve_generic_f (gfc_expr * expr)
834 sym = expr->symtree->n.sym;
838 m = resolve_generic_f0 (expr, sym);
841 else if (m == MATCH_ERROR)
845 if (sym->ns->parent == NULL)
847 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
851 if (!generic_sym (sym))
855 /* Last ditch attempt. */
857 if (!gfc_generic_intrinsic (expr->symtree->n.sym->name))
859 gfc_error ("Generic function '%s' at %L is not an intrinsic function",
860 expr->symtree->n.sym->name, &expr->where);
864 m = gfc_intrinsic_func_interface (expr, 0);
869 ("Generic function '%s' at %L is not consistent with a specific "
870 "intrinsic interface", expr->symtree->n.sym->name, &expr->where);
876 /* Resolve a function call known to be specific. */
879 resolve_specific_f0 (gfc_symbol * sym, gfc_expr * expr)
883 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
887 sym->attr.proc = PROC_DUMMY;
891 sym->attr.proc = PROC_EXTERNAL;
895 if (sym->attr.proc == PROC_MODULE
896 || sym->attr.proc == PROC_ST_FUNCTION
897 || sym->attr.proc == PROC_INTERNAL)
900 if (sym->attr.intrinsic)
902 m = gfc_intrinsic_func_interface (expr, 1);
907 ("Function '%s' at %L is INTRINSIC but is not compatible with "
908 "an intrinsic", sym->name, &expr->where);
916 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
919 expr->value.function.name = sym->name;
920 expr->value.function.esym = sym;
922 expr->rank = sym->as->rank;
929 resolve_specific_f (gfc_expr * expr)
934 sym = expr->symtree->n.sym;
938 m = resolve_specific_f0 (sym, expr);
941 if (m == MATCH_ERROR)
944 if (sym->ns->parent == NULL)
947 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
953 gfc_error ("Unable to resolve the specific function '%s' at %L",
954 expr->symtree->n.sym->name, &expr->where);
960 /* Resolve a procedure call not known to be generic nor specific. */
963 resolve_unknown_f (gfc_expr * expr)
968 sym = expr->symtree->n.sym;
972 sym->attr.proc = PROC_DUMMY;
973 expr->value.function.name = sym->name;
977 /* See if we have an intrinsic function reference. */
979 if (gfc_intrinsic_name (sym->name, 0))
981 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
986 /* The reference is to an external name. */
988 sym->attr.proc = PROC_EXTERNAL;
989 expr->value.function.name = sym->name;
990 expr->value.function.esym = expr->symtree->n.sym;
993 expr->rank = sym->as->rank;
995 /* Type of the expression is either the type of the symbol or the
996 default type of the symbol. */
999 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
1001 if (sym->ts.type != BT_UNKNOWN)
1005 ts = gfc_get_default_type (sym, sym->ns);
1007 if (ts->type == BT_UNKNOWN)
1009 gfc_error ("Function '%s' at %L has no IMPLICIT type",
1010 sym->name, &expr->where);
1021 /* Figure out if a function reference is pure or not. Also set the name
1022 of the function for a potential error message. Return nonzero if the
1023 function is PURE, zero if not. */
1026 pure_function (gfc_expr * e, const char **name)
1030 if (e->value.function.esym)
1032 pure = gfc_pure (e->value.function.esym);
1033 *name = e->value.function.esym->name;
1035 else if (e->value.function.isym)
1037 pure = e->value.function.isym->pure
1038 || e->value.function.isym->elemental;
1039 *name = e->value.function.isym->name;
1043 /* Implicit functions are not pure. */
1045 *name = e->value.function.name;
1052 /* Resolve a function call, which means resolving the arguments, then figuring
1053 out which entity the name refers to. */
1054 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
1055 to INTENT(OUT) or INTENT(INOUT). */
1058 resolve_function (gfc_expr * expr)
1060 gfc_actual_arglist *arg;
1064 if (resolve_actual_arglist (expr->value.function.actual) == FAILURE)
1067 /* See if function is already resolved. */
1069 if (expr->value.function.name != NULL)
1071 if (expr->ts.type == BT_UNKNOWN)
1072 expr->ts = expr->symtree->n.sym->ts;
1077 /* Apply the rules of section 14.1.2. */
1079 switch (procedure_kind (expr->symtree->n.sym))
1082 t = resolve_generic_f (expr);
1085 case PTYPE_SPECIFIC:
1086 t = resolve_specific_f (expr);
1090 t = resolve_unknown_f (expr);
1094 gfc_internal_error ("resolve_function(): bad function type");
1098 /* If the expression is still a function (it might have simplified),
1099 then we check to see if we are calling an elemental function. */
1101 if (expr->expr_type != EXPR_FUNCTION)
1104 if (expr->value.function.actual != NULL
1105 && ((expr->value.function.esym != NULL
1106 && expr->value.function.esym->attr.elemental)
1107 || (expr->value.function.isym != NULL
1108 && expr->value.function.isym->elemental)))
1111 /* The rank of an elemental is the rank of its array argument(s). */
1113 for (arg = expr->value.function.actual; arg; arg = arg->next)
1115 if (arg->expr != NULL && arg->expr->rank > 0)
1117 expr->rank = arg->expr->rank;
1123 if (!pure_function (expr, &name))
1128 ("Function reference to '%s' at %L is inside a FORALL block",
1129 name, &expr->where);
1132 else if (gfc_pure (NULL))
1134 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
1135 "procedure within a PURE procedure", name, &expr->where);
1144 /************* Subroutine resolution *************/
1147 pure_subroutine (gfc_code * c, gfc_symbol * sym)
1154 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
1155 sym->name, &c->loc);
1156 else if (gfc_pure (NULL))
1157 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
1163 resolve_generic_s0 (gfc_code * c, gfc_symbol * sym)
1167 if (sym->attr.generic)
1169 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
1172 c->resolved_sym = s;
1173 pure_subroutine (c, s);
1177 /* TODO: Need to search for elemental references in generic interface. */
1180 if (sym->attr.intrinsic)
1181 return gfc_intrinsic_sub_interface (c, 0);
1188 resolve_generic_s (gfc_code * c)
1193 sym = c->symtree->n.sym;
1195 m = resolve_generic_s0 (c, sym);
1198 if (m == MATCH_ERROR)
1201 if (sym->ns->parent != NULL)
1203 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1206 m = resolve_generic_s0 (c, sym);
1209 if (m == MATCH_ERROR)
1214 /* Last ditch attempt. */
1216 if (!gfc_generic_intrinsic (sym->name))
1219 ("Generic subroutine '%s' at %L is not an intrinsic subroutine",
1220 sym->name, &c->loc);
1224 m = gfc_intrinsic_sub_interface (c, 0);
1228 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
1229 "intrinsic subroutine interface", sym->name, &c->loc);
1235 /* Resolve a subroutine call known to be specific. */
1238 resolve_specific_s0 (gfc_code * c, gfc_symbol * sym)
1242 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1244 if (sym->attr.dummy)
1246 sym->attr.proc = PROC_DUMMY;
1250 sym->attr.proc = PROC_EXTERNAL;
1254 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
1257 if (sym->attr.intrinsic)
1259 m = gfc_intrinsic_sub_interface (c, 1);
1263 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
1264 "with an intrinsic", sym->name, &c->loc);
1272 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
1274 c->resolved_sym = sym;
1275 pure_subroutine (c, sym);
1282 resolve_specific_s (gfc_code * c)
1287 sym = c->symtree->n.sym;
1289 m = resolve_specific_s0 (c, sym);
1292 if (m == MATCH_ERROR)
1295 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1299 m = resolve_specific_s0 (c, sym);
1302 if (m == MATCH_ERROR)
1306 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
1307 sym->name, &c->loc);
1313 /* Resolve a subroutine call not known to be generic nor specific. */
1316 resolve_unknown_s (gfc_code * c)
1320 sym = c->symtree->n.sym;
1322 if (sym->attr.dummy)
1324 sym->attr.proc = PROC_DUMMY;
1328 /* See if we have an intrinsic function reference. */
1330 if (gfc_intrinsic_name (sym->name, 1))
1332 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
1337 /* The reference is to an external name. */
1340 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
1342 c->resolved_sym = sym;
1344 pure_subroutine (c, sym);
1350 /* Resolve a subroutine call. Although it was tempting to use the same code
1351 for functions, subroutines and functions are stored differently and this
1352 makes things awkward. */
1355 resolve_call (gfc_code * c)
1359 if (resolve_actual_arglist (c->ext.actual) == FAILURE)
1362 if (c->resolved_sym != NULL)
1365 switch (procedure_kind (c->symtree->n.sym))
1368 t = resolve_generic_s (c);
1371 case PTYPE_SPECIFIC:
1372 t = resolve_specific_s (c);
1376 t = resolve_unknown_s (c);
1380 gfc_internal_error ("resolve_subroutine(): bad function type");
1386 /* Compare the shapes of two arrays that have non-NULL shapes. If both
1387 op1->shape and op2->shape are non-NULL return SUCCESS if their shapes
1388 match. If both op1->shape and op2->shape are non-NULL return FAILURE
1389 if their shapes do not match. If either op1->shape or op2->shape is
1390 NULL, return SUCCESS. */
1393 compare_shapes (gfc_expr * op1, gfc_expr * op2)
1400 if (op1->shape != NULL && op2->shape != NULL)
1402 for (i = 0; i < op1->rank; i++)
1404 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0)
1406 gfc_error ("Shapes for operands at %L and %L are not conformable",
1407 &op1->where, &op2->where);
1417 /* Resolve an operator expression node. This can involve replacing the
1418 operation with a user defined function call. */
1421 resolve_operator (gfc_expr * e)
1423 gfc_expr *op1, *op2;
1427 /* Resolve all subnodes-- give them types. */
1429 switch (e->value.op.operator)
1432 if (gfc_resolve_expr (e->value.op.op2) == FAILURE)
1435 /* Fall through... */
1438 case INTRINSIC_UPLUS:
1439 case INTRINSIC_UMINUS:
1440 if (gfc_resolve_expr (e->value.op.op1) == FAILURE)
1445 /* Typecheck the new node. */
1447 op1 = e->value.op.op1;
1448 op2 = e->value.op.op2;
1450 switch (e->value.op.operator)
1452 case INTRINSIC_UPLUS:
1453 case INTRINSIC_UMINUS:
1454 if (op1->ts.type == BT_INTEGER
1455 || op1->ts.type == BT_REAL
1456 || op1->ts.type == BT_COMPLEX)
1462 sprintf (msg, _("Operand of unary numeric operator '%s' at %%L is %s"),
1463 gfc_op2string (e->value.op.operator), gfc_typename (&e->ts));
1466 case INTRINSIC_PLUS:
1467 case INTRINSIC_MINUS:
1468 case INTRINSIC_TIMES:
1469 case INTRINSIC_DIVIDE:
1470 case INTRINSIC_POWER:
1471 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
1473 gfc_type_convert_binary (e);
1478 _("Operands of binary numeric operator '%s' at %%L are %s/%s"),
1479 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
1480 gfc_typename (&op2->ts));
1483 case INTRINSIC_CONCAT:
1484 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1486 e->ts.type = BT_CHARACTER;
1487 e->ts.kind = op1->ts.kind;
1492 _("Operands of string concatenation operator at %%L are %s/%s"),
1493 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
1499 case INTRINSIC_NEQV:
1500 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
1502 e->ts.type = BT_LOGICAL;
1503 e->ts.kind = gfc_kind_max (op1, op2);
1504 if (op1->ts.kind < e->ts.kind)
1505 gfc_convert_type (op1, &e->ts, 2);
1506 else if (op2->ts.kind < e->ts.kind)
1507 gfc_convert_type (op2, &e->ts, 2);
1511 sprintf (msg, _("Operands of logical operator '%s' at %%L are %s/%s"),
1512 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
1513 gfc_typename (&op2->ts));
1518 if (op1->ts.type == BT_LOGICAL)
1520 e->ts.type = BT_LOGICAL;
1521 e->ts.kind = op1->ts.kind;
1525 sprintf (msg, _("Operand of .NOT. operator at %%L is %s"),
1526 gfc_typename (&op1->ts));
1533 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
1535 strcpy (msg, _("COMPLEX quantities cannot be compared at %L"));
1539 /* Fall through... */
1543 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1545 e->ts.type = BT_LOGICAL;
1546 e->ts.kind = gfc_default_logical_kind;
1550 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
1552 gfc_type_convert_binary (e);
1554 e->ts.type = BT_LOGICAL;
1555 e->ts.kind = gfc_default_logical_kind;
1559 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
1561 _("Logicals at %%L must be compared with %s instead of %s"),
1562 e->value.op.operator == INTRINSIC_EQ ? ".EQV." : ".NEQV.",
1563 gfc_op2string (e->value.op.operator));
1566 _("Operands of comparison operator '%s' at %%L are %s/%s"),
1567 gfc_op2string (e->value.op.operator), gfc_typename (&op1->ts),
1568 gfc_typename (&op2->ts));
1572 case INTRINSIC_USER:
1574 sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
1575 e->value.op.uop->name, gfc_typename (&op1->ts));
1577 sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
1578 e->value.op.uop->name, gfc_typename (&op1->ts),
1579 gfc_typename (&op2->ts));
1584 gfc_internal_error ("resolve_operator(): Bad intrinsic");
1587 /* Deal with arrayness of an operand through an operator. */
1591 switch (e->value.op.operator)
1593 case INTRINSIC_PLUS:
1594 case INTRINSIC_MINUS:
1595 case INTRINSIC_TIMES:
1596 case INTRINSIC_DIVIDE:
1597 case INTRINSIC_POWER:
1598 case INTRINSIC_CONCAT:
1602 case INTRINSIC_NEQV:
1610 if (op1->rank == 0 && op2->rank == 0)
1613 if (op1->rank == 0 && op2->rank != 0)
1615 e->rank = op2->rank;
1617 if (e->shape == NULL)
1618 e->shape = gfc_copy_shape (op2->shape, op2->rank);
1621 if (op1->rank != 0 && op2->rank == 0)
1623 e->rank = op1->rank;
1625 if (e->shape == NULL)
1626 e->shape = gfc_copy_shape (op1->shape, op1->rank);
1629 if (op1->rank != 0 && op2->rank != 0)
1631 if (op1->rank == op2->rank)
1633 e->rank = op1->rank;
1634 if (e->shape == NULL)
1636 t = compare_shapes(op1, op2);
1640 e->shape = gfc_copy_shape (op1->shape, op1->rank);
1645 gfc_error ("Inconsistent ranks for operator at %L and %L",
1646 &op1->where, &op2->where);
1649 /* Allow higher level expressions to work. */
1657 case INTRINSIC_UPLUS:
1658 case INTRINSIC_UMINUS:
1659 e->rank = op1->rank;
1661 if (e->shape == NULL)
1662 e->shape = gfc_copy_shape (op1->shape, op1->rank);
1664 /* Simply copy arrayness attribute */
1671 /* Attempt to simplify the expression. */
1673 t = gfc_simplify_expr (e, 0);
1678 if (gfc_extend_expr (e) == SUCCESS)
1681 gfc_error (msg, &e->where);
1687 /************** Array resolution subroutines **************/
1691 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
1694 /* Compare two integer expressions. */
1697 compare_bound (gfc_expr * a, gfc_expr * b)
1701 if (a == NULL || a->expr_type != EXPR_CONSTANT
1702 || b == NULL || b->expr_type != EXPR_CONSTANT)
1705 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
1706 gfc_internal_error ("compare_bound(): Bad expression");
1708 i = mpz_cmp (a->value.integer, b->value.integer);
1718 /* Compare an integer expression with an integer. */
1721 compare_bound_int (gfc_expr * a, int b)
1725 if (a == NULL || a->expr_type != EXPR_CONSTANT)
1728 if (a->ts.type != BT_INTEGER)
1729 gfc_internal_error ("compare_bound_int(): Bad expression");
1731 i = mpz_cmp_si (a->value.integer, b);
1741 /* Compare a single dimension of an array reference to the array
1745 check_dimension (int i, gfc_array_ref * ar, gfc_array_spec * as)
1748 /* Given start, end and stride values, calculate the minimum and
1749 maximum referenced indexes. */
1757 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
1759 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
1765 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
1767 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
1771 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
1773 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
1776 /* TODO: Possibly, we could warn about end[i] being out-of-bound although
1777 it is legal (see 6.2.2.3.1). */
1782 gfc_internal_error ("check_dimension(): Bad array reference");
1788 gfc_warning ("Array reference at %L is out of bounds", &ar->c_where[i]);
1793 /* Compare an array reference with an array specification. */
1796 compare_spec_to_ref (gfc_array_ref * ar)
1803 /* TODO: Full array sections are only allowed as actual parameters. */
1804 if (as->type == AS_ASSUMED_SIZE
1805 && (/*ar->type == AR_FULL
1806 ||*/ (ar->type == AR_SECTION
1807 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
1809 gfc_error ("Rightmost upper bound of assumed size array section"
1810 " not specified at %L", &ar->where);
1814 if (ar->type == AR_FULL)
1817 if (as->rank != ar->dimen)
1819 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
1820 &ar->where, ar->dimen, as->rank);
1824 for (i = 0; i < as->rank; i++)
1825 if (check_dimension (i, ar, as) == FAILURE)
1832 /* Resolve one part of an array index. */
1835 gfc_resolve_index (gfc_expr * index, int check_scalar)
1842 if (gfc_resolve_expr (index) == FAILURE)
1845 if (check_scalar && index->rank != 0)
1847 gfc_error ("Array index at %L must be scalar", &index->where);
1851 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL)
1853 gfc_error ("Array index at %L must be of INTEGER type",
1858 if (index->ts.type == BT_REAL)
1859 if (gfc_notify_std (GFC_STD_GNU, "Extension: REAL array index at %L",
1860 &index->where) == FAILURE)
1863 if (index->ts.kind != gfc_index_integer_kind
1864 || index->ts.type != BT_INTEGER)
1866 ts.type = BT_INTEGER;
1867 ts.kind = gfc_index_integer_kind;
1869 gfc_convert_type_warn (index, &ts, 2, 0);
1875 /* Resolve a dim argument to an intrinsic function. */
1878 gfc_resolve_dim_arg (gfc_expr *dim)
1883 if (gfc_resolve_expr (dim) == FAILURE)
1888 gfc_error ("Argument dim at %L must be scalar", &dim->where);
1892 if (dim->ts.type != BT_INTEGER)
1894 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where);
1897 if (dim->ts.kind != gfc_index_integer_kind)
1901 ts.type = BT_INTEGER;
1902 ts.kind = gfc_index_integer_kind;
1904 gfc_convert_type_warn (dim, &ts, 2, 0);
1910 /* Given an expression that contains array references, update those array
1911 references to point to the right array specifications. While this is
1912 filled in during matching, this information is difficult to save and load
1913 in a module, so we take care of it here.
1915 The idea here is that the original array reference comes from the
1916 base symbol. We traverse the list of reference structures, setting
1917 the stored reference to references. Component references can
1918 provide an additional array specification. */
1921 find_array_spec (gfc_expr * e)
1927 as = e->symtree->n.sym->as;
1929 for (ref = e->ref; ref; ref = ref->next)
1934 gfc_internal_error ("find_array_spec(): Missing spec");
1941 for (c = e->symtree->n.sym->ts.derived->components; c; c = c->next)
1942 if (c == ref->u.c.component)
1946 gfc_internal_error ("find_array_spec(): Component not found");
1951 gfc_internal_error ("find_array_spec(): unused as(1)");
1962 gfc_internal_error ("find_array_spec(): unused as(2)");
1966 /* Resolve an array reference. */
1969 resolve_array_ref (gfc_array_ref * ar)
1971 int i, check_scalar;
1973 for (i = 0; i < ar->dimen; i++)
1975 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
1977 if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
1979 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
1981 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
1984 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
1985 switch (ar->start[i]->rank)
1988 ar->dimen_type[i] = DIMEN_ELEMENT;
1992 ar->dimen_type[i] = DIMEN_VECTOR;
1996 gfc_error ("Array index at %L is an array of rank %d",
1997 &ar->c_where[i], ar->start[i]->rank);
2002 /* If the reference type is unknown, figure out what kind it is. */
2004 if (ar->type == AR_UNKNOWN)
2006 ar->type = AR_ELEMENT;
2007 for (i = 0; i < ar->dimen; i++)
2008 if (ar->dimen_type[i] == DIMEN_RANGE
2009 || ar->dimen_type[i] == DIMEN_VECTOR)
2011 ar->type = AR_SECTION;
2016 if (!ar->as->cray_pointee && compare_spec_to_ref (ar) == FAILURE)
2024 resolve_substring (gfc_ref * ref)
2027 if (ref->u.ss.start != NULL)
2029 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
2032 if (ref->u.ss.start->ts.type != BT_INTEGER)
2034 gfc_error ("Substring start index at %L must be of type INTEGER",
2035 &ref->u.ss.start->where);
2039 if (ref->u.ss.start->rank != 0)
2041 gfc_error ("Substring start index at %L must be scalar",
2042 &ref->u.ss.start->where);
2046 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT)
2048 gfc_error ("Substring start index at %L is less than one",
2049 &ref->u.ss.start->where);
2054 if (ref->u.ss.end != NULL)
2056 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
2059 if (ref->u.ss.end->ts.type != BT_INTEGER)
2061 gfc_error ("Substring end index at %L must be of type INTEGER",
2062 &ref->u.ss.end->where);
2066 if (ref->u.ss.end->rank != 0)
2068 gfc_error ("Substring end index at %L must be scalar",
2069 &ref->u.ss.end->where);
2073 if (ref->u.ss.length != NULL
2074 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT)
2076 gfc_error ("Substring end index at %L is out of bounds",
2077 &ref->u.ss.start->where);
2086 /* Resolve subtype references. */
2089 resolve_ref (gfc_expr * expr)
2091 int current_part_dimension, n_components, seen_part_dimension;
2094 for (ref = expr->ref; ref; ref = ref->next)
2095 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
2097 find_array_spec (expr);
2101 for (ref = expr->ref; ref; ref = ref->next)
2105 if (resolve_array_ref (&ref->u.ar) == FAILURE)
2113 resolve_substring (ref);
2117 /* Check constraints on part references. */
2119 current_part_dimension = 0;
2120 seen_part_dimension = 0;
2123 for (ref = expr->ref; ref; ref = ref->next)
2128 switch (ref->u.ar.type)
2132 current_part_dimension = 1;
2136 current_part_dimension = 0;
2140 gfc_internal_error ("resolve_ref(): Bad array reference");
2146 if ((current_part_dimension || seen_part_dimension)
2147 && ref->u.c.component->pointer)
2150 ("Component to the right of a part reference with nonzero "
2151 "rank must not have the POINTER attribute at %L",
2163 if (((ref->type == REF_COMPONENT && n_components > 1)
2164 || ref->next == NULL)
2165 && current_part_dimension
2166 && seen_part_dimension)
2169 gfc_error ("Two or more part references with nonzero rank must "
2170 "not be specified at %L", &expr->where);
2174 if (ref->type == REF_COMPONENT)
2176 if (current_part_dimension)
2177 seen_part_dimension = 1;
2179 /* reset to make sure */
2180 current_part_dimension = 0;
2188 /* Given an expression, determine its shape. This is easier than it sounds.
2189 Leaves the shape array NULL if it is not possible to determine the shape. */
2192 expression_shape (gfc_expr * e)
2194 mpz_t array[GFC_MAX_DIMENSIONS];
2197 if (e->rank == 0 || e->shape != NULL)
2200 for (i = 0; i < e->rank; i++)
2201 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
2204 e->shape = gfc_get_shape (e->rank);
2206 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
2211 for (i--; i >= 0; i--)
2212 mpz_clear (array[i]);
2216 /* Given a variable expression node, compute the rank of the expression by
2217 examining the base symbol and any reference structures it may have. */
2220 expression_rank (gfc_expr * e)
2227 if (e->expr_type == EXPR_ARRAY)
2229 /* Constructors can have a rank different from one via RESHAPE(). */
2231 if (e->symtree == NULL)
2237 e->rank = (e->symtree->n.sym->as == NULL)
2238 ? 0 : e->symtree->n.sym->as->rank;
2244 for (ref = e->ref; ref; ref = ref->next)
2246 if (ref->type != REF_ARRAY)
2249 if (ref->u.ar.type == AR_FULL)
2251 rank = ref->u.ar.as->rank;
2255 if (ref->u.ar.type == AR_SECTION)
2257 /* Figure out the rank of the section. */
2259 gfc_internal_error ("expression_rank(): Two array specs");
2261 for (i = 0; i < ref->u.ar.dimen; i++)
2262 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
2263 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
2273 expression_shape (e);
2277 /* Resolve a variable expression. */
2280 resolve_variable (gfc_expr * e)
2284 if (e->ref && resolve_ref (e) == FAILURE)
2287 if (e->symtree == NULL)
2290 sym = e->symtree->n.sym;
2291 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
2293 e->ts.type = BT_PROCEDURE;
2297 if (sym->ts.type != BT_UNKNOWN)
2298 gfc_variable_attr (e, &e->ts);
2301 /* Must be a simple variable reference. */
2302 if (gfc_set_default_type (sym, 1, NULL) == FAILURE)
2311 /* Resolve an expression. That is, make sure that types of operands agree
2312 with their operators, intrinsic operators are converted to function calls
2313 for overloaded types and unresolved function references are resolved. */
2316 gfc_resolve_expr (gfc_expr * e)
2323 switch (e->expr_type)
2326 t = resolve_operator (e);
2330 t = resolve_function (e);
2334 t = resolve_variable (e);
2336 expression_rank (e);
2339 case EXPR_SUBSTRING:
2340 t = resolve_ref (e);
2350 if (resolve_ref (e) == FAILURE)
2353 t = gfc_resolve_array_constructor (e);
2354 /* Also try to expand a constructor. */
2357 expression_rank (e);
2358 gfc_expand_constructor (e);
2363 case EXPR_STRUCTURE:
2364 t = resolve_ref (e);
2368 t = resolve_structure_cons (e);
2372 t = gfc_simplify_expr (e, 0);
2376 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
2383 /* Resolve an expression from an iterator. They must be scalar and have
2384 INTEGER or (optionally) REAL type. */
2387 gfc_resolve_iterator_expr (gfc_expr * expr, bool real_ok,
2388 const char * name_msgid)
2390 if (gfc_resolve_expr (expr) == FAILURE)
2393 if (expr->rank != 0)
2395 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where);
2399 if (!(expr->ts.type == BT_INTEGER
2400 || (expr->ts.type == BT_REAL && real_ok)))
2403 gfc_error ("%s at %L must be INTEGER or REAL", _(name_msgid),
2406 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where);
2413 /* Resolve the expressions in an iterator structure. If REAL_OK is
2414 false allow only INTEGER type iterators, otherwise allow REAL types. */
2417 gfc_resolve_iterator (gfc_iterator * iter, bool real_ok)
2420 if (iter->var->ts.type == BT_REAL)
2421 gfc_notify_std (GFC_STD_F95_DEL,
2422 "Obsolete: REAL DO loop iterator at %L",
2425 if (gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")
2429 if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
2431 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
2436 if (gfc_resolve_iterator_expr (iter->start, real_ok,
2437 "Start expression in DO loop") == FAILURE)
2440 if (gfc_resolve_iterator_expr (iter->end, real_ok,
2441 "End expression in DO loop") == FAILURE)
2444 if (gfc_resolve_iterator_expr (iter->step, real_ok,
2445 "Step expression in DO loop") == FAILURE)
2448 if (iter->step->expr_type == EXPR_CONSTANT)
2450 if ((iter->step->ts.type == BT_INTEGER
2451 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
2452 || (iter->step->ts.type == BT_REAL
2453 && mpfr_sgn (iter->step->value.real) == 0))
2455 gfc_error ("Step expression in DO loop at %L cannot be zero",
2456 &iter->step->where);
2461 /* Convert start, end, and step to the same type as var. */
2462 if (iter->start->ts.kind != iter->var->ts.kind
2463 || iter->start->ts.type != iter->var->ts.type)
2464 gfc_convert_type (iter->start, &iter->var->ts, 2);
2466 if (iter->end->ts.kind != iter->var->ts.kind
2467 || iter->end->ts.type != iter->var->ts.type)
2468 gfc_convert_type (iter->end, &iter->var->ts, 2);
2470 if (iter->step->ts.kind != iter->var->ts.kind
2471 || iter->step->ts.type != iter->var->ts.type)
2472 gfc_convert_type (iter->step, &iter->var->ts, 2);
2478 /* Resolve a list of FORALL iterators. */
2481 resolve_forall_iterators (gfc_forall_iterator * iter)
2486 if (gfc_resolve_expr (iter->var) == SUCCESS
2487 && iter->var->ts.type != BT_INTEGER)
2488 gfc_error ("FORALL Iteration variable at %L must be INTEGER",
2491 if (gfc_resolve_expr (iter->start) == SUCCESS
2492 && iter->start->ts.type != BT_INTEGER)
2493 gfc_error ("FORALL start expression at %L must be INTEGER",
2494 &iter->start->where);
2495 if (iter->var->ts.kind != iter->start->ts.kind)
2496 gfc_convert_type (iter->start, &iter->var->ts, 2);
2498 if (gfc_resolve_expr (iter->end) == SUCCESS
2499 && iter->end->ts.type != BT_INTEGER)
2500 gfc_error ("FORALL end expression at %L must be INTEGER",
2502 if (iter->var->ts.kind != iter->end->ts.kind)
2503 gfc_convert_type (iter->end, &iter->var->ts, 2);
2505 if (gfc_resolve_expr (iter->stride) == SUCCESS
2506 && iter->stride->ts.type != BT_INTEGER)
2507 gfc_error ("FORALL Stride expression at %L must be INTEGER",
2508 &iter->stride->where);
2509 if (iter->var->ts.kind != iter->stride->ts.kind)
2510 gfc_convert_type (iter->stride, &iter->var->ts, 2);
2517 /* Given a pointer to a symbol that is a derived type, see if any components
2518 have the POINTER attribute. The search is recursive if necessary.
2519 Returns zero if no pointer components are found, nonzero otherwise. */
2522 derived_pointer (gfc_symbol * sym)
2526 for (c = sym->components; c; c = c->next)
2531 if (c->ts.type == BT_DERIVED && derived_pointer (c->ts.derived))
2539 /* Given a pointer to a symbol that is a derived type, see if it's
2540 inaccessible, i.e. if it's defined in another module and the components are
2541 PRIVATE. The search is recursive if necessary. Returns zero if no
2542 inaccessible components are found, nonzero otherwise. */
2545 derived_inaccessible (gfc_symbol *sym)
2549 if (sym->attr.use_assoc && sym->component_access == ACCESS_PRIVATE)
2552 for (c = sym->components; c; c = c->next)
2554 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.derived))
2562 /* Resolve the argument of a deallocate expression. The expression must be
2563 a pointer or a full array. */
2566 resolve_deallocate_expr (gfc_expr * e)
2568 symbol_attribute attr;
2572 if (gfc_resolve_expr (e) == FAILURE)
2575 attr = gfc_expr_attr (e);
2579 if (e->expr_type != EXPR_VARIABLE)
2582 allocatable = e->symtree->n.sym->attr.allocatable;
2583 for (ref = e->ref; ref; ref = ref->next)
2587 if (ref->u.ar.type != AR_FULL)
2592 allocatable = (ref->u.c.component->as != NULL
2593 && ref->u.c.component->as->type == AS_DEFERRED);
2601 if (allocatable == 0)
2604 gfc_error ("Expression in DEALLOCATE statement at %L must be "
2605 "ALLOCATABLE or a POINTER", &e->where);
2612 /* Given the expression node e for an allocatable/pointer of derived type to be
2613 allocated, get the expression node to be initialized afterwards (needed for
2614 derived types with default initializers). */
2617 expr_to_initialize (gfc_expr * e)
2623 result = gfc_copy_expr (e);
2625 /* Change the last array reference from AR_ELEMENT to AR_FULL. */
2626 for (ref = result->ref; ref; ref = ref->next)
2627 if (ref->type == REF_ARRAY && ref->next == NULL)
2629 ref->u.ar.type = AR_FULL;
2631 for (i = 0; i < ref->u.ar.dimen; i++)
2632 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
2634 result->rank = ref->u.ar.dimen;
2642 /* Resolve the expression in an ALLOCATE statement, doing the additional
2643 checks to see whether the expression is OK or not. The expression must
2644 have a trailing array reference that gives the size of the array. */
2647 resolve_allocate_expr (gfc_expr * e, gfc_code * code)
2649 int i, pointer, allocatable, dimension;
2650 symbol_attribute attr;
2651 gfc_ref *ref, *ref2;
2656 if (gfc_resolve_expr (e) == FAILURE)
2659 /* Make sure the expression is allocatable or a pointer. If it is
2660 pointer, the next-to-last reference must be a pointer. */
2664 if (e->expr_type != EXPR_VARIABLE)
2668 attr = gfc_expr_attr (e);
2669 pointer = attr.pointer;
2670 dimension = attr.dimension;
2675 allocatable = e->symtree->n.sym->attr.allocatable;
2676 pointer = e->symtree->n.sym->attr.pointer;
2677 dimension = e->symtree->n.sym->attr.dimension;
2679 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
2683 if (ref->next != NULL)
2688 allocatable = (ref->u.c.component->as != NULL
2689 && ref->u.c.component->as->type == AS_DEFERRED);
2691 pointer = ref->u.c.component->pointer;
2692 dimension = ref->u.c.component->dimension;
2702 if (allocatable == 0 && pointer == 0)
2704 gfc_error ("Expression in ALLOCATE statement at %L must be "
2705 "ALLOCATABLE or a POINTER", &e->where);
2709 /* Add default initializer for those derived types that need them. */
2710 if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts)))
2712 init_st = gfc_get_code ();
2713 init_st->loc = code->loc;
2714 init_st->op = EXEC_ASSIGN;
2715 init_st->expr = expr_to_initialize (e);
2716 init_st->expr2 = init_e;
2718 init_st->next = code->next;
2719 code->next = init_st;
2722 if (pointer && dimension == 0)
2725 /* Make sure the next-to-last reference node is an array specification. */
2727 if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
2729 gfc_error ("Array specification required in ALLOCATE statement "
2730 "at %L", &e->where);
2734 if (ref2->u.ar.type == AR_ELEMENT)
2737 /* Make sure that the array section reference makes sense in the
2738 context of an ALLOCATE specification. */
2742 for (i = 0; i < ar->dimen; i++)
2743 switch (ar->dimen_type[i])
2749 if (ar->start[i] != NULL
2750 && ar->end[i] != NULL
2751 && ar->stride[i] == NULL)
2754 /* Fall Through... */
2758 gfc_error ("Bad array specification in ALLOCATE statement at %L",
2767 /************ SELECT CASE resolution subroutines ************/
2769 /* Callback function for our mergesort variant. Determines interval
2770 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
2771 op1 > op2. Assumes we're not dealing with the default case.
2772 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:).
2773 There are nine situations to check. */
2776 compare_cases (const gfc_case * op1, const gfc_case * op2)
2780 if (op1->low == NULL) /* op1 = (:L) */
2782 /* op2 = (:N), so overlap. */
2784 /* op2 = (M:) or (M:N), L < M */
2785 if (op2->low != NULL
2786 && gfc_compare_expr (op1->high, op2->low) < 0)
2789 else if (op1->high == NULL) /* op1 = (K:) */
2791 /* op2 = (M:), so overlap. */
2793 /* op2 = (:N) or (M:N), K > N */
2794 if (op2->high != NULL
2795 && gfc_compare_expr (op1->low, op2->high) > 0)
2798 else /* op1 = (K:L) */
2800 if (op2->low == NULL) /* op2 = (:N), K > N */
2801 retval = (gfc_compare_expr (op1->low, op2->high) > 0) ? 1 : 0;
2802 else if (op2->high == NULL) /* op2 = (M:), L < M */
2803 retval = (gfc_compare_expr (op1->high, op2->low) < 0) ? -1 : 0;
2804 else /* op2 = (M:N) */
2808 if (gfc_compare_expr (op1->high, op2->low) < 0)
2811 else if (gfc_compare_expr (op1->low, op2->high) > 0)
2820 /* Merge-sort a double linked case list, detecting overlap in the
2821 process. LIST is the head of the double linked case list before it
2822 is sorted. Returns the head of the sorted list if we don't see any
2823 overlap, or NULL otherwise. */
2826 check_case_overlap (gfc_case * list)
2828 gfc_case *p, *q, *e, *tail;
2829 int insize, nmerges, psize, qsize, cmp, overlap_seen;
2831 /* If the passed list was empty, return immediately. */
2838 /* Loop unconditionally. The only exit from this loop is a return
2839 statement, when we've finished sorting the case list. */
2846 /* Count the number of merges we do in this pass. */
2849 /* Loop while there exists a merge to be done. */
2854 /* Count this merge. */
2857 /* Cut the list in two pieces by stepping INSIZE places
2858 forward in the list, starting from P. */
2861 for (i = 0; i < insize; i++)
2870 /* Now we have two lists. Merge them! */
2871 while (psize > 0 || (qsize > 0 && q != NULL))
2874 /* See from which the next case to merge comes from. */
2877 /* P is empty so the next case must come from Q. */
2882 else if (qsize == 0 || q == NULL)
2891 cmp = compare_cases (p, q);
2894 /* The whole case range for P is less than the
2902 /* The whole case range for Q is greater than
2903 the case range for P. */
2910 /* The cases overlap, or they are the same
2911 element in the list. Either way, we must
2912 issue an error and get the next case from P. */
2913 /* FIXME: Sort P and Q by line number. */
2914 gfc_error ("CASE label at %L overlaps with CASE "
2915 "label at %L", &p->where, &q->where);
2923 /* Add the next element to the merged list. */
2932 /* P has now stepped INSIZE places along, and so has Q. So
2933 they're the same. */
2938 /* If we have done only one merge or none at all, we've
2939 finished sorting the cases. */
2948 /* Otherwise repeat, merging lists twice the size. */
2954 /* Check to see if an expression is suitable for use in a CASE statement.
2955 Makes sure that all case expressions are scalar constants of the same
2956 type. Return FAILURE if anything is wrong. */
2959 validate_case_label_expr (gfc_expr * e, gfc_expr * case_expr)
2961 if (e == NULL) return SUCCESS;
2963 if (e->ts.type != case_expr->ts.type)
2965 gfc_error ("Expression in CASE statement at %L must be of type %s",
2966 &e->where, gfc_basic_typename (case_expr->ts.type));
2970 /* C805 (R808) For a given case-construct, each case-value shall be of
2971 the same type as case-expr. For character type, length differences
2972 are allowed, but the kind type parameters shall be the same. */
2974 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind)
2976 gfc_error("Expression in CASE statement at %L must be kind %d",
2977 &e->where, case_expr->ts.kind);
2981 /* Convert the case value kind to that of case expression kind, if needed.
2982 FIXME: Should a warning be issued? */
2983 if (e->ts.kind != case_expr->ts.kind)
2984 gfc_convert_type_warn (e, &case_expr->ts, 2, 0);
2988 gfc_error ("Expression in CASE statement at %L must be scalar",
2997 /* Given a completely parsed select statement, we:
2999 - Validate all expressions and code within the SELECT.
3000 - Make sure that the selection expression is not of the wrong type.
3001 - Make sure that no case ranges overlap.
3002 - Eliminate unreachable cases and unreachable code resulting from
3003 removing case labels.
3005 The standard does allow unreachable cases, e.g. CASE (5:3). But
3006 they are a hassle for code generation, and to prevent that, we just
3007 cut them out here. This is not necessary for overlapping cases
3008 because they are illegal and we never even try to generate code.
3010 We have the additional caveat that a SELECT construct could have
3011 been a computed GOTO in the source code. Fortunately we can fairly
3012 easily work around that here: The case_expr for a "real" SELECT CASE
3013 is in code->expr1, but for a computed GOTO it is in code->expr2. All
3014 we have to do is make sure that the case_expr is a scalar integer
3018 resolve_select (gfc_code * code)
3021 gfc_expr *case_expr;
3022 gfc_case *cp, *default_case, *tail, *head;
3023 int seen_unreachable;
3028 if (code->expr == NULL)
3030 /* This was actually a computed GOTO statement. */
3031 case_expr = code->expr2;
3032 if (case_expr->ts.type != BT_INTEGER
3033 || case_expr->rank != 0)
3034 gfc_error ("Selection expression in computed GOTO statement "
3035 "at %L must be a scalar integer expression",
3038 /* Further checking is not necessary because this SELECT was built
3039 by the compiler, so it should always be OK. Just move the
3040 case_expr from expr2 to expr so that we can handle computed
3041 GOTOs as normal SELECTs from here on. */
3042 code->expr = code->expr2;
3047 case_expr = code->expr;
3049 type = case_expr->ts.type;
3050 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
3052 gfc_error ("Argument of SELECT statement at %L cannot be %s",
3053 &case_expr->where, gfc_typename (&case_expr->ts));
3055 /* Punt. Going on here just produce more garbage error messages. */
3059 if (case_expr->rank != 0)
3061 gfc_error ("Argument of SELECT statement at %L must be a scalar "
3062 "expression", &case_expr->where);
3068 /* PR 19168 has a long discussion concerning a mismatch of the kinds
3069 of the SELECT CASE expression and its CASE values. Walk the lists
3070 of case values, and if we find a mismatch, promote case_expr to
3071 the appropriate kind. */
3073 if (type == BT_LOGICAL || type == BT_INTEGER)
3075 for (body = code->block; body; body = body->block)
3077 /* Walk the case label list. */
3078 for (cp = body->ext.case_list; cp; cp = cp->next)
3080 /* Intercept the DEFAULT case. It does not have a kind. */
3081 if (cp->low == NULL && cp->high == NULL)
3084 /* Unreachable case ranges are discarded, so ignore. */
3085 if (cp->low != NULL && cp->high != NULL
3086 && cp->low != cp->high
3087 && gfc_compare_expr (cp->low, cp->high) > 0)
3090 /* FIXME: Should a warning be issued? */
3092 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low))
3093 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0);
3095 if (cp->high != NULL
3096 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high))
3097 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0);
3102 /* Assume there is no DEFAULT case. */
3103 default_case = NULL;
3107 for (body = code->block; body; body = body->block)
3109 /* Assume the CASE list is OK, and all CASE labels can be matched. */
3111 seen_unreachable = 0;
3113 /* Walk the case label list, making sure that all case labels
3115 for (cp = body->ext.case_list; cp; cp = cp->next)
3117 /* Count the number of cases in the whole construct. */
3120 /* Intercept the DEFAULT case. */
3121 if (cp->low == NULL && cp->high == NULL)
3123 if (default_case != NULL)
3125 gfc_error ("The DEFAULT CASE at %L cannot be followed "
3126 "by a second DEFAULT CASE at %L",
3127 &default_case->where, &cp->where);
3138 /* Deal with single value cases and case ranges. Errors are
3139 issued from the validation function. */
3140 if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
3141 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
3147 if (type == BT_LOGICAL
3148 && ((cp->low == NULL || cp->high == NULL)
3149 || cp->low != cp->high))
3152 ("Logical range in CASE statement at %L is not allowed",
3158 if (cp->low != NULL && cp->high != NULL
3159 && cp->low != cp->high
3160 && gfc_compare_expr (cp->low, cp->high) > 0)
3162 if (gfc_option.warn_surprising)
3163 gfc_warning ("Range specification at %L can never "
3164 "be matched", &cp->where);
3166 cp->unreachable = 1;
3167 seen_unreachable = 1;
3171 /* If the case range can be matched, it can also overlap with
3172 other cases. To make sure it does not, we put it in a
3173 double linked list here. We sort that with a merge sort
3174 later on to detect any overlapping cases. */
3178 head->right = head->left = NULL;
3183 tail->right->left = tail;
3190 /* It there was a failure in the previous case label, give up
3191 for this case label list. Continue with the next block. */
3195 /* See if any case labels that are unreachable have been seen.
3196 If so, we eliminate them. This is a bit of a kludge because
3197 the case lists for a single case statement (label) is a
3198 single forward linked lists. */
3199 if (seen_unreachable)
3201 /* Advance until the first case in the list is reachable. */
3202 while (body->ext.case_list != NULL
3203 && body->ext.case_list->unreachable)
3205 gfc_case *n = body->ext.case_list;
3206 body->ext.case_list = body->ext.case_list->next;
3208 gfc_free_case_list (n);
3211 /* Strip all other unreachable cases. */
3212 if (body->ext.case_list)
3214 for (cp = body->ext.case_list; cp->next; cp = cp->next)
3216 if (cp->next->unreachable)
3218 gfc_case *n = cp->next;
3219 cp->next = cp->next->next;
3221 gfc_free_case_list (n);
3228 /* See if there were overlapping cases. If the check returns NULL,
3229 there was overlap. In that case we don't do anything. If head
3230 is non-NULL, we prepend the DEFAULT case. The sorted list can
3231 then used during code generation for SELECT CASE constructs with
3232 a case expression of a CHARACTER type. */
3235 head = check_case_overlap (head);
3237 /* Prepend the default_case if it is there. */
3238 if (head != NULL && default_case)
3240 default_case->left = NULL;
3241 default_case->right = head;
3242 head->left = default_case;
3246 /* Eliminate dead blocks that may be the result if we've seen
3247 unreachable case labels for a block. */
3248 for (body = code; body && body->block; body = body->block)
3250 if (body->block->ext.case_list == NULL)
3252 /* Cut the unreachable block from the code chain. */
3253 gfc_code *c = body->block;
3254 body->block = c->block;
3256 /* Kill the dead block, but not the blocks below it. */
3258 gfc_free_statements (c);
3262 /* More than two cases is legal but insane for logical selects.
3263 Issue a warning for it. */
3264 if (gfc_option.warn_surprising && type == BT_LOGICAL
3266 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
3271 /* Resolve a transfer statement. This is making sure that:
3272 -- a derived type being transferred has only non-pointer components
3273 -- a derived type being transferred doesn't have private components, unless
3274 it's being transferred from the module where the type was defined
3275 -- we're not trying to transfer a whole assumed size array. */
3278 resolve_transfer (gfc_code * code)
3287 if (exp->expr_type != EXPR_VARIABLE)
3290 sym = exp->symtree->n.sym;
3293 /* Go to actual component transferred. */
3294 for (ref = code->expr->ref; ref; ref = ref->next)
3295 if (ref->type == REF_COMPONENT)
3296 ts = &ref->u.c.component->ts;
3298 if (ts->type == BT_DERIVED)
3300 /* Check that transferred derived type doesn't contain POINTER
3302 if (derived_pointer (ts->derived))
3304 gfc_error ("Data transfer element at %L cannot have "
3305 "POINTER components", &code->loc);
3309 if (derived_inaccessible (ts->derived))
3311 gfc_error ("Data transfer element at %L cannot have "
3312 "PRIVATE components",&code->loc);
3317 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
3318 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
3320 gfc_error ("Data transfer element at %L cannot be a full reference to "
3321 "an assumed-size array", &code->loc);
3327 /*********** Toplevel code resolution subroutines ***********/
3329 /* Given a branch to a label and a namespace, if the branch is conforming.
3330 The code node described where the branch is located. */
3333 resolve_branch (gfc_st_label * label, gfc_code * code)
3335 gfc_code *block, *found;
3343 /* Step one: is this a valid branching target? */
3345 if (lp->defined == ST_LABEL_UNKNOWN)
3347 gfc_error ("Label %d referenced at %L is never defined", lp->value,
3352 if (lp->defined != ST_LABEL_TARGET)
3354 gfc_error ("Statement at %L is not a valid branch target statement "
3355 "for the branch statement at %L", &lp->where, &code->loc);
3359 /* Step two: make sure this branch is not a branch to itself ;-) */
3361 if (code->here == label)
3363 gfc_warning ("Branch at %L causes an infinite loop", &code->loc);
3367 /* Step three: Try to find the label in the parse tree. To do this,
3368 we traverse the tree block-by-block: first the block that
3369 contains this GOTO, then the block that it is nested in, etc. We
3370 can ignore other blocks because branching into another block is
3375 for (stack = cs_base; stack; stack = stack->prev)
3377 for (block = stack->head; block; block = block->next)
3379 if (block->here == label)
3392 /* still nothing, so illegal. */
3393 gfc_error_now ("Label at %L is not in the same block as the "
3394 "GOTO statement at %L", &lp->where, &code->loc);
3398 /* Step four: Make sure that the branching target is legal if
3399 the statement is an END {SELECT,DO,IF}. */
3401 if (found->op == EXEC_NOP)
3403 for (stack = cs_base; stack; stack = stack->prev)
3404 if (stack->current->next == found)
3408 gfc_notify_std (GFC_STD_F95_DEL,
3409 "Obsolete: GOTO at %L jumps to END of construct at %L",
3410 &code->loc, &found->loc);
3415 /* Check whether EXPR1 has the same shape as EXPR2. */
3418 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
3420 mpz_t shape[GFC_MAX_DIMENSIONS];
3421 mpz_t shape2[GFC_MAX_DIMENSIONS];
3422 try result = FAILURE;
3425 /* Compare the rank. */
3426 if (expr1->rank != expr2->rank)
3429 /* Compare the size of each dimension. */
3430 for (i=0; i<expr1->rank; i++)
3432 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
3435 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
3438 if (mpz_cmp (shape[i], shape2[i]))
3442 /* When either of the two expression is an assumed size array, we
3443 ignore the comparison of dimension sizes. */
3448 for (i--; i>=0; i--)
3450 mpz_clear (shape[i]);
3451 mpz_clear (shape2[i]);
3457 /* Check whether a WHERE assignment target or a WHERE mask expression
3458 has the same shape as the outmost WHERE mask expression. */
3461 resolve_where (gfc_code *code, gfc_expr *mask)
3467 cblock = code->block;
3469 /* Store the first WHERE mask-expr of the WHERE statement or construct.
3470 In case of nested WHERE, only the outmost one is stored. */
3471 if (mask == NULL) /* outmost WHERE */
3473 else /* inner WHERE */
3480 /* Check if the mask-expr has a consistent shape with the
3481 outmost WHERE mask-expr. */
3482 if (resolve_where_shape (cblock->expr, e) == FAILURE)
3483 gfc_error ("WHERE mask at %L has inconsistent shape",
3484 &cblock->expr->where);
3487 /* the assignment statement of a WHERE statement, or the first
3488 statement in where-body-construct of a WHERE construct */
3489 cnext = cblock->next;
3494 /* WHERE assignment statement */
3497 /* Check shape consistent for WHERE assignment target. */
3498 if (e && resolve_where_shape (cnext->expr, e) == FAILURE)
3499 gfc_error ("WHERE assignment target at %L has "
3500 "inconsistent shape", &cnext->expr->where);
3503 /* WHERE or WHERE construct is part of a where-body-construct */
3505 resolve_where (cnext, e);
3509 gfc_error ("Unsupported statement inside WHERE at %L",
3512 /* the next statement within the same where-body-construct */
3513 cnext = cnext->next;
3515 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
3516 cblock = cblock->block;
3521 /* Check whether the FORALL index appears in the expression or not. */
3524 gfc_find_forall_index (gfc_expr *expr, gfc_symbol *symbol)
3528 gfc_actual_arglist *args;
3531 switch (expr->expr_type)
3534 gcc_assert (expr->symtree->n.sym);
3536 /* A scalar assignment */
3539 if (expr->symtree->n.sym == symbol)
3545 /* the expr is array ref, substring or struct component. */
3552 /* Check if the symbol appears in the array subscript. */
3554 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
3557 if (gfc_find_forall_index (ar.start[i], symbol) == SUCCESS)
3561 if (gfc_find_forall_index (ar.end[i], symbol) == SUCCESS)
3565 if (gfc_find_forall_index (ar.stride[i], symbol) == SUCCESS)
3571 if (expr->symtree->n.sym == symbol)
3574 /* Check if the symbol appears in the substring section. */
3575 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
3577 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
3585 gfc_error("expresion reference type error at %L", &expr->where);
3591 /* If the expression is a function call, then check if the symbol
3592 appears in the actual arglist of the function. */
3594 for (args = expr->value.function.actual; args; args = args->next)
3596 if (gfc_find_forall_index(args->expr,symbol) == SUCCESS)
3601 /* It seems not to happen. */
3602 case EXPR_SUBSTRING:
3606 gcc_assert (expr->ref->type == REF_SUBSTRING);
3607 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
3609 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
3614 /* It seems not to happen. */
3615 case EXPR_STRUCTURE:
3617 gfc_error ("Unsupported statement while finding forall index in "
3622 /* Find the FORALL index in the first operand. */
3623 if (expr->value.op.op1)
3625 if (gfc_find_forall_index (expr->value.op.op1, symbol) == SUCCESS)
3629 /* Find the FORALL index in the second operand. */
3630 if (expr->value.op.op2)
3632 if (gfc_find_forall_index (expr->value.op.op2, symbol) == SUCCESS)
3645 /* Resolve assignment in FORALL construct.
3646 NVAR is the number of FORALL index variables, and VAR_EXPR records the
3647 FORALL index variables. */
3650 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
3654 for (n = 0; n < nvar; n++)
3656 gfc_symbol *forall_index;
3658 forall_index = var_expr[n]->symtree->n.sym;
3660 /* Check whether the assignment target is one of the FORALL index
3662 if ((code->expr->expr_type == EXPR_VARIABLE)
3663 && (code->expr->symtree->n.sym == forall_index))
3664 gfc_error ("Assignment to a FORALL index variable at %L",
3665 &code->expr->where);
3668 /* If one of the FORALL index variables doesn't appear in the
3669 assignment target, then there will be a many-to-one
3671 if (gfc_find_forall_index (code->expr, forall_index) == FAILURE)
3672 gfc_error ("The FORALL with index '%s' cause more than one "
3673 "assignment to this object at %L",
3674 var_expr[n]->symtree->name, &code->expr->where);
3680 /* Resolve WHERE statement in FORALL construct. */
3683 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr){
3687 cblock = code->block;
3690 /* the assignment statement of a WHERE statement, or the first
3691 statement in where-body-construct of a WHERE construct */
3692 cnext = cblock->next;
3697 /* WHERE assignment statement */
3699 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
3702 /* WHERE or WHERE construct is part of a where-body-construct */
3704 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
3708 gfc_error ("Unsupported statement inside WHERE at %L",
3711 /* the next statement within the same where-body-construct */
3712 cnext = cnext->next;
3714 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
3715 cblock = cblock->block;
3720 /* Traverse the FORALL body to check whether the following errors exist:
3721 1. For assignment, check if a many-to-one assignment happens.
3722 2. For WHERE statement, check the WHERE body to see if there is any
3723 many-to-one assignment. */
3726 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
3730 c = code->block->next;
3736 case EXEC_POINTER_ASSIGN:
3737 gfc_resolve_assign_in_forall (c, nvar, var_expr);
3740 /* Because the resolve_blocks() will handle the nested FORALL,
3741 there is no need to handle it here. */
3745 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
3750 /* The next statement in the FORALL body. */
3756 /* Given a FORALL construct, first resolve the FORALL iterator, then call
3757 gfc_resolve_forall_body to resolve the FORALL body. */
3759 static void resolve_blocks (gfc_code *, gfc_namespace *);
3762 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
3764 static gfc_expr **var_expr;
3765 static int total_var = 0;
3766 static int nvar = 0;
3767 gfc_forall_iterator *fa;
3768 gfc_symbol *forall_index;
3772 /* Start to resolve a FORALL construct */
3773 if (forall_save == 0)
3775 /* Count the total number of FORALL index in the nested FORALL
3776 construct in order to allocate the VAR_EXPR with proper size. */
3778 while ((next != NULL) && (next->op == EXEC_FORALL))
3780 for (fa = next->ext.forall_iterator; fa; fa = fa->next)
3782 next = next->block->next;
3785 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
3786 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
3789 /* The information about FORALL iterator, including FORALL index start, end
3790 and stride. The FORALL index can not appear in start, end or stride. */
3791 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
3793 /* Check if any outer FORALL index name is the same as the current
3795 for (i = 0; i < nvar; i++)
3797 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
3799 gfc_error ("An outer FORALL construct already has an index "
3800 "with this name %L", &fa->var->where);
3804 /* Record the current FORALL index. */
3805 var_expr[nvar] = gfc_copy_expr (fa->var);
3807 forall_index = fa->var->symtree->n.sym;
3809 /* Check if the FORALL index appears in start, end or stride. */
3810 if (gfc_find_forall_index (fa->start, forall_index) == SUCCESS)
3811 gfc_error ("A FORALL index must not appear in a limit or stride "
3812 "expression in the same FORALL at %L", &fa->start->where);
3813 if (gfc_find_forall_index (fa->end, forall_index) == SUCCESS)
3814 gfc_error ("A FORALL index must not appear in a limit or stride "
3815 "expression in the same FORALL at %L", &fa->end->where);
3816 if (gfc_find_forall_index (fa->stride, forall_index) == SUCCESS)
3817 gfc_error ("A FORALL index must not appear in a limit or stride "
3818 "expression in the same FORALL at %L", &fa->stride->where);
3822 /* Resolve the FORALL body. */
3823 gfc_resolve_forall_body (code, nvar, var_expr);
3825 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
3826 resolve_blocks (code->block, ns);
3828 /* Free VAR_EXPR after the whole FORALL construct resolved. */
3829 for (i = 0; i < total_var; i++)
3830 gfc_free_expr (var_expr[i]);
3832 /* Reset the counters. */
3838 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
3841 static void resolve_code (gfc_code *, gfc_namespace *);
3844 resolve_blocks (gfc_code * b, gfc_namespace * ns)
3848 for (; b; b = b->block)
3850 t = gfc_resolve_expr (b->expr);
3851 if (gfc_resolve_expr (b->expr2) == FAILURE)
3857 if (t == SUCCESS && b->expr != NULL
3858 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank != 0))
3860 ("ELSE IF clause at %L requires a scalar LOGICAL expression",
3867 && (b->expr->ts.type != BT_LOGICAL
3868 || b->expr->rank == 0))
3870 ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
3875 resolve_branch (b->label, b);
3885 gfc_internal_error ("resolve_block(): Bad block type");
3888 resolve_code (b->next, ns);
3893 /* Given a block of code, recursively resolve everything pointed to by this
3897 resolve_code (gfc_code * code, gfc_namespace * ns)
3899 int forall_save = 0;
3904 frame.prev = cs_base;
3908 for (; code; code = code->next)
3910 frame.current = code;
3912 if (code->op == EXEC_FORALL)
3914 forall_save = forall_flag;
3916 gfc_resolve_forall (code, ns, forall_save);
3919 resolve_blocks (code->block, ns);
3921 if (code->op == EXEC_FORALL)
3922 forall_flag = forall_save;
3924 t = gfc_resolve_expr (code->expr);
3925 if (gfc_resolve_expr (code->expr2) == FAILURE)
3941 resolve_where (code, NULL);
3945 if (code->expr != NULL)
3947 if (code->expr->ts.type != BT_INTEGER)
3948 gfc_error ("ASSIGNED GOTO statement at %L requires an INTEGER "
3949 "variable", &code->expr->where);
3950 else if (code->expr->symtree->n.sym->attr.assign != 1)
3951 gfc_error ("Variable '%s' has not been assigned a target label "
3952 "at %L", code->expr->symtree->n.sym->name,
3953 &code->expr->where);
3956 resolve_branch (code->label, code);
3960 if (code->expr != NULL && code->expr->ts.type != BT_INTEGER)
3961 gfc_error ("Alternate RETURN statement at %L requires an INTEGER "
3962 "return specifier", &code->expr->where);
3969 if (gfc_extend_assign (code, ns) == SUCCESS)
3972 if (gfc_pure (NULL))
3974 if (gfc_impure_variable (code->expr->symtree->n.sym))
3977 ("Cannot assign to variable '%s' in PURE procedure at %L",
3978 code->expr->symtree->n.sym->name, &code->expr->where);
3982 if (code->expr2->ts.type == BT_DERIVED
3983 && derived_pointer (code->expr2->ts.derived))
3986 ("Right side of assignment at %L is a derived type "
3987 "containing a POINTER in a PURE procedure",
3988 &code->expr2->where);
3993 gfc_check_assign (code->expr, code->expr2, 1);
3996 case EXEC_LABEL_ASSIGN:
3997 if (code->label->defined == ST_LABEL_UNKNOWN)
3998 gfc_error ("Label %d referenced at %L is never defined",
3999 code->label->value, &code->label->where);
4001 && (code->expr->expr_type != EXPR_VARIABLE
4002 || code->expr->symtree->n.sym->ts.type != BT_INTEGER
4003 || code->expr->symtree->n.sym->ts.kind
4004 != gfc_default_integer_kind
4005 || code->expr->symtree->n.sym->as != NULL))
4006 gfc_error ("ASSIGN statement at %L requires a scalar "
4007 "default INTEGER variable", &code->expr->where);
4010 case EXEC_POINTER_ASSIGN:
4014 gfc_check_pointer_assign (code->expr, code->expr2);
4017 case EXEC_ARITHMETIC_IF:
4019 && code->expr->ts.type != BT_INTEGER
4020 && code->expr->ts.type != BT_REAL)
4021 gfc_error ("Arithmetic IF statement at %L requires a numeric "
4022 "expression", &code->expr->where);
4024 resolve_branch (code->label, code);
4025 resolve_branch (code->label2, code);
4026 resolve_branch (code->label3, code);
4030 if (t == SUCCESS && code->expr != NULL
4031 && (code->expr->ts.type != BT_LOGICAL
4032 || code->expr->rank != 0))
4033 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
4034 &code->expr->where);
4039 resolve_call (code);
4043 /* Select is complicated. Also, a SELECT construct could be
4044 a transformed computed GOTO. */
4045 resolve_select (code);
4049 if (code->ext.iterator != NULL)
4050 gfc_resolve_iterator (code->ext.iterator, true);
4054 if (code->expr == NULL)
4055 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
4057 && (code->expr->rank != 0
4058 || code->expr->ts.type != BT_LOGICAL))
4059 gfc_error ("Exit condition of DO WHILE loop at %L must be "
4060 "a scalar LOGICAL expression", &code->expr->where);
4064 if (t == SUCCESS && code->expr != NULL
4065 && code->expr->ts.type != BT_INTEGER)
4066 gfc_error ("STAT tag in ALLOCATE statement at %L must be "
4067 "of type INTEGER", &code->expr->where);
4069 for (a = code->ext.alloc_list; a; a = a->next)
4070 resolve_allocate_expr (a->expr, code);
4074 case EXEC_DEALLOCATE:
4075 if (t == SUCCESS && code->expr != NULL
4076 && code->expr->ts.type != BT_INTEGER)
4078 ("STAT tag in DEALLOCATE statement at %L must be of type "
4079 "INTEGER", &code->expr->where);
4081 for (a = code->ext.alloc_list; a; a = a->next)
4082 resolve_deallocate_expr (a->expr);
4087 if (gfc_resolve_open (code->ext.open) == FAILURE)
4090 resolve_branch (code->ext.open->err, code);
4094 if (gfc_resolve_close (code->ext.close) == FAILURE)
4097 resolve_branch (code->ext.close->err, code);
4100 case EXEC_BACKSPACE:
4104 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
4107 resolve_branch (code->ext.filepos->err, code);
4111 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
4114 resolve_branch (code->ext.inquire->err, code);
4118 gcc_assert (code->ext.inquire != NULL);
4119 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
4122 resolve_branch (code->ext.inquire->err, code);
4127 if (gfc_resolve_dt (code->ext.dt) == FAILURE)
4130 resolve_branch (code->ext.dt->err, code);
4131 resolve_branch (code->ext.dt->end, code);
4132 resolve_branch (code->ext.dt->eor, code);
4136 resolve_transfer (code);
4140 resolve_forall_iterators (code->ext.forall_iterator);
4142 if (code->expr != NULL && code->expr->ts.type != BT_LOGICAL)
4144 ("FORALL mask clause at %L requires a LOGICAL expression",
4145 &code->expr->where);
4149 gfc_internal_error ("resolve_code(): Bad statement code");
4153 cs_base = frame.prev;
4157 /* Resolve initial values and make sure they are compatible with
4161 resolve_values (gfc_symbol * sym)
4164 if (sym->value == NULL)
4167 if (gfc_resolve_expr (sym->value) == FAILURE)
4170 gfc_check_assign_symbol (sym, sym->value);
4174 /* Do anything necessary to resolve a symbol. Right now, we just
4175 assume that an otherwise unknown symbol is a variable. This sort
4176 of thing commonly happens for symbols in module. */
4179 resolve_symbol (gfc_symbol * sym)
4181 /* Zero if we are checking a formal namespace. */
4182 static int formal_ns_flag = 1;
4183 int formal_ns_save, check_constant, mp_flag;
4186 gfc_symtree * symtree;
4187 gfc_symtree * this_symtree;
4190 gfc_formal_arglist * arg;
4192 if (sym->attr.flavor == FL_UNKNOWN)
4195 /* If we find that a flavorless symbol is an interface in one of the
4196 parent namespaces, find its symtree in this namespace, free the
4197 symbol and set the symtree to point to the interface symbol. */
4198 for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
4200 symtree = gfc_find_symtree (ns->sym_root, sym->name);
4201 if (symtree && symtree->n.sym->generic)
4203 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
4207 gfc_free_symbol (sym);
4208 symtree->n.sym->refs++;
4209 this_symtree->n.sym = symtree->n.sym;
4214 /* Otherwise give it a flavor according to such attributes as
4216 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
4217 sym->attr.flavor = FL_VARIABLE;
4220 sym->attr.flavor = FL_PROCEDURE;
4221 if (sym->attr.dimension)
4222 sym->attr.function = 1;
4226 /* Symbols that are module procedures with results (functions) have
4227 the types and array specification copied for type checking in
4228 procedures that call them, as well as for saving to a module
4229 file. These symbols can't stand the scrutiny that their results
4231 mp_flag = (sym->result != NULL && sym->result != sym);
4233 /* Assign default type to symbols that need one and don't have one. */
4234 if (sym->ts.type == BT_UNKNOWN)
4236 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
4237 gfc_set_default_type (sym, 1, NULL);
4239 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
4241 /* The specific case of an external procedure should emit an error
4242 in the case that there is no implicit type. */
4244 gfc_set_default_type (sym, sym->attr.external, NULL);
4247 /* Result may be in another namespace. */
4248 resolve_symbol (sym->result);
4250 sym->ts = sym->result->ts;
4251 sym->as = gfc_copy_array_spec (sym->result->as);
4252 sym->attr.dimension = sym->result->attr.dimension;
4253 sym->attr.pointer = sym->result->attr.pointer;
4258 /* Assumed size arrays and assumed shape arrays must be dummy
4262 && (sym->as->type == AS_ASSUMED_SIZE
4263 || sym->as->type == AS_ASSUMED_SHAPE)
4264 && sym->attr.dummy == 0)
4266 if (sym->as->type == AS_ASSUMED_SIZE)
4267 gfc_error ("Assumed size array at %L must be a dummy argument",
4270 gfc_error ("Assumed shape array at %L must be a dummy argument",
4275 /* A parameter array's shape needs to be constant. */
4277 if (sym->attr.flavor == FL_PARAMETER && sym->as != NULL
4278 && !gfc_is_compile_time_shape (sym->as))
4280 gfc_error ("Parameter array '%s' at %L cannot be automatic "
4281 "or assumed shape", sym->name, &sym->declared_at);
4285 /* A module array's shape needs to be constant. */
4287 if (sym->ns->proc_name
4288 && sym->attr.flavor == FL_VARIABLE
4289 && sym->ns->proc_name->attr.flavor == FL_MODULE
4290 && !sym->attr.use_assoc
4291 && !sym->attr.allocatable
4292 && !sym->attr.pointer
4294 && !gfc_is_compile_time_shape (sym->as))
4296 gfc_error ("Module array '%s' at %L cannot be automatic "
4297 "or assumed shape", sym->name, &sym->declared_at);
4301 /* Make sure that character string variables with assumed length are
4304 if (sym->attr.flavor == FL_VARIABLE && !sym->attr.result
4305 && sym->ts.type == BT_CHARACTER
4306 && sym->ts.cl->length == NULL && sym->attr.dummy == 0)
4308 gfc_error ("Entity with assumed character length at %L must be a "
4309 "dummy argument or a PARAMETER", &sym->declared_at);
4313 /* Make sure a parameter that has been implicitly typed still
4314 matches the implicit type, since PARAMETER statements can precede
4315 IMPLICIT statements. */
4317 if (sym->attr.flavor == FL_PARAMETER
4318 && sym->attr.implicit_type
4319 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym, sym->ns)))
4320 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
4321 "later IMPLICIT type", sym->name, &sym->declared_at);
4323 /* Make sure the types of derived parameters are consistent. This
4324 type checking is deferred until resolution because the type may
4325 refer to a derived type from the host. */
4327 if (sym->attr.flavor == FL_PARAMETER
4328 && sym->ts.type == BT_DERIVED
4329 && !gfc_compare_types (&sym->ts, &sym->value->ts))
4330 gfc_error ("Incompatible derived type in PARAMETER at %L",
4331 &sym->value->where);
4333 /* Make sure symbols with known intent or optional are really dummy
4334 variable. Because of ENTRY statement, this has to be deferred
4335 until resolution time. */
4337 if (! sym->attr.dummy
4338 && (sym->attr.optional
4339 || sym->attr.intent != INTENT_UNKNOWN))
4341 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
4345 if (sym->attr.proc == PROC_ST_FUNCTION)
4347 if (sym->ts.type == BT_CHARACTER)
4349 gfc_charlen *cl = sym->ts.cl;
4350 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
4352 gfc_error ("Character-valued statement function '%s' at %L must "
4353 "have constant length", sym->name, &sym->declared_at);
4359 /* If a derived type symbol has reached this point, without its
4360 type being declared, we have an error. Notice that most
4361 conditions that produce undefined derived types have already
4362 been dealt with. However, the likes of:
4363 implicit type(t) (t) ..... call foo (t) will get us here if
4364 the type is not declared in the scope of the implicit
4365 statement. Change the type to BT_UNKNOWN, both because it is so
4366 and to prevent an ICE. */
4367 if (sym->ts.type == BT_DERIVED
4368 && sym->ts.derived->components == NULL)
4370 gfc_error ("The derived type '%s' at %L is of type '%s', "
4371 "which has not been defined.", sym->name,
4372 &sym->declared_at, sym->ts.derived->name);
4373 sym->ts.type = BT_UNKNOWN;
4377 /* If a component of a derived type is of a type declared to be private,
4378 either the derived type definition must contain the PRIVATE statement,
4379 or the derived type must be private. (4.4.1 just after R427) */
4380 if (sym->attr.flavor == FL_DERIVED
4381 && sym->component_access != ACCESS_PRIVATE
4382 && gfc_check_access(sym->attr.access, sym->ns->default_access))
4384 for (c = sym->components; c; c = c->next)
4386 if (c->ts.type == BT_DERIVED
4387 && !c->ts.derived->attr.use_assoc
4388 && !gfc_check_access(c->ts.derived->attr.access,
4389 c->ts.derived->ns->default_access))
4391 gfc_error ("The component '%s' is a PRIVATE type and cannot be "
4392 "a component of '%s', which is PUBLIC at %L",
4393 c->name, sym->name, &sym->declared_at);
4399 /* An assumed-size array with INTENT(OUT) shall not be of a type for which
4400 default initialization is defined (5.1.2.4.4). */
4401 if (sym->ts.type == BT_DERIVED
4403 && sym->attr.intent == INTENT_OUT
4405 && sym->as->type == AS_ASSUMED_SIZE)
4407 for (c = sym->ts.derived->components; c; c = c->next)
4411 gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
4412 "ASSUMED SIZE and so cannot have a default initializer",
4413 sym->name, &sym->declared_at);
4420 /* Ensure that derived type formal arguments of a public procedure
4421 are not of a private type. */
4422 if (sym->attr.flavor == FL_PROCEDURE
4423 && gfc_check_access(sym->attr.access, sym->ns->default_access))
4425 for (arg = sym->formal; arg; arg = arg->next)
4428 && arg->sym->ts.type == BT_DERIVED
4429 && !arg->sym->ts.derived->attr.use_assoc
4430 && !gfc_check_access(arg->sym->ts.derived->attr.access,
4431 arg->sym->ts.derived->ns->default_access))
4433 gfc_error_now ("'%s' is a PRIVATE type and cannot be "
4434 "a dummy argument of '%s', which is PUBLIC at %L",
4435 arg->sym->name, sym->name, &sym->declared_at);
4436 /* Stop this message from recurring. */
4437 arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
4443 /* Constraints on deferred shape variable. */
4444 if (sym->attr.flavor == FL_VARIABLE
4445 || (sym->attr.flavor == FL_PROCEDURE
4446 && sym->attr.function))
4448 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
4450 if (sym->attr.allocatable)
4452 if (sym->attr.dimension)
4453 gfc_error ("Allocatable array '%s' at %L must have "
4454 "a deferred shape", sym->name, &sym->declared_at);
4456 gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
4457 sym->name, &sym->declared_at);
4461 if (sym->attr.pointer && sym->attr.dimension)
4463 gfc_error ("Array pointer '%s' at %L must have a deferred shape",
4464 sym->name, &sym->declared_at);
4471 if (!mp_flag && !sym->attr.allocatable
4472 && !sym->attr.pointer && !sym->attr.dummy)
4474 gfc_error ("Array '%s' at %L cannot have a deferred shape",
4475 sym->name, &sym->declared_at);
4481 switch (sym->attr.flavor)
4484 /* Can the symbol have an initializer? */
4486 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
4487 || sym->attr.intrinsic || sym->attr.result)
4489 else if (sym->attr.dimension && !sym->attr.pointer)
4491 /* Don't allow initialization of automatic arrays. */
4492 for (i = 0; i < sym->as->rank; i++)
4494 if (sym->as->lower[i] == NULL
4495 || sym->as->lower[i]->expr_type != EXPR_CONSTANT
4496 || sym->as->upper[i] == NULL
4497 || sym->as->upper[i]->expr_type != EXPR_CONSTANT)
4505 /* Reject illegal initializers. */
4506 if (sym->value && flag)
4508 if (sym->attr.allocatable)
4509 gfc_error ("Allocatable '%s' at %L cannot have an initializer",
4510 sym->name, &sym->declared_at);
4511 else if (sym->attr.external)
4512 gfc_error ("External '%s' at %L cannot have an initializer",
4513 sym->name, &sym->declared_at);
4514 else if (sym->attr.dummy)
4515 gfc_error ("Dummy '%s' at %L cannot have an initializer",
4516 sym->name, &sym->declared_at);
4517 else if (sym->attr.intrinsic)
4518 gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
4519 sym->name, &sym->declared_at);
4520 else if (sym->attr.result)
4521 gfc_error ("Function result '%s' at %L cannot have an initializer",
4522 sym->name, &sym->declared_at);
4524 gfc_error ("Automatic array '%s' at %L cannot have an initializer",
4525 sym->name, &sym->declared_at);
4529 /* Assign default initializer. */
4530 if (sym->ts.type == BT_DERIVED && !(sym->value || flag)
4531 && !sym->attr.pointer)
4532 sym->value = gfc_default_initializer (&sym->ts);
4536 /* Reject PRIVATE objects in a PUBLIC namelist. */
4537 if (gfc_check_access(sym->attr.access, sym->ns->default_access))
4539 for (nl = sym->namelist; nl; nl = nl->next)
4541 if (!nl->sym->attr.use_assoc
4543 !(sym->ns->parent == nl->sym->ns)
4545 !gfc_check_access(nl->sym->attr.access,
4546 nl->sym->ns->default_access))
4547 gfc_error ("PRIVATE symbol '%s' cannot be member of "
4548 "PUBLIC namelist at %L", nl->sym->name,
4556 /* An external symbol falls through to here if it is not referenced. */
4557 if (sym->attr.external && sym->value)
4559 gfc_error ("External object '%s' at %L may not have an initializer",
4560 sym->name, &sym->declared_at);
4568 /* Make sure that intrinsic exist */
4569 if (sym->attr.intrinsic
4570 && ! gfc_intrinsic_name(sym->name, 0)
4571 && ! gfc_intrinsic_name(sym->name, 1))
4572 gfc_error("Intrinsic at %L does not exist", &sym->declared_at);
4574 /* Resolve array specifier. Check as well some constraints
4575 on COMMON blocks. */
4577 check_constant = sym->attr.in_common && !sym->attr.pointer;
4578 gfc_resolve_array_spec (sym->as, check_constant);
4580 /* Resolve formal namespaces. */
4582 if (formal_ns_flag && sym != NULL && sym->formal_ns != NULL)
4584 formal_ns_save = formal_ns_flag;
4586 gfc_resolve (sym->formal_ns);
4587 formal_ns_flag = formal_ns_save;
4593 /************* Resolve DATA statements *************/
4597 gfc_data_value *vnode;
4603 /* Advance the values structure to point to the next value in the data list. */
4606 next_data_value (void)
4608 while (values.left == 0)
4610 if (values.vnode->next == NULL)
4613 values.vnode = values.vnode->next;
4614 values.left = values.vnode->repeat;
4622 check_data_variable (gfc_data_variable * var, locus * where)
4628 ar_type mark = AR_UNKNOWN;
4630 mpz_t section_index[GFC_MAX_DIMENSIONS];
4634 if (gfc_resolve_expr (var->expr) == FAILURE)
4638 mpz_init_set_si (offset, 0);
4641 if (e->expr_type != EXPR_VARIABLE)
4642 gfc_internal_error ("check_data_variable(): Bad expression");
4646 mpz_init_set_ui (size, 1);
4653 /* Find the array section reference. */
4654 for (ref = e->ref; ref; ref = ref->next)
4656 if (ref->type != REF_ARRAY)
4658 if (ref->u.ar.type == AR_ELEMENT)
4664 /* Set marks according to the reference pattern. */
4665 switch (ref->u.ar.type)
4673 /* Get the start position of array section. */
4674 gfc_get_section_index (ar, section_index, &offset);
4682 if (gfc_array_size (e, &size) == FAILURE)
4684 gfc_error ("Nonconstant array section at %L in DATA statement",
4693 while (mpz_cmp_ui (size, 0) > 0)
4695 if (next_data_value () == FAILURE)
4697 gfc_error ("DATA statement at %L has more variables than values",
4703 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
4707 /* If we have more than one element left in the repeat count,
4708 and we have more than one element left in the target variable,
4709 then create a range assignment. */
4710 /* ??? Only done for full arrays for now, since array sections
4712 if (mark == AR_FULL && ref && ref->next == NULL
4713 && values.left > 1 && mpz_cmp_ui (size, 1) > 0)
4717 if (mpz_cmp_ui (size, values.left) >= 0)
4719 mpz_init_set_ui (range, values.left);
4720 mpz_sub_ui (size, size, values.left);
4725 mpz_init_set (range, size);
4726 values.left -= mpz_get_ui (size);
4727 mpz_set_ui (size, 0);
4730 gfc_assign_data_value_range (var->expr, values.vnode->expr,
4733 mpz_add (offset, offset, range);
4737 /* Assign initial value to symbol. */
4741 mpz_sub_ui (size, size, 1);
4743 gfc_assign_data_value (var->expr, values.vnode->expr, offset);
4745 if (mark == AR_FULL)
4746 mpz_add_ui (offset, offset, 1);
4748 /* Modify the array section indexes and recalculate the offset
4749 for next element. */
4750 else if (mark == AR_SECTION)
4751 gfc_advance_section (section_index, ar, &offset);
4755 if (mark == AR_SECTION)
4757 for (i = 0; i < ar->dimen; i++)
4758 mpz_clear (section_index[i]);
4768 static try traverse_data_var (gfc_data_variable *, locus *);
4770 /* Iterate over a list of elements in a DATA statement. */
4773 traverse_data_list (gfc_data_variable * var, locus * where)
4776 iterator_stack frame;
4779 mpz_init (frame.value);
4781 mpz_init_set (trip, var->iter.end->value.integer);
4782 mpz_sub (trip, trip, var->iter.start->value.integer);
4783 mpz_add (trip, trip, var->iter.step->value.integer);
4785 mpz_div (trip, trip, var->iter.step->value.integer);
4787 mpz_set (frame.value, var->iter.start->value.integer);
4789 frame.prev = iter_stack;
4790 frame.variable = var->iter.var->symtree;
4791 iter_stack = &frame;
4793 while (mpz_cmp_ui (trip, 0) > 0)
4795 if (traverse_data_var (var->list, where) == FAILURE)
4801 e = gfc_copy_expr (var->expr);
4802 if (gfc_simplify_expr (e, 1) == FAILURE)
4808 mpz_add (frame.value, frame.value, var->iter.step->value.integer);
4810 mpz_sub_ui (trip, trip, 1);
4814 mpz_clear (frame.value);
4816 iter_stack = frame.prev;
4821 /* Type resolve variables in the variable list of a DATA statement. */
4824 traverse_data_var (gfc_data_variable * var, locus * where)
4828 for (; var; var = var->next)
4830 if (var->expr == NULL)
4831 t = traverse_data_list (var, where);
4833 t = check_data_variable (var, where);
4843 /* Resolve the expressions and iterators associated with a data statement.
4844 This is separate from the assignment checking because data lists should
4845 only be resolved once. */
4848 resolve_data_variables (gfc_data_variable * d)
4850 for (; d; d = d->next)
4852 if (d->list == NULL)
4854 if (gfc_resolve_expr (d->expr) == FAILURE)
4859 if (gfc_resolve_iterator (&d->iter, false) == FAILURE)
4862 if (d->iter.start->expr_type != EXPR_CONSTANT
4863 || d->iter.end->expr_type != EXPR_CONSTANT
4864 || d->iter.step->expr_type != EXPR_CONSTANT)
4865 gfc_internal_error ("resolve_data_variables(): Bad iterator");
4867 if (resolve_data_variables (d->list) == FAILURE)
4876 /* Resolve a single DATA statement. We implement this by storing a pointer to
4877 the value list into static variables, and then recursively traversing the
4878 variables list, expanding iterators and such. */
4881 resolve_data (gfc_data * d)
4883 if (resolve_data_variables (d->var) == FAILURE)
4886 values.vnode = d->value;
4887 values.left = (d->value == NULL) ? 0 : d->value->repeat;
4889 if (traverse_data_var (d->var, &d->where) == FAILURE)
4892 /* At this point, we better not have any values left. */
4894 if (next_data_value () == SUCCESS)
4895 gfc_error ("DATA statement at %L has more values than variables",
4900 /* Determines if a variable is not 'pure', ie not assignable within a pure
4901 procedure. Returns zero if assignment is OK, nonzero if there is a problem.
4905 gfc_impure_variable (gfc_symbol * sym)
4907 if (sym->attr.use_assoc || sym->attr.in_common)
4910 if (sym->ns != gfc_current_ns)
4911 return !sym->attr.function;
4913 /* TODO: Check storage association through EQUIVALENCE statements */
4919 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
4920 symbol of the current procedure. */
4923 gfc_pure (gfc_symbol * sym)
4925 symbol_attribute attr;
4928 sym = gfc_current_ns->proc_name;
4934 return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental);
4938 /* Test whether the current procedure is elemental or not. */
4941 gfc_elemental (gfc_symbol * sym)
4943 symbol_attribute attr;
4946 sym = gfc_current_ns->proc_name;
4951 return attr.flavor == FL_PROCEDURE && attr.elemental;
4955 /* Warn about unused labels. */
4958 warn_unused_label (gfc_namespace * ns)
4969 for (; l; l = l->prev)
4971 if (l->defined == ST_LABEL_UNKNOWN)
4974 switch (l->referenced)
4976 case ST_LABEL_UNKNOWN:
4977 gfc_warning ("Label %d at %L defined but not used", l->value,
4981 case ST_LABEL_BAD_TARGET:
4982 gfc_warning ("Label %d at %L defined but cannot be used", l->value,
4993 /* Returns the sequence type of a symbol or sequence. */
4996 sequence_type (gfc_typespec ts)
5005 if (ts.derived->components == NULL)
5006 return SEQ_NONDEFAULT;
5008 result = sequence_type (ts.derived->components->ts);
5009 for (c = ts.derived->components->next; c; c = c->next)
5010 if (sequence_type (c->ts) != result)
5016 if (ts.kind != gfc_default_character_kind)
5017 return SEQ_NONDEFAULT;
5019 return SEQ_CHARACTER;
5022 if (ts.kind != gfc_default_integer_kind)
5023 return SEQ_NONDEFAULT;
5028 if (!(ts.kind == gfc_default_real_kind
5029 || ts.kind == gfc_default_double_kind))
5030 return SEQ_NONDEFAULT;
5035 if (ts.kind != gfc_default_complex_kind)
5036 return SEQ_NONDEFAULT;
5041 if (ts.kind != gfc_default_logical_kind)
5042 return SEQ_NONDEFAULT;
5047 return SEQ_NONDEFAULT;
5052 /* Resolve derived type EQUIVALENCE object. */
5055 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
5058 gfc_component *c = derived->components;
5063 /* Shall not be an object of nonsequence derived type. */
5064 if (!derived->attr.sequence)
5066 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
5067 "attribute to be an EQUIVALENCE object", sym->name, &e->where);
5071 for (; c ; c = c->next)
5074 if (d && (resolve_equivalence_derived (c->ts.derived, sym, e) == FAILURE))
5077 /* Shall not be an object of sequence derived type containing a pointer
5078 in the structure. */
5081 gfc_error ("Derived type variable '%s' at %L with pointer component(s) "
5082 "cannot be an EQUIVALENCE object", sym->name, &e->where);
5088 gfc_error ("Derived type variable '%s' at %L with default initializer "
5089 "cannot be an EQUIVALENCE object", sym->name, &e->where);
5097 /* Resolve equivalence object.
5098 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target,
5099 an allocatable array, an object of nonsequence derived type, an object of
5100 sequence derived type containing a pointer at any level of component
5101 selection, an automatic object, a function name, an entry name, a result
5102 name, a named constant, a structure component, or a subobject of any of
5103 the preceding objects. A substring shall not have length zero. A
5104 derived type shall not have components with default initialization nor
5105 shall two objects of an equivalence group be initialized.
5106 The simple constraints are done in symbol.c(check_conflict) and the rest
5107 are implemented here. */
5110 resolve_equivalence (gfc_equiv *eq)
5113 gfc_symbol *derived;
5114 gfc_symbol *first_sym;
5117 locus *last_where = NULL;
5118 seq_type eq_type, last_eq_type;
5119 gfc_typespec *last_ts;
5121 const char *value_name;
5125 last_ts = &eq->expr->symtree->n.sym->ts;
5127 first_sym = eq->expr->symtree->n.sym;
5129 for (object = 1; eq; eq = eq->eq, object++)
5133 e->ts = e->symtree->n.sym->ts;
5134 /* match_varspec might not know yet if it is seeing
5135 array reference or substring reference, as it doesn't
5137 if (e->ref && e->ref->type == REF_ARRAY)
5139 gfc_ref *ref = e->ref;
5140 sym = e->symtree->n.sym;
5142 if (sym->attr.dimension)
5144 ref->u.ar.as = sym->as;
5148 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
5149 if (e->ts.type == BT_CHARACTER
5151 && ref->type == REF_ARRAY
5152 && ref->u.ar.dimen == 1
5153 && ref->u.ar.dimen_type[0] == DIMEN_RANGE
5154 && ref->u.ar.stride[0] == NULL)
5156 gfc_expr *start = ref->u.ar.start[0];
5157 gfc_expr *end = ref->u.ar.end[0];
5160 /* Optimize away the (:) reference. */
5161 if (start == NULL && end == NULL)
5166 e->ref->next = ref->next;
5171 ref->type = REF_SUBSTRING;
5173 start = gfc_int_expr (1);
5174 ref->u.ss.start = start;
5175 if (end == NULL && e->ts.cl)
5176 end = gfc_copy_expr (e->ts.cl->length);
5177 ref->u.ss.end = end;
5178 ref->u.ss.length = e->ts.cl;
5185 /* Any further ref is an error. */
5188 gcc_assert (ref->type == REF_ARRAY);
5189 gfc_error ("Syntax error in EQUIVALENCE statement at %L",
5195 if (gfc_resolve_expr (e) == FAILURE)
5198 sym = e->symtree->n.sym;
5200 /* An equivalence statement cannot have more than one initialized
5204 if (value_name != NULL)
5206 gfc_error ("Initialized objects '%s' and '%s' cannot both "
5207 "be in the EQUIVALENCE statement at %L",
5208 value_name, sym->name, &e->where);
5212 value_name = sym->name;
5215 /* Shall not equivalence common block variables in a PURE procedure. */
5216 if (sym->ns->proc_name
5217 && sym->ns->proc_name->attr.pure
5218 && sym->attr.in_common)
5220 gfc_error ("Common block member '%s' at %L cannot be an EQUIVALENCE "
5221 "object in the pure procedure '%s'",
5222 sym->name, &e->where, sym->ns->proc_name->name);
5226 /* Shall not be a named constant. */
5227 if (e->expr_type == EXPR_CONSTANT)
5229 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
5230 "object", sym->name, &e->where);
5234 derived = e->ts.derived;
5235 if (derived && resolve_equivalence_derived (derived, sym, e) == FAILURE)
5238 /* Check that the types correspond correctly:
5240 A numeric sequence structure may be equivalenced to another sequence
5241 structure, an object of default integer type, default real type, double
5242 precision real type, default logical type such that components of the
5243 structure ultimately only become associated to objects of the same
5244 kind. A character sequence structure may be equivalenced to an object
5245 of default character kind or another character sequence structure.
5246 Other objects may be equivalenced only to objects of the same type and
5249 /* Identical types are unconditionally OK. */
5250 if (object == 1 || gfc_compare_types (last_ts, &sym->ts))
5251 goto identical_types;
5253 last_eq_type = sequence_type (*last_ts);
5254 eq_type = sequence_type (sym->ts);
5256 /* Since the pair of objects is not of the same type, mixed or
5257 non-default sequences can be rejected. */
5259 msg = "Sequence %s with mixed components in EQUIVALENCE "
5260 "statement at %L with different type objects";
5262 && last_eq_type == SEQ_MIXED
5263 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
5264 last_where) == FAILURE)
5265 || (eq_type == SEQ_MIXED
5266 && gfc_notify_std (GFC_STD_GNU, msg,sym->name,
5267 &e->where) == FAILURE))
5270 msg = "Non-default type object or sequence %s in EQUIVALENCE "
5271 "statement at %L with objects of different type";
5273 && last_eq_type == SEQ_NONDEFAULT
5274 && gfc_notify_std (GFC_STD_GNU, msg, first_sym->name,
5275 last_where) == FAILURE)
5276 || (eq_type == SEQ_NONDEFAULT
5277 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
5278 &e->where) == FAILURE))
5281 msg ="Non-CHARACTER object '%s' in default CHARACTER "
5282 "EQUIVALENCE statement at %L";
5283 if (last_eq_type == SEQ_CHARACTER
5284 && eq_type != SEQ_CHARACTER
5285 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
5286 &e->where) == FAILURE)
5289 msg ="Non-NUMERIC object '%s' in default NUMERIC "
5290 "EQUIVALENCE statement at %L";
5291 if (last_eq_type == SEQ_NUMERIC
5292 && eq_type != SEQ_NUMERIC
5293 && gfc_notify_std (GFC_STD_GNU, msg, sym->name,
5294 &e->where) == FAILURE)
5299 last_where = &e->where;
5304 /* Shall not be an automatic array. */
5305 if (e->ref->type == REF_ARRAY
5306 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
5308 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
5309 "an EQUIVALENCE object", sym->name, &e->where);
5316 /* Shall not be a structure component. */
5317 if (r->type == REF_COMPONENT)
5319 gfc_error ("Structure component '%s' at %L cannot be an "
5320 "EQUIVALENCE object",
5321 r->u.c.component->name, &e->where);
5325 /* A substring shall not have length zero. */
5326 if (r->type == REF_SUBSTRING)
5328 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
5330 gfc_error ("Substring at %L has length zero",
5331 &r->u.ss.start->where);
5341 /* Resolve function and ENTRY types, issue diagnostics if needed. */
5344 resolve_fntype (gfc_namespace * ns)
5349 if (ns->proc_name == NULL || !ns->proc_name->attr.function)
5352 /* If there are any entries, ns->proc_name is the entry master
5353 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */
5355 sym = ns->entries->sym;
5357 sym = ns->proc_name;
5358 if (sym->result == sym
5359 && sym->ts.type == BT_UNKNOWN
5360 && gfc_set_default_type (sym, 0, NULL) == FAILURE
5361 && !sym->attr.untyped)
5363 gfc_error ("Function '%s' at %L has no IMPLICIT type",
5364 sym->name, &sym->declared_at);
5365 sym->attr.untyped = 1;
5369 for (el = ns->entries->next; el; el = el->next)
5371 if (el->sym->result == el->sym
5372 && el->sym->ts.type == BT_UNKNOWN
5373 && gfc_set_default_type (el->sym, 0, NULL) == FAILURE
5374 && !el->sym->attr.untyped)
5376 gfc_error ("ENTRY '%s' at %L has no IMPLICIT type",
5377 el->sym->name, &el->sym->declared_at);
5378 el->sym->attr.untyped = 1;
5384 /* This function is called after a complete program unit has been compiled.
5385 Its purpose is to examine all of the expressions associated with a program
5386 unit, assign types to all intermediate expressions, make sure that all
5387 assignments are to compatible types and figure out which names refer to
5388 which functions or subroutines. */
5391 gfc_resolve (gfc_namespace * ns)
5393 gfc_namespace *old_ns, *n;
5398 old_ns = gfc_current_ns;
5399 gfc_current_ns = ns;
5401 resolve_entries (ns);
5403 resolve_contained_functions (ns);
5405 gfc_traverse_ns (ns, resolve_symbol);
5407 resolve_fntype (ns);
5409 for (n = ns->contained; n; n = n->sibling)
5411 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
5412 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
5413 "also be PURE", n->proc_name->name,
5414 &n->proc_name->declared_at);
5420 gfc_check_interfaces (ns);
5422 for (cl = ns->cl_list; cl; cl = cl->next)
5424 if (cl->length == NULL || gfc_resolve_expr (cl->length) == FAILURE)
5427 if (gfc_simplify_expr (cl->length, 0) == FAILURE)
5430 if (gfc_specification_expr (cl->length) == FAILURE)
5434 gfc_traverse_ns (ns, resolve_values);
5440 for (d = ns->data; d; d = d->next)
5444 gfc_traverse_ns (ns, gfc_formalize_init_value);
5446 for (eq = ns->equiv; eq; eq = eq->next)
5447 resolve_equivalence (eq);
5450 resolve_code (ns->code, ns);
5452 /* Warn about unused labels. */
5453 if (gfc_option.warn_unused_labels)
5454 warn_unused_label (ns);
5456 gfc_current_ns = old_ns;