1 /* Perform type resolution on the various stuctures.
2 Copyright (C) 2001, 2002, 2003, 2004 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, 59 Temple Place - Suite 330,Boston, MA
24 #include "arith.h" /* For gfc_compare_expr(). */
28 /* Stack to push the current if we descend into a block during
29 resolution. See resolve_branch() and resolve_code(). */
31 typedef struct code_stack
33 struct gfc_code *head, *current;
34 struct code_stack *prev;
38 static code_stack *cs_base = NULL;
41 /* Nonzero if we're inside a FORALL block */
43 static int forall_flag;
45 /* Resolve types of formal argument lists. These have to be done early so that
46 the formal argument lists of module procedures can be copied to the
47 containing module before the individual procedures are resolved
48 individually. We also resolve argument lists of procedures in interface
49 blocks because they are self-contained scoping units.
51 Since a dummy argument cannot be a non-dummy procedure, the only
52 resort left for untyped names are the IMPLICIT types. */
55 resolve_formal_arglist (gfc_symbol * proc)
57 gfc_formal_arglist *f;
61 /* TODO: Procedures whose return character length parameter is not constant
62 or assumed must also have explicit interfaces. */
63 if (proc->result != NULL)
68 if (gfc_elemental (proc)
69 || sym->attr.pointer || sym->attr.allocatable
70 || (sym->as && sym->as->rank > 0))
71 proc->attr.always_explicit = 1;
73 for (f = proc->formal; f; f = f->next)
79 /* Alternate return placeholder. */
80 if (gfc_elemental (proc))
81 gfc_error ("Alternate return specifier in elemental subroutine "
82 "'%s' at %L is not allowed", proc->name,
84 if (proc->attr.function)
85 gfc_error ("Alternate return specifier in function "
86 "'%s' at %L is not allowed", proc->name,
91 if (sym->attr.if_source != IFSRC_UNKNOWN)
92 resolve_formal_arglist (sym);
94 if (sym->attr.subroutine || sym->attr.external || sym->attr.intrinsic)
96 if (gfc_pure (proc) && !gfc_pure (sym))
99 ("Dummy procedure '%s' of PURE procedure at %L must also "
100 "be PURE", sym->name, &sym->declared_at);
104 if (gfc_elemental (proc))
107 ("Dummy procedure at %L not allowed in ELEMENTAL procedure",
115 if (sym->ts.type == BT_UNKNOWN)
117 if (!sym->attr.function || sym->result == sym)
118 gfc_set_default_type (sym, 1, sym->ns);
121 /* Set the type of the RESULT, then copy. */
122 if (sym->result->ts.type == BT_UNKNOWN)
123 gfc_set_default_type (sym->result, 1, sym->result->ns);
125 sym->ts = sym->result->ts;
127 sym->as = gfc_copy_array_spec (sym->result->as);
131 gfc_resolve_array_spec (sym->as, 0);
133 /* We can't tell if an array with dimension (:) is assumed or deferred
134 shape until we know if it has the pointer or allocatable attributes.
136 if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
137 && !(sym->attr.pointer || sym->attr.allocatable))
139 sym->as->type = AS_ASSUMED_SHAPE;
140 for (i = 0; i < sym->as->rank; i++)
141 sym->as->lower[i] = gfc_int_expr (1);
144 if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
145 || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
146 || sym->attr.optional)
147 proc->attr.always_explicit = 1;
149 /* If the flavor is unknown at this point, it has to be a variable.
150 A procedure specification would have already set the type. */
152 if (sym->attr.flavor == FL_UNKNOWN)
153 gfc_add_flavor (&sym->attr, FL_VARIABLE, &sym->declared_at);
157 if (proc->attr.function && !sym->attr.pointer
158 && sym->attr.flavor != FL_PROCEDURE
159 && sym->attr.intent != INTENT_IN)
161 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
162 "INTENT(IN)", sym->name, proc->name,
165 if (proc->attr.subroutine && !sym->attr.pointer
166 && sym->attr.intent == INTENT_UNKNOWN)
169 ("Argument '%s' of pure subroutine '%s' at %L must have "
170 "its INTENT specified", sym->name, proc->name,
175 if (gfc_elemental (proc))
180 ("Argument '%s' of elemental procedure at %L must be scalar",
181 sym->name, &sym->declared_at);
185 if (sym->attr.pointer)
188 ("Argument '%s' of elemental procedure at %L cannot have "
189 "the POINTER attribute", sym->name, &sym->declared_at);
194 /* Each dummy shall be specified to be scalar. */
195 if (proc->attr.proc == PROC_ST_FUNCTION)
200 ("Argument '%s' of statement function at %L must be scalar",
201 sym->name, &sym->declared_at);
205 if (sym->ts.type == BT_CHARACTER)
207 gfc_charlen *cl = sym->ts.cl;
208 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
211 ("Character-valued argument '%s' of statement function at "
212 "%L must has constant length",
213 sym->name, &sym->declared_at);
222 /* Work function called when searching for symbols that have argument lists
223 associated with them. */
226 find_arglists (gfc_symbol * sym)
229 if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
232 resolve_formal_arglist (sym);
236 /* Given a namespace, resolve all formal argument lists within the namespace.
240 resolve_formal_arglists (gfc_namespace * ns)
246 gfc_traverse_ns (ns, find_arglists);
251 resolve_contained_fntype (gfc_symbol * sym, gfc_namespace * ns)
255 /* If this namespace is not a function, ignore it. */
257 || !(sym->attr.function
258 || sym->attr.flavor == FL_VARIABLE))
261 /* Try to find out of what type the function is. If there was an
262 explicit RESULT clause, try to get the type from it. If the
263 function is never defined, set it to the implicit type. If
264 even that fails, give up. */
265 if (sym->result != NULL)
268 if (sym->ts.type == BT_UNKNOWN)
270 /* Assume we can find an implicit type. */
273 if (sym->result == NULL)
274 t = gfc_set_default_type (sym, 0, ns);
277 if (sym->result->ts.type == BT_UNKNOWN)
278 t = gfc_set_default_type (sym->result, 0, NULL);
280 sym->ts = sym->result->ts;
284 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
285 sym->name, &sym->declared_at); /* FIXME */
290 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
291 introduce duplicates. */
294 merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
296 gfc_formal_arglist *f, *new_arglist;
299 for (; new_args != NULL; new_args = new_args->next)
301 new_sym = new_args->sym;
302 /* See if ths arg is already in the formal argument list. */
303 for (f = proc->formal; f; f = f->next)
305 if (new_sym == f->sym)
312 /* Add a new argument. Argument order is not important. */
313 new_arglist = gfc_get_formal_arglist ();
314 new_arglist->sym = new_sym;
315 /* We mark all arguments as optional, since in the common case
316 only a subset of the arguments will be present. This avoids
317 having to special case arguments of master functions later on. */
318 new_arglist->sym->attr.optional = 1;
319 new_arglist->next = proc->formal;
320 proc->formal = new_arglist;
325 /* Resolve alternate entry points. If a symbol has multiple entry points we
326 create a new master symbol for the main routine, and turn the existing
327 symbol into an entry point. */
330 resolve_entries (gfc_namespace * ns)
332 gfc_namespace *old_ns;
336 char name[GFC_MAX_SYMBOL_LEN + 1];
337 static int master_count = 0;
339 if (ns->proc_name == NULL)
342 /* No need to do anything if this procedure doesn't have alternate entry
347 /* We may already have resolved alternate entry points. */
348 if (ns->proc_name->attr.entry_master)
351 /* If this isn't a procedure something has gone horribly wrong. */
352 assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
354 /* Remember the current namespace. */
355 old_ns = gfc_current_ns;
359 /* Add the main entry point to the list of entry points. */
360 el = gfc_get_entry_list ();
361 el->sym = ns->proc_name;
363 el->next = ns->entries;
365 ns->proc_name->attr.entry = 1;
367 /* Add an entry statement for it. */
374 /* Create a new symbol for the master function. */
375 /* Give the internal function a unique name (within this file).
376 Also include the function name so the user has some hope of figuring
377 out what is going on. */
378 snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
379 master_count++, ns->proc_name->name);
380 name[GFC_MAX_SYMBOL_LEN] = '\0';
381 gfc_get_ha_symbol (name, &proc);
382 assert (proc != NULL);
384 gfc_add_procedure (&proc->attr, PROC_INTERNAL, NULL);
385 if (ns->proc_name->attr.subroutine)
386 gfc_add_subroutine (&proc->attr, NULL);
389 gfc_add_function (&proc->attr, NULL);
390 gfc_internal_error ("TODO: Functions with alternate entry points");
392 proc->attr.access = ACCESS_PRIVATE;
393 proc->attr.entry_master = 1;
395 /* Merge all the entry point arguments. */
396 for (el = ns->entries; el; el = el->next)
397 merge_argument_lists (proc, el->sym->formal);
399 /* Use the master function for the function body. */
400 ns->proc_name = proc;
402 /* Finalize the new symbols. */
403 gfc_commit_symbols ();
405 /* Restore the original namespace. */
406 gfc_current_ns = old_ns;
410 /* Resolve contained function types. Because contained functions can call one
411 another, they have to be worked out before any of the contained procedures
414 The good news is that if a function doesn't already have a type, the only
415 way it can get one is through an IMPLICIT type or a RESULT variable, because
416 by definition contained functions are contained namespace they're contained
417 in, not in a sibling or parent namespace. */
420 resolve_contained_functions (gfc_namespace * ns)
422 gfc_namespace *child;
425 resolve_formal_arglists (ns);
427 for (child = ns->contained; child; child = child->sibling)
429 /* Resolve alternate entry points first. */
430 resolve_entries (child);
432 /* Then check function return types. */
433 resolve_contained_fntype (child->proc_name, child);
434 for (el = child->entries; el; el = el->next)
435 resolve_contained_fntype (el->sym, child);
440 /* Resolve all of the elements of a structure constructor and make sure that
441 the types are correct. */
444 resolve_structure_cons (gfc_expr * expr)
446 gfc_constructor *cons;
451 cons = expr->value.constructor;
452 /* A constructor may have references if it is the result of substituting a
453 parameter variable. In this case we just pull out the component we
456 comp = expr->ref->u.c.sym->components;
458 comp = expr->ts.derived->components;
460 for (; comp; comp = comp->next, cons = cons->next)
468 if (gfc_resolve_expr (cons->expr) == FAILURE)
474 /* If we don't have the right type, try to convert it. */
476 if (!gfc_compare_types (&cons->expr->ts, &comp->ts)
477 && gfc_convert_type (cons->expr, &comp->ts, 1) == FAILURE)
486 /****************** Expression name resolution ******************/
488 /* Returns 0 if a symbol was not declared with a type or
489 attribute declaration statement, nonzero otherwise. */
492 was_declared (gfc_symbol * sym)
498 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
501 if (a.allocatable || a.dimension || a.external || a.intrinsic
502 || a.optional || a.pointer || a.save || a.target
503 || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
510 /* Determine if a symbol is generic or not. */
513 generic_sym (gfc_symbol * sym)
517 if (sym->attr.generic ||
518 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
521 if (was_declared (sym) || sym->ns->parent == NULL)
524 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
526 return (s == NULL) ? 0 : generic_sym (s);
530 /* Determine if a symbol is specific or not. */
533 specific_sym (gfc_symbol * sym)
537 if (sym->attr.if_source == IFSRC_IFBODY
538 || sym->attr.proc == PROC_MODULE
539 || sym->attr.proc == PROC_INTERNAL
540 || sym->attr.proc == PROC_ST_FUNCTION
541 || (sym->attr.intrinsic &&
542 gfc_specific_intrinsic (sym->name))
543 || sym->attr.external)
546 if (was_declared (sym) || sym->ns->parent == NULL)
549 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
551 return (s == NULL) ? 0 : specific_sym (s);
555 /* Figure out if the procedure is specific, generic or unknown. */
558 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
562 procedure_kind (gfc_symbol * sym)
565 if (generic_sym (sym))
566 return PTYPE_GENERIC;
568 if (specific_sym (sym))
569 return PTYPE_SPECIFIC;
571 return PTYPE_UNKNOWN;
575 /* Resolve an actual argument list. Most of the time, this is just
576 resolving the expressions in the list.
577 The exception is that we sometimes have to decide whether arguments
578 that look like procedure arguments are really simple variable
582 resolve_actual_arglist (gfc_actual_arglist * arg)
585 gfc_symtree *parent_st;
588 for (; arg; arg = arg->next)
594 /* Check the label is a valid branching target. */
597 if (arg->label->defined == ST_LABEL_UNKNOWN)
599 gfc_error ("Label %d referenced at %L is never defined",
600 arg->label->value, &arg->label->where);
607 if (e->ts.type != BT_PROCEDURE)
609 if (gfc_resolve_expr (e) != SUCCESS)
614 /* See if the expression node should really be a variable
617 sym = e->symtree->n.sym;
619 if (sym->attr.flavor == FL_PROCEDURE
620 || sym->attr.intrinsic
621 || sym->attr.external)
624 /* If the symbol is the function that names the current (or
625 parent) scope, then we really have a variable reference. */
627 if (sym->attr.function && sym->result == sym
628 && (sym->ns->proc_name == sym
629 || (sym->ns->parent != NULL
630 && sym->ns->parent->proc_name == sym)))
636 /* See if the name is a module procedure in a parent unit. */
638 if (was_declared (sym) || sym->ns->parent == NULL)
641 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
643 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
647 if (parent_st == NULL)
650 sym = parent_st->n.sym;
651 e->symtree = parent_st; /* Point to the right thing. */
653 if (sym->attr.flavor == FL_PROCEDURE
654 || sym->attr.intrinsic
655 || sym->attr.external)
661 e->expr_type = EXPR_VARIABLE;
665 e->rank = sym->as->rank;
666 e->ref = gfc_get_ref ();
667 e->ref->type = REF_ARRAY;
668 e->ref->u.ar.type = AR_FULL;
669 e->ref->u.ar.as = sym->as;
677 /************* Function resolution *************/
679 /* Resolve a function call known to be generic.
680 Section 14.1.2.4.1. */
683 resolve_generic_f0 (gfc_expr * expr, gfc_symbol * sym)
687 if (sym->attr.generic)
690 gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
693 expr->value.function.name = s->name;
694 expr->value.function.esym = s;
697 expr->rank = s->as->rank;
701 /* TODO: Need to search for elemental references in generic interface */
704 if (sym->attr.intrinsic)
705 return gfc_intrinsic_func_interface (expr, 0);
712 resolve_generic_f (gfc_expr * expr)
717 sym = expr->symtree->n.sym;
721 m = resolve_generic_f0 (expr, sym);
724 else if (m == MATCH_ERROR)
728 if (sym->ns->parent == NULL)
730 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
734 if (!generic_sym (sym))
738 /* Last ditch attempt. */
740 if (!gfc_generic_intrinsic (expr->symtree->n.sym->name))
742 gfc_error ("Generic function '%s' at %L is not an intrinsic function",
743 expr->symtree->n.sym->name, &expr->where);
747 m = gfc_intrinsic_func_interface (expr, 0);
752 ("Generic function '%s' at %L is not consistent with a specific "
753 "intrinsic interface", expr->symtree->n.sym->name, &expr->where);
759 /* Resolve a function call known to be specific. */
762 resolve_specific_f0 (gfc_symbol * sym, gfc_expr * expr)
766 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
770 sym->attr.proc = PROC_DUMMY;
774 sym->attr.proc = PROC_EXTERNAL;
778 if (sym->attr.proc == PROC_MODULE
779 || sym->attr.proc == PROC_ST_FUNCTION
780 || sym->attr.proc == PROC_INTERNAL)
783 if (sym->attr.intrinsic)
785 m = gfc_intrinsic_func_interface (expr, 1);
790 ("Function '%s' at %L is INTRINSIC but is not compatible with "
791 "an intrinsic", sym->name, &expr->where);
799 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
802 expr->value.function.name = sym->name;
803 expr->value.function.esym = sym;
805 expr->rank = sym->as->rank;
812 resolve_specific_f (gfc_expr * expr)
817 sym = expr->symtree->n.sym;
821 m = resolve_specific_f0 (sym, expr);
824 if (m == MATCH_ERROR)
827 if (sym->ns->parent == NULL)
830 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
836 gfc_error ("Unable to resolve the specific function '%s' at %L",
837 expr->symtree->n.sym->name, &expr->where);
843 /* Resolve a procedure call not known to be generic nor specific. */
846 resolve_unknown_f (gfc_expr * expr)
851 sym = expr->symtree->n.sym;
855 sym->attr.proc = PROC_DUMMY;
856 expr->value.function.name = sym->name;
860 /* See if we have an intrinsic function reference. */
862 if (gfc_intrinsic_name (sym->name, 0))
864 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
869 /* The reference is to an external name. */
871 sym->attr.proc = PROC_EXTERNAL;
872 expr->value.function.name = sym->name;
873 expr->value.function.esym = expr->symtree->n.sym;
876 expr->rank = sym->as->rank;
878 /* Type of the expression is either the type of the symbol or the
879 default type of the symbol. */
882 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
884 if (sym->ts.type != BT_UNKNOWN)
888 ts = gfc_get_default_type (sym, sym->ns);
890 if (ts->type == BT_UNKNOWN)
892 gfc_error ("Function '%s' at %L has no implicit type",
893 sym->name, &expr->where);
904 /* Figure out if if a function reference is pure or not. Also sets the name
905 of the function for a potential error message. Returns nonzero if the
906 function is PURE, zero if not. */
909 pure_function (gfc_expr * e, char **name)
913 if (e->value.function.esym)
915 pure = gfc_pure (e->value.function.esym);
916 *name = e->value.function.esym->name;
918 else if (e->value.function.isym)
920 pure = e->value.function.isym->pure
921 || e->value.function.isym->elemental;
922 *name = e->value.function.isym->name;
926 /* Implicit functions are not pure. */
928 *name = e->value.function.name;
935 /* Resolve a function call, which means resolving the arguments, then figuring
936 out which entity the name refers to. */
937 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
938 to INTENT(OUT) or INTENT(INOUT). */
941 resolve_function (gfc_expr * expr)
943 gfc_actual_arglist *arg;
947 if (resolve_actual_arglist (expr->value.function.actual) == FAILURE)
950 /* See if function is already resolved. */
952 if (expr->value.function.name != NULL)
954 if (expr->ts.type == BT_UNKNOWN)
955 expr->ts = expr->symtree->n.sym->ts;
960 /* Apply the rules of section 14.1.2. */
962 switch (procedure_kind (expr->symtree->n.sym))
965 t = resolve_generic_f (expr);
969 t = resolve_specific_f (expr);
973 t = resolve_unknown_f (expr);
977 gfc_internal_error ("resolve_function(): bad function type");
981 /* If the expression is still a function (it might have simplified),
982 then we check to see if we are calling an elemental function. */
984 if (expr->expr_type != EXPR_FUNCTION)
987 if (expr->value.function.actual != NULL
988 && ((expr->value.function.esym != NULL
989 && expr->value.function.esym->attr.elemental)
990 || (expr->value.function.isym != NULL
991 && expr->value.function.isym->elemental)))
994 /* The rank of an elemental is the rank of its array argument(s). */
996 for (arg = expr->value.function.actual; arg; arg = arg->next)
998 if (arg->expr != NULL && arg->expr->rank > 0)
1000 expr->rank = arg->expr->rank;
1006 if (!pure_function (expr, &name))
1011 ("Function reference to '%s' at %L is inside a FORALL block",
1012 name, &expr->where);
1015 else if (gfc_pure (NULL))
1017 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
1018 "procedure within a PURE procedure", name, &expr->where);
1027 /************* Subroutine resolution *************/
1030 pure_subroutine (gfc_code * c, gfc_symbol * sym)
1037 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
1038 sym->name, &c->loc);
1039 else if (gfc_pure (NULL))
1040 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
1046 resolve_generic_s0 (gfc_code * c, gfc_symbol * sym)
1050 if (sym->attr.generic)
1052 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
1055 c->resolved_sym = s;
1056 pure_subroutine (c, s);
1060 /* TODO: Need to search for elemental references in generic interface. */
1063 if (sym->attr.intrinsic)
1064 return gfc_intrinsic_sub_interface (c, 0);
1071 resolve_generic_s (gfc_code * c)
1076 sym = c->symtree->n.sym;
1078 m = resolve_generic_s0 (c, sym);
1081 if (m == MATCH_ERROR)
1084 if (sym->ns->parent != NULL)
1086 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1089 m = resolve_generic_s0 (c, sym);
1092 if (m == MATCH_ERROR)
1097 /* Last ditch attempt. */
1099 if (!gfc_generic_intrinsic (sym->name))
1102 ("Generic subroutine '%s' at %L is not an intrinsic subroutine",
1103 sym->name, &c->loc);
1107 m = gfc_intrinsic_sub_interface (c, 0);
1111 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
1112 "intrinsic subroutine interface", sym->name, &c->loc);
1118 /* Resolve a subroutine call known to be specific. */
1121 resolve_specific_s0 (gfc_code * c, gfc_symbol * sym)
1125 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1127 if (sym->attr.dummy)
1129 sym->attr.proc = PROC_DUMMY;
1133 sym->attr.proc = PROC_EXTERNAL;
1137 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
1140 if (sym->attr.intrinsic)
1142 m = gfc_intrinsic_sub_interface (c, 1);
1146 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
1147 "with an intrinsic", sym->name, &c->loc);
1155 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
1157 c->resolved_sym = sym;
1158 pure_subroutine (c, sym);
1165 resolve_specific_s (gfc_code * c)
1170 sym = c->symtree->n.sym;
1172 m = resolve_specific_s0 (c, sym);
1175 if (m == MATCH_ERROR)
1178 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1182 m = resolve_specific_s0 (c, sym);
1185 if (m == MATCH_ERROR)
1189 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
1190 sym->name, &c->loc);
1196 /* Resolve a subroutine call not known to be generic nor specific. */
1199 resolve_unknown_s (gfc_code * c)
1203 sym = c->symtree->n.sym;
1205 if (sym->attr.dummy)
1207 sym->attr.proc = PROC_DUMMY;
1211 /* See if we have an intrinsic function reference. */
1213 if (gfc_intrinsic_name (sym->name, 1))
1215 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
1220 /* The reference is to an external name. */
1223 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
1225 c->resolved_sym = sym;
1227 pure_subroutine (c, sym);
1233 /* Resolve a subroutine call. Although it was tempting to use the same code
1234 for functions, subroutines and functions are stored differently and this
1235 makes things awkward. */
1238 resolve_call (gfc_code * c)
1242 if (resolve_actual_arglist (c->ext.actual) == FAILURE)
1245 if (c->resolved_sym != NULL)
1248 switch (procedure_kind (c->symtree->n.sym))
1251 t = resolve_generic_s (c);
1254 case PTYPE_SPECIFIC:
1255 t = resolve_specific_s (c);
1259 t = resolve_unknown_s (c);
1263 gfc_internal_error ("resolve_subroutine(): bad function type");
1270 /* Resolve an operator expression node. This can involve replacing the
1271 operation with a user defined function call. */
1274 resolve_operator (gfc_expr * e)
1276 gfc_expr *op1, *op2;
1280 /* Resolve all subnodes-- give them types. */
1282 switch (e->operator)
1285 if (gfc_resolve_expr (e->op2) == FAILURE)
1288 /* Fall through... */
1291 case INTRINSIC_UPLUS:
1292 case INTRINSIC_UMINUS:
1293 if (gfc_resolve_expr (e->op1) == FAILURE)
1298 /* Typecheck the new node. */
1303 switch (e->operator)
1305 case INTRINSIC_UPLUS:
1306 case INTRINSIC_UMINUS:
1307 if (op1->ts.type == BT_INTEGER
1308 || op1->ts.type == BT_REAL
1309 || op1->ts.type == BT_COMPLEX)
1315 sprintf (msg, "Operand of unary numeric operator '%s' at %%L is %s",
1316 gfc_op2string (e->operator), gfc_typename (&e->ts));
1319 case INTRINSIC_PLUS:
1320 case INTRINSIC_MINUS:
1321 case INTRINSIC_TIMES:
1322 case INTRINSIC_DIVIDE:
1323 case INTRINSIC_POWER:
1324 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
1326 gfc_type_convert_binary (e);
1331 "Operands of binary numeric operator '%s' at %%L are %s/%s",
1332 gfc_op2string (e->operator), gfc_typename (&op1->ts),
1333 gfc_typename (&op2->ts));
1336 case INTRINSIC_CONCAT:
1337 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1339 e->ts.type = BT_CHARACTER;
1340 e->ts.kind = op1->ts.kind;
1345 "Operands of string concatenation operator at %%L are %s/%s",
1346 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
1352 case INTRINSIC_NEQV:
1353 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
1355 e->ts.type = BT_LOGICAL;
1356 e->ts.kind = gfc_kind_max (op1, op2);
1357 if (op1->ts.kind < e->ts.kind)
1358 gfc_convert_type (op1, &e->ts, 2);
1359 else if (op2->ts.kind < e->ts.kind)
1360 gfc_convert_type (op2, &e->ts, 2);
1364 sprintf (msg, "Operands of logical operator '%s' at %%L are %s/%s",
1365 gfc_op2string (e->operator), gfc_typename (&op1->ts),
1366 gfc_typename (&op2->ts));
1371 if (op1->ts.type == BT_LOGICAL)
1373 e->ts.type = BT_LOGICAL;
1374 e->ts.kind = op1->ts.kind;
1378 sprintf (msg, "Operand of .NOT. operator at %%L is %s",
1379 gfc_typename (&op1->ts));
1386 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
1388 strcpy (msg, "COMPLEX quantities cannot be compared at %L");
1392 /* Fall through... */
1396 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1398 e->ts.type = BT_LOGICAL;
1399 e->ts.kind = gfc_default_logical_kind ();
1403 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
1405 gfc_type_convert_binary (e);
1407 e->ts.type = BT_LOGICAL;
1408 e->ts.kind = gfc_default_logical_kind ();
1412 sprintf (msg, "Operands of comparison operator '%s' at %%L are %s/%s",
1413 gfc_op2string (e->operator), gfc_typename (&op1->ts),
1414 gfc_typename (&op2->ts));
1418 case INTRINSIC_USER:
1420 sprintf (msg, "Operand of user operator '%s' at %%L is %s",
1421 e->uop->ns->proc_name->name, gfc_typename (&op1->ts));
1423 sprintf (msg, "Operands of user operator '%s' at %%L are %s/%s",
1424 e->uop->ns->proc_name->name, gfc_typename (&op1->ts),
1425 gfc_typename (&op2->ts));
1430 gfc_internal_error ("resolve_operator(): Bad intrinsic");
1433 /* Deal with arrayness of an operand through an operator. */
1437 switch (e->operator)
1439 case INTRINSIC_PLUS:
1440 case INTRINSIC_MINUS:
1441 case INTRINSIC_TIMES:
1442 case INTRINSIC_DIVIDE:
1443 case INTRINSIC_POWER:
1444 case INTRINSIC_CONCAT:
1448 case INTRINSIC_NEQV:
1456 if (op1->rank == 0 && op2->rank == 0)
1459 if (op1->rank == 0 && op2->rank != 0)
1461 e->rank = op2->rank;
1463 if (e->shape == NULL)
1464 e->shape = gfc_copy_shape (op2->shape, op2->rank);
1467 if (op1->rank != 0 && op2->rank == 0)
1469 e->rank = op1->rank;
1471 if (e->shape == NULL)
1472 e->shape = gfc_copy_shape (op1->shape, op1->rank);
1475 if (op1->rank != 0 && op2->rank != 0)
1477 if (op1->rank == op2->rank)
1479 e->rank = op1->rank;
1481 if (e->shape == NULL)
1482 e->shape = gfc_copy_shape (op1->shape, op1->rank);
1487 gfc_error ("Inconsistent ranks for operator at %L and %L",
1488 &op1->where, &op2->where);
1491 /* Allow higher level expressions to work. */
1499 case INTRINSIC_UPLUS:
1500 case INTRINSIC_UMINUS:
1501 e->rank = op1->rank;
1503 if (e->shape == NULL)
1504 e->shape = gfc_copy_shape (op1->shape, op1->rank);
1506 /* Simply copy arrayness attribute */
1513 /* Attempt to simplify the expression. */
1515 t = gfc_simplify_expr (e, 0);
1519 if (gfc_extend_expr (e) == SUCCESS)
1522 gfc_error (msg, &e->where);
1527 /************** Array resolution subroutines **************/
1531 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
1534 /* Compare two integer expressions. */
1537 compare_bound (gfc_expr * a, gfc_expr * b)
1541 if (a == NULL || a->expr_type != EXPR_CONSTANT
1542 || b == NULL || b->expr_type != EXPR_CONSTANT)
1545 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
1546 gfc_internal_error ("compare_bound(): Bad expression");
1548 i = mpz_cmp (a->value.integer, b->value.integer);
1558 /* Compare an integer expression with an integer. */
1561 compare_bound_int (gfc_expr * a, int b)
1565 if (a == NULL || a->expr_type != EXPR_CONSTANT)
1568 if (a->ts.type != BT_INTEGER)
1569 gfc_internal_error ("compare_bound_int(): Bad expression");
1571 i = mpz_cmp_si (a->value.integer, b);
1581 /* Compare a single dimension of an array reference to the array
1585 check_dimension (int i, gfc_array_ref * ar, gfc_array_spec * as)
1588 /* Given start, end and stride values, calculate the minimum and
1589 maximum referenced indexes. */
1597 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
1599 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
1605 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
1607 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
1611 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
1613 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
1616 /* TODO: Possibly, we could warn about end[i] being out-of-bound although
1617 it is legal (see 6.2.2.3.1). */
1622 gfc_internal_error ("check_dimension(): Bad array reference");
1628 gfc_warning ("Array reference at %L is out of bounds", &ar->c_where[i]);
1633 /* Compare an array reference with an array specification. */
1636 compare_spec_to_ref (gfc_array_ref * ar)
1643 /* TODO: Full array sections are only allowed as actual parameters. */
1644 if (as->type == AS_ASSUMED_SIZE
1645 && (/*ar->type == AR_FULL
1646 ||*/ (ar->type == AR_SECTION
1647 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
1649 gfc_error ("Rightmost upper bound of assumed size array section"
1650 " not specified at %L", &ar->where);
1654 if (ar->type == AR_FULL)
1657 if (as->rank != ar->dimen)
1659 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
1660 &ar->where, ar->dimen, as->rank);
1664 for (i = 0; i < as->rank; i++)
1665 if (check_dimension (i, ar, as) == FAILURE)
1672 /* Resolve one part of an array index. */
1675 gfc_resolve_index (gfc_expr * index, int check_scalar)
1682 if (gfc_resolve_expr (index) == FAILURE)
1685 if (index->ts.type != BT_INTEGER)
1687 gfc_error ("Array index at %L must be of INTEGER type", &index->where);
1691 if (check_scalar && index->rank != 0)
1693 gfc_error ("Array index at %L must be scalar", &index->where);
1697 if (index->ts.kind != gfc_index_integer_kind)
1699 ts.type = BT_INTEGER;
1700 ts.kind = gfc_index_integer_kind;
1702 gfc_convert_type_warn (index, &ts, 2, 0);
1709 /* Given an expression that contains array references, update those array
1710 references to point to the right array specifications. While this is
1711 filled in during matching, this information is difficult to save and load
1712 in a module, so we take care of it here.
1714 The idea here is that the original array reference comes from the
1715 base symbol. We traverse the list of reference structures, setting
1716 the stored reference to references. Component references can
1717 provide an additional array specification. */
1720 find_array_spec (gfc_expr * e)
1726 as = e->symtree->n.sym->as;
1727 c = e->symtree->n.sym->components;
1729 for (ref = e->ref; ref; ref = ref->next)
1734 gfc_internal_error ("find_array_spec(): Missing spec");
1741 for (; c; c = c->next)
1742 if (c == ref->u.c.component)
1746 gfc_internal_error ("find_array_spec(): Component not found");
1751 gfc_internal_error ("find_array_spec(): unused as(1)");
1755 c = c->ts.derived->components;
1763 gfc_internal_error ("find_array_spec(): unused as(2)");
1767 /* Resolve an array reference. */
1770 resolve_array_ref (gfc_array_ref * ar)
1772 int i, check_scalar;
1774 for (i = 0; i < ar->dimen; i++)
1776 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
1778 if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
1780 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
1782 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
1785 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
1786 switch (ar->start[i]->rank)
1789 ar->dimen_type[i] = DIMEN_ELEMENT;
1793 ar->dimen_type[i] = DIMEN_VECTOR;
1797 gfc_error ("Array index at %L is an array of rank %d",
1798 &ar->c_where[i], ar->start[i]->rank);
1803 /* If the reference type is unknown, figure out what kind it is. */
1805 if (ar->type == AR_UNKNOWN)
1807 ar->type = AR_ELEMENT;
1808 for (i = 0; i < ar->dimen; i++)
1809 if (ar->dimen_type[i] == DIMEN_RANGE
1810 || ar->dimen_type[i] == DIMEN_VECTOR)
1812 ar->type = AR_SECTION;
1817 if (compare_spec_to_ref (ar) == FAILURE)
1825 resolve_substring (gfc_ref * ref)
1828 if (ref->u.ss.start != NULL)
1830 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
1833 if (ref->u.ss.start->ts.type != BT_INTEGER)
1835 gfc_error ("Substring start index at %L must be of type INTEGER",
1836 &ref->u.ss.start->where);
1840 if (ref->u.ss.start->rank != 0)
1842 gfc_error ("Substring start index at %L must be scalar",
1843 &ref->u.ss.start->where);
1847 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT)
1849 gfc_error ("Substring start index at %L is less than one",
1850 &ref->u.ss.start->where);
1855 if (ref->u.ss.end != NULL)
1857 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
1860 if (ref->u.ss.end->ts.type != BT_INTEGER)
1862 gfc_error ("Substring end index at %L must be of type INTEGER",
1863 &ref->u.ss.end->where);
1867 if (ref->u.ss.end->rank != 0)
1869 gfc_error ("Substring end index at %L must be scalar",
1870 &ref->u.ss.end->where);
1874 if (ref->u.ss.length != NULL
1875 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT)
1877 gfc_error ("Substring end index at %L is out of bounds",
1878 &ref->u.ss.start->where);
1887 /* Resolve subtype references. */
1890 resolve_ref (gfc_expr * expr)
1892 int current_part_dimension, n_components, seen_part_dimension;
1895 for (ref = expr->ref; ref; ref = ref->next)
1896 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
1898 find_array_spec (expr);
1902 for (ref = expr->ref; ref; ref = ref->next)
1906 if (resolve_array_ref (&ref->u.ar) == FAILURE)
1914 resolve_substring (ref);
1918 /* Check constraints on part references. */
1920 current_part_dimension = 0;
1921 seen_part_dimension = 0;
1924 for (ref = expr->ref; ref; ref = ref->next)
1929 switch (ref->u.ar.type)
1933 current_part_dimension = 1;
1937 current_part_dimension = 0;
1941 gfc_internal_error ("resolve_ref(): Bad array reference");
1947 if ((current_part_dimension || seen_part_dimension)
1948 && ref->u.c.component->pointer)
1951 ("Component to the right of a part reference with nonzero "
1952 "rank must not have the POINTER attribute at %L",
1964 if (((ref->type == REF_COMPONENT && n_components > 1)
1965 || ref->next == NULL)
1966 && current_part_dimension
1967 && seen_part_dimension)
1970 gfc_error ("Two or more part references with nonzero rank must "
1971 "not be specified at %L", &expr->where);
1975 if (ref->type == REF_COMPONENT)
1977 if (current_part_dimension)
1978 seen_part_dimension = 1;
1980 /* reset to make sure */
1981 current_part_dimension = 0;
1989 /* Given an expression, determine its shape. This is easier than it sounds.
1990 Leaves the shape array NULL if it is not possible to determine the shape. */
1993 expression_shape (gfc_expr * e)
1995 mpz_t array[GFC_MAX_DIMENSIONS];
1998 if (e->rank == 0 || e->shape != NULL)
2001 for (i = 0; i < e->rank; i++)
2002 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
2005 e->shape = gfc_get_shape (e->rank);
2007 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
2012 for (i--; i >= 0; i--)
2013 mpz_clear (array[i]);
2017 /* Given a variable expression node, compute the rank of the expression by
2018 examining the base symbol and any reference structures it may have. */
2021 expression_rank (gfc_expr * e)
2028 if (e->expr_type == EXPR_ARRAY)
2030 /* Constructors can have a rank different from one via RESHAPE(). */
2032 if (e->symtree == NULL)
2038 e->rank = (e->symtree->n.sym->as == NULL)
2039 ? 0 : e->symtree->n.sym->as->rank;
2045 for (ref = e->ref; ref; ref = ref->next)
2047 if (ref->type != REF_ARRAY)
2050 if (ref->u.ar.type == AR_FULL)
2052 rank = ref->u.ar.as->rank;
2056 if (ref->u.ar.type == AR_SECTION)
2058 /* Figure out the rank of the section. */
2060 gfc_internal_error ("expression_rank(): Two array specs");
2062 for (i = 0; i < ref->u.ar.dimen; i++)
2063 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
2064 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
2074 expression_shape (e);
2078 /* Resolve a variable expression. */
2081 resolve_variable (gfc_expr * e)
2085 if (e->ref && resolve_ref (e) == FAILURE)
2088 sym = e->symtree->n.sym;
2089 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
2091 e->ts.type = BT_PROCEDURE;
2095 if (sym->ts.type != BT_UNKNOWN)
2096 gfc_variable_attr (e, &e->ts);
2099 /* Must be a simple variable reference. */
2100 if (gfc_set_default_type (sym, 1, NULL) == FAILURE)
2109 /* Resolve an expression. That is, make sure that types of operands agree
2110 with their operators, intrinsic operators are converted to function calls
2111 for overloaded types and unresolved function references are resolved. */
2114 gfc_resolve_expr (gfc_expr * e)
2121 switch (e->expr_type)
2124 t = resolve_operator (e);
2128 t = resolve_function (e);
2132 t = resolve_variable (e);
2134 expression_rank (e);
2137 case EXPR_SUBSTRING:
2138 t = resolve_ref (e);
2148 if (resolve_ref (e) == FAILURE)
2151 t = gfc_resolve_array_constructor (e);
2152 /* Also try to expand a constructor. */
2155 expression_rank (e);
2156 gfc_expand_constructor (e);
2161 case EXPR_STRUCTURE:
2162 t = resolve_ref (e);
2166 t = resolve_structure_cons (e);
2170 t = gfc_simplify_expr (e, 0);
2174 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
2181 /* Resolve the expressions in an iterator structure and require that they all
2182 be of integer type. */
2185 gfc_resolve_iterator (gfc_iterator * iter)
2188 if (gfc_resolve_expr (iter->var) == FAILURE)
2191 if (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0)
2193 gfc_error ("Loop variable at %L must be a scalar INTEGER",
2198 if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
2200 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
2205 if (gfc_resolve_expr (iter->start) == FAILURE)
2208 if (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0)
2210 gfc_error ("Start expression in DO loop at %L must be a scalar INTEGER",
2211 &iter->start->where);
2215 if (gfc_resolve_expr (iter->end) == FAILURE)
2218 if (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0)
2220 gfc_error ("End expression in DO loop at %L must be a scalar INTEGER",
2225 if (gfc_resolve_expr (iter->step) == FAILURE)
2228 if (iter->step->ts.type != BT_INTEGER || iter->step->rank != 0)
2230 gfc_error ("Step expression in DO loop at %L must be a scalar INTEGER",
2231 &iter->step->where);
2235 if (iter->step->expr_type == EXPR_CONSTANT
2236 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
2238 gfc_error ("Step expression in DO loop at %L cannot be zero",
2239 &iter->step->where);
2247 /* Resolve a list of FORALL iterators. */
2250 resolve_forall_iterators (gfc_forall_iterator * iter)
2255 if (gfc_resolve_expr (iter->var) == SUCCESS
2256 && iter->var->ts.type != BT_INTEGER)
2257 gfc_error ("FORALL Iteration variable at %L must be INTEGER",
2260 if (gfc_resolve_expr (iter->start) == SUCCESS
2261 && iter->start->ts.type != BT_INTEGER)
2262 gfc_error ("FORALL start expression at %L must be INTEGER",
2263 &iter->start->where);
2264 if (iter->var->ts.kind != iter->start->ts.kind)
2265 gfc_convert_type (iter->start, &iter->var->ts, 2);
2267 if (gfc_resolve_expr (iter->end) == SUCCESS
2268 && iter->end->ts.type != BT_INTEGER)
2269 gfc_error ("FORALL end expression at %L must be INTEGER",
2271 if (iter->var->ts.kind != iter->end->ts.kind)
2272 gfc_convert_type (iter->end, &iter->var->ts, 2);
2274 if (gfc_resolve_expr (iter->stride) == SUCCESS
2275 && iter->stride->ts.type != BT_INTEGER)
2276 gfc_error ("FORALL Stride expression at %L must be INTEGER",
2277 &iter->stride->where);
2278 if (iter->var->ts.kind != iter->stride->ts.kind)
2279 gfc_convert_type (iter->stride, &iter->var->ts, 2);
2286 /* Given a pointer to a symbol that is a derived type, see if any components
2287 have the POINTER attribute. The search is recursive if necessary.
2288 Returns zero if no pointer components are found, nonzero otherwise. */
2291 derived_pointer (gfc_symbol * sym)
2295 for (c = sym->components; c; c = c->next)
2300 if (c->ts.type == BT_DERIVED && derived_pointer (c->ts.derived))
2308 /* Resolve the argument of a deallocate expression. The expression must be
2309 a pointer or a full array. */
2312 resolve_deallocate_expr (gfc_expr * e)
2314 symbol_attribute attr;
2318 if (gfc_resolve_expr (e) == FAILURE)
2321 attr = gfc_expr_attr (e);
2325 if (e->expr_type != EXPR_VARIABLE)
2328 allocatable = e->symtree->n.sym->attr.allocatable;
2329 for (ref = e->ref; ref; ref = ref->next)
2333 if (ref->u.ar.type != AR_FULL)
2338 allocatable = (ref->u.c.component->as != NULL
2339 && ref->u.c.component->as->type == AS_DEFERRED);
2347 if (allocatable == 0)
2350 gfc_error ("Expression in DEALLOCATE statement at %L must be "
2351 "ALLOCATABLE or a POINTER", &e->where);
2358 /* Resolve the expression in an ALLOCATE statement, doing the additional
2359 checks to see whether the expression is OK or not. The expression must
2360 have a trailing array reference that gives the size of the array. */
2363 resolve_allocate_expr (gfc_expr * e)
2365 int i, pointer, allocatable, dimension;
2366 symbol_attribute attr;
2367 gfc_ref *ref, *ref2;
2370 if (gfc_resolve_expr (e) == FAILURE)
2373 /* Make sure the expression is allocatable or a pointer. If it is
2374 pointer, the next-to-last reference must be a pointer. */
2378 if (e->expr_type != EXPR_VARIABLE)
2382 attr = gfc_expr_attr (e);
2383 pointer = attr.pointer;
2384 dimension = attr.dimension;
2389 allocatable = e->symtree->n.sym->attr.allocatable;
2390 pointer = e->symtree->n.sym->attr.pointer;
2391 dimension = e->symtree->n.sym->attr.dimension;
2393 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
2397 if (ref->next != NULL)
2402 allocatable = (ref->u.c.component->as != NULL
2403 && ref->u.c.component->as->type == AS_DEFERRED);
2405 pointer = ref->u.c.component->pointer;
2406 dimension = ref->u.c.component->dimension;
2416 if (allocatable == 0 && pointer == 0)
2418 gfc_error ("Expression in ALLOCATE statement at %L must be "
2419 "ALLOCATABLE or a POINTER", &e->where);
2423 if (pointer && dimension == 0)
2426 /* Make sure the next-to-last reference node is an array specification. */
2428 if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
2430 gfc_error ("Array specification required in ALLOCATE statement "
2431 "at %L", &e->where);
2435 if (ref2->u.ar.type == AR_ELEMENT)
2438 /* Make sure that the array section reference makes sense in the
2439 context of an ALLOCATE specification. */
2443 for (i = 0; i < ar->dimen; i++)
2444 switch (ar->dimen_type[i])
2450 if (ar->start[i] != NULL
2451 && ar->end[i] != NULL
2452 && ar->stride[i] == NULL)
2455 /* Fall Through... */
2459 gfc_error ("Bad array specification in ALLOCATE statement at %L",
2468 /************ SELECT CASE resolution subroutines ************/
2470 /* Callback function for our mergesort variant. Determines interval
2471 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
2472 op1 > op2. Assumes we're not dealing with the default case. */
2475 compare_cases (const void * _op1, const void * _op2)
2477 const gfc_case *op1, *op2;
2479 op1 = (const gfc_case *) _op1;
2480 op2 = (const gfc_case *) _op2;
2482 if (op1->low == NULL) /* op1 = (:N) */
2484 if (op2->low == NULL) /* op2 = (:M), so overlap. */
2487 else if (op2->high == NULL) /* op2 = (M:) */
2489 if (gfc_compare_expr (op1->high, op2->low) < 0)
2490 return -1; /* N < M */
2495 else /* op2 = (L:M) */
2497 if (gfc_compare_expr (op1->high, op2->low) < 0)
2498 return -1; /* N < L */
2504 else if (op1->high == NULL) /* op1 = (N:) */
2506 if (op2->low == NULL) /* op2 = (:M) */
2508 if (gfc_compare_expr (op1->low, op2->high) > 0)
2509 return 1; /* N > M */
2514 else if (op2->high == NULL) /* op2 = (M:), so overlap. */
2517 else /* op2 = (L:M) */
2519 if (gfc_compare_expr (op1->low, op2->high) > 0)
2520 return 1; /* N > M */
2526 else /* op1 = (N:P) */
2528 if (op2->low == NULL) /* op2 = (:M) */
2530 if (gfc_compare_expr (op1->low, op2->high) > 0)
2531 return 1; /* N > M */
2536 else if (op2->high == NULL) /* op2 = (M:) */
2538 if (gfc_compare_expr (op1->high, op2->low) < 0)
2539 return -1; /* P < M */
2544 else /* op2 = (L:M) */
2546 if (gfc_compare_expr (op1->high, op2->low) < 0)
2547 return -1; /* P < L */
2549 if (gfc_compare_expr (op1->low, op2->high) > 0)
2550 return 1; /* N > M */
2558 /* Merge-sort a double linked case list, detecting overlap in the
2559 process. LIST is the head of the double linked case list before it
2560 is sorted. Returns the head of the sorted list if we don't see any
2561 overlap, or NULL otherwise. */
2564 check_case_overlap (gfc_case * list)
2566 gfc_case *p, *q, *e, *tail;
2567 int insize, nmerges, psize, qsize, cmp, overlap_seen;
2569 /* If the passed list was empty, return immediately. */
2576 /* Loop unconditionally. The only exit from this loop is a return
2577 statement, when we've finished sorting the case list. */
2584 /* Count the number of merges we do in this pass. */
2587 /* Loop while there exists a merge to be done. */
2592 /* Count this merge. */
2595 /* Cut the list in two pieces by steppin INSIZE places
2596 forward in the list, starting from P. */
2599 for (i = 0; i < insize; i++)
2608 /* Now we have two lists. Merge them! */
2609 while (psize > 0 || (qsize > 0 && q != NULL))
2612 /* See from which the next case to merge comes from. */
2615 /* P is empty so the next case must come from Q. */
2620 else if (qsize == 0 || q == NULL)
2629 cmp = compare_cases (p, q);
2632 /* The whole case range for P is less than the
2640 /* The whole case range for Q is greater than
2641 the case range for P. */
2648 /* The cases overlap, or they are the same
2649 element in the list. Either way, we must
2650 issue an error and get the next case from P. */
2651 /* FIXME: Sort P and Q by line number. */
2652 gfc_error ("CASE label at %L overlaps with CASE "
2653 "label at %L", &p->where, &q->where);
2661 /* Add the next element to the merged list. */
2670 /* P has now stepped INSIZE places along, and so has Q. So
2671 they're the same. */
2676 /* If we have done only one merge or none at all, we've
2677 finished sorting the cases. */
2686 /* Otherwise repeat, merging lists twice the size. */
2692 /* Check to see if an expression is suitable for use in a CASE
2693 statement. Makes sure that all case expressions are scalar
2694 constants of the same type/kind. Return FAILURE if anything
2698 validate_case_label_expr (gfc_expr * e, gfc_expr * case_expr)
2700 gfc_typespec case_ts = case_expr->ts;
2702 if (e == NULL) return SUCCESS;
2704 if (e->ts.type != case_ts.type)
2706 gfc_error ("Expression in CASE statement at %L must be of type %s",
2707 &e->where, gfc_basic_typename (case_ts.type));
2711 if (e->ts.kind != case_ts.kind)
2713 gfc_error("Expression in CASE statement at %L must be kind %d",
2714 &e->where, case_ts.kind);
2720 gfc_error ("Expression in CASE statement at %L must be scalar",
2729 /* Given a completely parsed select statement, we:
2731 - Validate all expressions and code within the SELECT.
2732 - Make sure that the selection expression is not of the wrong type.
2733 - Make sure that no case ranges overlap.
2734 - Eliminate unreachable cases and unreachable code resulting from
2735 removing case labels.
2737 The standard does allow unreachable cases, e.g. CASE (5:3). But
2738 they are a hassle for code generation, and to prevent that, we just
2739 cut them out here. This is not necessary for overlapping cases
2740 because they are illegal and we never even try to generate code.
2742 We have the additional caveat that a SELECT construct could have
2743 been a computed GOTO in the source code. Furtunately we can fairly
2744 easily work around that here: The case_expr for a "real" SELECT CASE
2745 is in code->expr1, but for a computed GOTO it is in code->expr2. All
2746 we have to do is make sure that the case_expr is a scalar integer
2750 resolve_select (gfc_code * code)
2753 gfc_expr *case_expr;
2754 gfc_case *cp, *default_case, *tail, *head;
2755 int seen_unreachable;
2760 if (code->expr == NULL)
2762 /* This was actually a computed GOTO statement. */
2763 case_expr = code->expr2;
2764 if (case_expr->ts.type != BT_INTEGER
2765 || case_expr->rank != 0)
2766 gfc_error ("Selection expression in computed GOTO statement "
2767 "at %L must be a scalar integer expression",
2770 /* Further checking is not necessary because this SELECT was built
2771 by the compiler, so it should always be OK. Just move the
2772 case_expr from expr2 to expr so that we can handle computed
2773 GOTOs as normal SELECTs from here on. */
2774 code->expr = code->expr2;
2779 case_expr = code->expr;
2781 type = case_expr->ts.type;
2782 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
2784 gfc_error ("Argument of SELECT statement at %L cannot be %s",
2785 &case_expr->where, gfc_typename (&case_expr->ts));
2787 /* Punt. Going on here just produce more garbage error messages. */
2791 if (case_expr->rank != 0)
2793 gfc_error ("Argument of SELECT statement at %L must be a scalar "
2794 "expression", &case_expr->where);
2800 /* Assume there is no DEFAULT case. */
2801 default_case = NULL;
2805 for (body = code->block; body; body = body->block)
2807 /* Assume the CASE list is OK, and all CASE labels can be matched. */
2809 seen_unreachable = 0;
2811 /* Walk the case label list, making sure that all case labels
2813 for (cp = body->ext.case_list; cp; cp = cp->next)
2815 /* Count the number of cases in the whole construct. */
2818 /* Intercept the DEFAULT case. */
2819 if (cp->low == NULL && cp->high == NULL)
2821 if (default_case != NULL)
2823 gfc_error ("The DEFAULT CASE at %L cannot be followed "
2824 "by a second DEFAULT CASE at %L",
2825 &default_case->where, &cp->where);
2836 /* Deal with single value cases and case ranges. Errors are
2837 issued from the validation function. */
2838 if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
2839 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
2845 if (type == BT_LOGICAL
2846 && ((cp->low == NULL || cp->high == NULL)
2847 || cp->low != cp->high))
2850 ("Logical range in CASE statement at %L is not allowed",
2856 if (cp->low != NULL && cp->high != NULL
2857 && cp->low != cp->high
2858 && gfc_compare_expr (cp->low, cp->high) > 0)
2860 if (gfc_option.warn_surprising)
2861 gfc_warning ("Range specification at %L can never "
2862 "be matched", &cp->where);
2864 cp->unreachable = 1;
2865 seen_unreachable = 1;
2869 /* If the case range can be matched, it can also overlap with
2870 other cases. To make sure it does not, we put it in a
2871 double linked list here. We sort that with a merge sort
2872 later on to detect any overlapping cases. */
2876 head->right = head->left = NULL;
2881 tail->right->left = tail;
2888 /* It there was a failure in the previous case label, give up
2889 for this case label list. Continue with the next block. */
2893 /* See if any case labels that are unreachable have been seen.
2894 If so, we eliminate them. This is a bit of a kludge because
2895 the case lists for a single case statement (label) is a
2896 single forward linked lists. */
2897 if (seen_unreachable)
2899 /* Advance until the first case in the list is reachable. */
2900 while (body->ext.case_list != NULL
2901 && body->ext.case_list->unreachable)
2903 gfc_case *n = body->ext.case_list;
2904 body->ext.case_list = body->ext.case_list->next;
2906 gfc_free_case_list (n);
2909 /* Strip all other unreachable cases. */
2910 if (body->ext.case_list)
2912 for (cp = body->ext.case_list; cp->next; cp = cp->next)
2914 if (cp->next->unreachable)
2916 gfc_case *n = cp->next;
2917 cp->next = cp->next->next;
2919 gfc_free_case_list (n);
2926 /* See if there were overlapping cases. If the check returns NULL,
2927 there was overlap. In that case we don't do anything. If head
2928 is non-NULL, we prepend the DEFAULT case. The sorted list can
2929 then used during code generation for SELECT CASE constructs with
2930 a case expression of a CHARACTER type. */
2933 head = check_case_overlap (head);
2935 /* Prepend the default_case if it is there. */
2936 if (head != NULL && default_case)
2938 default_case->left = NULL;
2939 default_case->right = head;
2940 head->left = default_case;
2944 /* Eliminate dead blocks that may be the result if we've seen
2945 unreachable case labels for a block. */
2946 for (body = code; body && body->block; body = body->block)
2948 if (body->block->ext.case_list == NULL)
2950 /* Cut the unreachable block from the code chain. */
2951 gfc_code *c = body->block;
2952 body->block = c->block;
2954 /* Kill the dead block, but not the blocks below it. */
2956 gfc_free_statements (c);
2960 /* More than two cases is legal but insane for logical selects.
2961 Issue a warning for it. */
2962 if (gfc_option.warn_surprising && type == BT_LOGICAL
2964 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
2969 /*********** Toplevel code resolution subroutines ***********/
2971 /* Given a branch to a label and a namespace, if the branch is conforming.
2972 The code node described where the branch is located. */
2975 resolve_branch (gfc_st_label * label, gfc_code * code)
2977 gfc_code *block, *found;
2985 /* Step one: is this a valid branching target? */
2987 if (lp->defined == ST_LABEL_UNKNOWN)
2989 gfc_error ("Label %d referenced at %L is never defined", lp->value,
2994 if (lp->defined != ST_LABEL_TARGET)
2996 gfc_error ("Statement at %L is not a valid branch target statement "
2997 "for the branch statement at %L", &lp->where, &code->loc);
3001 /* Step two: make sure this branch is not a branch to itself ;-) */
3003 if (code->here == label)
3005 gfc_warning ("Branch at %L causes an infinite loop", &code->loc);
3009 /* Step three: Try to find the label in the parse tree. To do this,
3010 we traverse the tree block-by-block: first the block that
3011 contains this GOTO, then the block that it is nested in, etc. We
3012 can ignore other blocks because branching into another block is
3017 for (stack = cs_base; stack; stack = stack->prev)
3019 for (block = stack->head; block; block = block->next)
3021 if (block->here == label)
3034 /* still nothing, so illegal. */
3035 gfc_error_now ("Label at %L is not in the same block as the "
3036 "GOTO statement at %L", &lp->where, &code->loc);
3040 /* Step four: Make sure that the branching target is legal if
3041 the statement is an END {SELECT,DO,IF}. */
3043 if (found->op == EXEC_NOP)
3045 for (stack = cs_base; stack; stack = stack->prev)
3046 if (stack->current->next == found)
3050 gfc_notify_std (GFC_STD_F95_DEL,
3051 "Obsolete: GOTO at %L jumps to END of construct at %L",
3052 &code->loc, &found->loc);
3057 /* Check whether EXPR1 has the same shape as EXPR2. */
3060 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
3062 mpz_t shape[GFC_MAX_DIMENSIONS];
3063 mpz_t shape2[GFC_MAX_DIMENSIONS];
3064 try result = FAILURE;
3067 /* Compare the rank. */
3068 if (expr1->rank != expr2->rank)
3071 /* Compare the size of each dimension. */
3072 for (i=0; i<expr1->rank; i++)
3074 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
3077 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
3080 if (mpz_cmp (shape[i], shape2[i]))
3084 /* When either of the two expression is an assumed size array, we
3085 ignore the comparison of dimension sizes. */
3090 for (i--; i>=0; i--)
3092 mpz_clear (shape[i]);
3093 mpz_clear (shape2[i]);
3099 /* Check whether a WHERE assignment target or a WHERE mask expression
3100 has the same shape as the outmost WHERE mask expression. */
3103 resolve_where (gfc_code *code, gfc_expr *mask)
3109 cblock = code->block;
3111 /* Store the first WHERE mask-expr of the WHERE statement or construct.
3112 In case of nested WHERE, only the outmost one is stored. */
3113 if (mask == NULL) /* outmost WHERE */
3115 else /* inner WHERE */
3122 /* Check if the mask-expr has a consistent shape with the
3123 outmost WHERE mask-expr. */
3124 if (resolve_where_shape (cblock->expr, e) == FAILURE)
3125 gfc_error ("WHERE mask at %L has inconsistent shape",
3126 &cblock->expr->where);
3129 /* the assignment statement of a WHERE statement, or the first
3130 statement in where-body-construct of a WHERE construct */
3131 cnext = cblock->next;
3136 /* WHERE assignment statement */
3139 /* Check shape consistent for WHERE assignment target. */
3140 if (e && resolve_where_shape (cnext->expr, e) == FAILURE)
3141 gfc_error ("WHERE assignment target at %L has "
3142 "inconsistent shape", &cnext->expr->where);
3145 /* WHERE or WHERE construct is part of a where-body-construct */
3147 resolve_where (cnext, e);
3151 gfc_error ("Unsupported statement inside WHERE at %L",
3154 /* the next statement within the same where-body-construct */
3155 cnext = cnext->next;
3157 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
3158 cblock = cblock->block;
3163 /* Check whether the FORALL index appears in the expression or not. */
3166 gfc_find_forall_index (gfc_expr *expr, gfc_symbol *symbol)
3170 gfc_actual_arglist *args;
3173 switch (expr->expr_type)
3176 assert (expr->symtree->n.sym);
3178 /* A scalar assignment */
3181 if (expr->symtree->n.sym == symbol)
3187 /* the expr is array ref, substring or struct component. */
3194 /* Check if the symbol appears in the array subscript. */
3196 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
3199 if (gfc_find_forall_index (ar.start[i], symbol) == SUCCESS)
3203 if (gfc_find_forall_index (ar.end[i], symbol) == SUCCESS)
3207 if (gfc_find_forall_index (ar.stride[i], symbol) == SUCCESS)
3213 if (expr->symtree->n.sym == symbol)
3216 /* Check if the symbol appears in the substring section. */
3217 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
3219 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
3227 gfc_error("expresion reference type error at %L", &expr->where);
3233 /* If the expression is a function call, then check if the symbol
3234 appears in the actual arglist of the function. */
3236 for (args = expr->value.function.actual; args; args = args->next)
3238 if (gfc_find_forall_index(args->expr,symbol) == SUCCESS)
3243 /* It seems not to happen. */
3244 case EXPR_SUBSTRING:
3248 assert(expr->ref->type == REF_SUBSTRING);
3249 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
3251 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
3256 /* It seems not to happen. */
3257 case EXPR_STRUCTURE:
3259 gfc_error ("Unsupported statement while finding forall index in "
3266 /* Find the FORALL index in the first operand. */
3269 if (gfc_find_forall_index (expr->op1, symbol) == SUCCESS)
3273 /* Find the FORALL index in the second operand. */
3276 if (gfc_find_forall_index (expr->op2, symbol) == SUCCESS)
3283 /* Resolve assignment in FORALL construct.
3284 NVAR is the number of FORALL index variables, and VAR_EXPR records the
3285 FORALL index variables. */
3288 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
3292 for (n = 0; n < nvar; n++)
3294 gfc_symbol *forall_index;
3296 forall_index = var_expr[n]->symtree->n.sym;
3298 /* Check whether the assignment target is one of the FORALL index
3300 if ((code->expr->expr_type == EXPR_VARIABLE)
3301 && (code->expr->symtree->n.sym == forall_index))
3302 gfc_error ("Assignment to a FORALL index variable at %L",
3303 &code->expr->where);
3306 /* If one of the FORALL index variables doesn't appear in the
3307 assignment target, then there will be a many-to-one
3309 if (gfc_find_forall_index (code->expr, forall_index) == FAILURE)
3310 gfc_error ("The FORALL with index '%s' cause more than one "
3311 "assignment to this object at %L",
3312 var_expr[n]->symtree->name, &code->expr->where);
3318 /* Resolve WHERE statement in FORALL construct. */
3321 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr){
3325 cblock = code->block;
3328 /* the assignment statement of a WHERE statement, or the first
3329 statement in where-body-construct of a WHERE construct */
3330 cnext = cblock->next;
3335 /* WHERE assignment statement */
3337 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
3340 /* WHERE or WHERE construct is part of a where-body-construct */
3342 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
3346 gfc_error ("Unsupported statement inside WHERE at %L",
3349 /* the next statement within the same where-body-construct */
3350 cnext = cnext->next;
3352 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
3353 cblock = cblock->block;
3358 /* Traverse the FORALL body to check whether the following errors exist:
3359 1. For assignment, check if a many-to-one assignment happens.
3360 2. For WHERE statement, check the WHERE body to see if there is any
3361 many-to-one assignment. */
3364 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
3368 c = code->block->next;
3374 case EXEC_POINTER_ASSIGN:
3375 gfc_resolve_assign_in_forall (c, nvar, var_expr);
3378 /* Because the resolve_blocks() will handle the nested FORALL,
3379 there is no need to handle it here. */
3383 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
3388 /* The next statement in the FORALL body. */
3394 /* Given a FORALL construct, first resolve the FORALL iterator, then call
3395 gfc_resolve_forall_body to resolve the FORALL body. */
3397 static void resolve_blocks (gfc_code *, gfc_namespace *);
3400 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
3402 static gfc_expr **var_expr;
3403 static int total_var = 0;
3404 static int nvar = 0;
3405 gfc_forall_iterator *fa;
3406 gfc_symbol *forall_index;
3410 /* Start to resolve a FORALL construct */
3411 if (forall_save == 0)
3413 /* Count the total number of FORALL index in the nested FORALL
3414 construct in order to allocate the VAR_EXPR with proper size. */
3416 while ((next != NULL) && (next->op == EXEC_FORALL))
3418 for (fa = next->ext.forall_iterator; fa; fa = fa->next)
3420 next = next->block->next;
3423 /* allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
3424 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
3427 /* The information about FORALL iterator, including FORALL index start, end
3428 and stride. The FORALL index can not appear in start, end or stride. */
3429 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
3431 /* Check if any outer FORALL index name is the same as the current
3433 for (i = 0; i < nvar; i++)
3435 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
3437 gfc_error ("An outer FORALL construct already has an index "
3438 "with this name %L", &fa->var->where);
3442 /* Record the current FORALL index. */
3443 var_expr[nvar] = gfc_copy_expr (fa->var);
3445 forall_index = fa->var->symtree->n.sym;
3447 /* Check if the FORALL index appears in start, end or stride. */
3448 if (gfc_find_forall_index (fa->start, forall_index) == SUCCESS)
3449 gfc_error ("A FORALL index must not appear in a limit or stride "
3450 "expression in the same FORALL at %L", &fa->start->where);
3451 if (gfc_find_forall_index (fa->end, forall_index) == SUCCESS)
3452 gfc_error ("A FORALL index must not appear in a limit or stride "
3453 "expression in the same FORALL at %L", &fa->end->where);
3454 if (gfc_find_forall_index (fa->stride, forall_index) == SUCCESS)
3455 gfc_error ("A FORALL index must not appear in a limit or stride "
3456 "expression in the same FORALL at %L", &fa->stride->where);
3460 /* Resolve the FORALL body. */
3461 gfc_resolve_forall_body (code, nvar, var_expr);
3463 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
3464 resolve_blocks (code->block, ns);
3466 /* Free VAR_EXPR after the whole FORALL construct resolved. */
3467 for (i = 0; i < total_var; i++)
3468 gfc_free_expr (var_expr[i]);
3470 /* Reset the counters. */
3476 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
3479 static void resolve_code (gfc_code *, gfc_namespace *);
3482 resolve_blocks (gfc_code * b, gfc_namespace * ns)
3486 for (; b; b = b->block)
3488 t = gfc_resolve_expr (b->expr);
3489 if (gfc_resolve_expr (b->expr2) == FAILURE)
3495 if (t == SUCCESS && b->expr != NULL
3496 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank != 0))
3498 ("ELSE IF clause at %L requires a scalar LOGICAL expression",
3505 && (b->expr->ts.type != BT_LOGICAL
3506 || b->expr->rank == 0))
3508 ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
3513 resolve_branch (b->label, b);
3523 gfc_internal_error ("resolve_block(): Bad block type");
3526 resolve_code (b->next, ns);
3531 /* Given a block of code, recursively resolve everything pointed to by this
3535 resolve_code (gfc_code * code, gfc_namespace * ns)
3537 int forall_save = 0;
3542 frame.prev = cs_base;
3546 for (; code; code = code->next)
3548 frame.current = code;
3550 if (code->op == EXEC_FORALL)
3552 forall_save = forall_flag;
3554 gfc_resolve_forall (code, ns, forall_save);
3557 resolve_blocks (code->block, ns);
3559 if (code->op == EXEC_FORALL)
3560 forall_flag = forall_save;
3562 t = gfc_resolve_expr (code->expr);
3563 if (gfc_resolve_expr (code->expr2) == FAILURE)
3580 resolve_where (code, NULL);
3584 if (code->expr != NULL && code->expr->ts.type != BT_INTEGER)
3585 gfc_error ("ASSIGNED GOTO statement at %L requires an INTEGER "
3586 "variable", &code->expr->where);
3588 resolve_branch (code->label, code);
3592 if (code->expr != NULL && code->expr->ts.type != BT_INTEGER)
3593 gfc_error ("Alternate RETURN statement at %L requires an INTEGER "
3594 "return specifier", &code->expr->where);
3601 if (gfc_extend_assign (code, ns) == SUCCESS)
3604 if (gfc_pure (NULL))
3606 if (gfc_impure_variable (code->expr->symtree->n.sym))
3609 ("Cannot assign to variable '%s' in PURE procedure at %L",
3610 code->expr->symtree->n.sym->name, &code->expr->where);
3614 if (code->expr2->ts.type == BT_DERIVED
3615 && derived_pointer (code->expr2->ts.derived))
3618 ("Right side of assignment at %L is a derived type "
3619 "containing a POINTER in a PURE procedure",
3620 &code->expr2->where);
3625 gfc_check_assign (code->expr, code->expr2, 1);
3628 case EXEC_LABEL_ASSIGN:
3629 if (code->label->defined == ST_LABEL_UNKNOWN)
3630 gfc_error ("Label %d referenced at %L is never defined",
3631 code->label->value, &code->label->where);
3632 if (t == SUCCESS && code->expr->ts.type != BT_INTEGER)
3633 gfc_error ("ASSIGN statement at %L requires an INTEGER "
3634 "variable", &code->expr->where);
3637 case EXEC_POINTER_ASSIGN:
3641 gfc_check_pointer_assign (code->expr, code->expr2);
3644 case EXEC_ARITHMETIC_IF:
3646 && code->expr->ts.type != BT_INTEGER
3647 && code->expr->ts.type != BT_REAL)
3648 gfc_error ("Arithmetic IF statement at %L requires a numeric "
3649 "expression", &code->expr->where);
3651 resolve_branch (code->label, code);
3652 resolve_branch (code->label2, code);
3653 resolve_branch (code->label3, code);
3657 if (t == SUCCESS && code->expr != NULL
3658 && (code->expr->ts.type != BT_LOGICAL
3659 || code->expr->rank != 0))
3660 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
3661 &code->expr->where);
3666 resolve_call (code);
3670 /* Select is complicated. Also, a SELECT construct could be
3671 a transformed computed GOTO. */
3672 resolve_select (code);
3676 if (code->ext.iterator != NULL)
3677 gfc_resolve_iterator (code->ext.iterator);
3681 if (code->expr == NULL)
3682 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
3684 && (code->expr->rank != 0
3685 || code->expr->ts.type != BT_LOGICAL))
3686 gfc_error ("Exit condition of DO WHILE loop at %L must be "
3687 "a scalar LOGICAL expression", &code->expr->where);
3691 if (t == SUCCESS && code->expr != NULL
3692 && code->expr->ts.type != BT_INTEGER)
3693 gfc_error ("STAT tag in ALLOCATE statement at %L must be "
3694 "of type INTEGER", &code->expr->where);
3696 for (a = code->ext.alloc_list; a; a = a->next)
3697 resolve_allocate_expr (a->expr);
3701 case EXEC_DEALLOCATE:
3702 if (t == SUCCESS && code->expr != NULL
3703 && code->expr->ts.type != BT_INTEGER)
3705 ("STAT tag in DEALLOCATE statement at %L must be of type "
3706 "INTEGER", &code->expr->where);
3708 for (a = code->ext.alloc_list; a; a = a->next)
3709 resolve_deallocate_expr (a->expr);
3714 if (gfc_resolve_open (code->ext.open) == FAILURE)
3717 resolve_branch (code->ext.open->err, code);
3721 if (gfc_resolve_close (code->ext.close) == FAILURE)
3724 resolve_branch (code->ext.close->err, code);
3727 case EXEC_BACKSPACE:
3730 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
3733 resolve_branch (code->ext.filepos->err, code);
3737 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
3740 resolve_branch (code->ext.inquire->err, code);
3744 assert(code->ext.inquire != NULL);
3745 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
3748 resolve_branch (code->ext.inquire->err, code);
3753 if (gfc_resolve_dt (code->ext.dt) == FAILURE)
3756 resolve_branch (code->ext.dt->err, code);
3757 resolve_branch (code->ext.dt->end, code);
3758 resolve_branch (code->ext.dt->eor, code);
3762 resolve_forall_iterators (code->ext.forall_iterator);
3764 if (code->expr != NULL && code->expr->ts.type != BT_LOGICAL)
3766 ("FORALL mask clause at %L requires a LOGICAL expression",
3767 &code->expr->where);
3771 gfc_internal_error ("resolve_code(): Bad statement code");
3775 cs_base = frame.prev;
3779 /* Resolve initial values and make sure they are compatible with
3783 resolve_values (gfc_symbol * sym)
3786 if (sym->value == NULL)
3789 if (gfc_resolve_expr (sym->value) == FAILURE)
3792 gfc_check_assign_symbol (sym, sym->value);
3796 /* Do anything necessary to resolve a symbol. Right now, we just
3797 assume that an otherwise unknown symbol is a variable. This sort
3798 of thing commonly happens for symbols in module. */
3801 resolve_symbol (gfc_symbol * sym)
3803 /* Zero if we are checking a formal namespace. */
3804 static int formal_ns_flag = 1;
3805 int formal_ns_save, check_constant, mp_flag;
3810 if (sym->attr.flavor == FL_UNKNOWN)
3812 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
3813 sym->attr.flavor = FL_VARIABLE;
3816 sym->attr.flavor = FL_PROCEDURE;
3817 if (sym->attr.dimension)
3818 sym->attr.function = 1;
3822 /* Symbols that are module procedures with results (functions) have
3823 the types and array specification copied for type checking in
3824 procedures that call them, as well as for saving to a module
3825 file. These symbols can't stand the scrutiny that their results
3827 mp_flag = (sym->result != NULL && sym->result != sym);
3829 /* Assign default type to symbols that need one and don't have one. */
3830 if (sym->ts.type == BT_UNKNOWN)
3832 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
3833 gfc_set_default_type (sym, 1, NULL);
3835 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
3838 gfc_set_default_type (sym, 0, NULL);
3841 /* Result may be in another namespace. */
3842 resolve_symbol (sym->result);
3844 sym->ts = sym->result->ts;
3845 sym->as = gfc_copy_array_spec (sym->result->as);
3850 /* Assumed size arrays and assumed shape arrays must be dummy
3854 && (sym->as->type == AS_ASSUMED_SIZE
3855 || sym->as->type == AS_ASSUMED_SHAPE)
3856 && sym->attr.dummy == 0)
3858 gfc_error ("Assumed %s array at %L must be a dummy argument",
3859 sym->as->type == AS_ASSUMED_SIZE ? "size" : "shape",
3864 /* A parameter array's shape needs to be constant. */
3866 if (sym->attr.flavor == FL_PARAMETER && sym->as != NULL
3867 && !gfc_is_compile_time_shape (sym->as))
3869 gfc_error ("Parameter array '%s' at %L cannot be automatic "
3870 "or assumed shape", sym->name, &sym->declared_at);
3874 /* Make sure that character string variables with assumed length are
3877 if (sym->attr.flavor == FL_VARIABLE && !sym->attr.result
3878 && sym->ts.type == BT_CHARACTER
3879 && sym->ts.cl->length == NULL && sym->attr.dummy == 0)
3881 gfc_error ("Entity with assumed character length at %L must be a "
3882 "dummy argument or a PARAMETER", &sym->declared_at);
3886 /* Make sure a parameter that has been implicitly typed still
3887 matches the implicit type, since PARAMETER statements can precede
3888 IMPLICIT statements. */
3890 if (sym->attr.flavor == FL_PARAMETER
3891 && sym->attr.implicit_type
3892 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym, sym->ns)))
3893 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
3894 "later IMPLICIT type", sym->name, &sym->declared_at);
3896 /* Make sure the types of derived parameters are consistent. This
3897 type checking is deferred until resolution because the type may
3898 refer to a derived type from the host. */
3900 if (sym->attr.flavor == FL_PARAMETER
3901 && sym->ts.type == BT_DERIVED
3902 && !gfc_compare_types (&sym->ts, &sym->value->ts))
3903 gfc_error ("Incompatible derived type in PARAMETER at %L",
3904 &sym->value->where);
3906 /* Make sure symbols with known intent or optional are really dummy
3907 variable. Because of ENTRY statement, this has to be deferred
3908 until resolution time. */
3910 if (! sym->attr.dummy
3911 && (sym->attr.optional
3912 || sym->attr.intent != INTENT_UNKNOWN))
3914 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
3918 if (sym->attr.proc == PROC_ST_FUNCTION)
3920 if (sym->ts.type == BT_CHARACTER)
3922 gfc_charlen *cl = sym->ts.cl;
3923 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
3925 gfc_error ("Character-valued statement function '%s' at %L must "
3926 "have constant length", sym->name, &sym->declared_at);
3932 /* Constraints on deferred shape variable. */
3933 if (sym->attr.flavor == FL_VARIABLE
3934 || (sym->attr.flavor == FL_PROCEDURE
3935 && sym->attr.function))
3937 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
3939 if (sym->attr.allocatable)
3941 if (sym->attr.dimension)
3942 gfc_error ("Allocatable array at %L must have a deferred shape",
3945 gfc_error ("Object at %L may not be ALLOCATABLE",
3950 if (sym->attr.pointer && sym->attr.dimension)
3952 gfc_error ("Pointer to array at %L must have a deferred shape",
3960 if (!mp_flag && !sym->attr.allocatable
3961 && !sym->attr.pointer && !sym->attr.dummy)
3963 gfc_error ("Array at %L cannot have a deferred shape",
3970 if (sym->attr.flavor == FL_VARIABLE)
3972 /* Can the sybol have an initializer? */
3974 if (sym->attr.allocatable)
3975 whynot = "Allocatable";
3976 else if (sym->attr.external)
3977 whynot = "External";
3978 else if (sym->attr.dummy)
3980 else if (sym->attr.intrinsic)
3981 whynot = "Intrinsic";
3982 else if (sym->attr.result)
3983 whynot = "Function Result";
3984 else if (sym->attr.dimension && !sym->attr.pointer)
3986 /* Don't allow initialization of automatic arrays. */
3987 for (i = 0; i < sym->as->rank; i++)
3989 if (sym->as->lower[i] == NULL
3990 || sym->as->lower[i]->expr_type != EXPR_CONSTANT
3991 || sym->as->upper[i] == NULL
3992 || sym->as->upper[i]->expr_type != EXPR_CONSTANT)
3994 whynot = "Automatic array";
4000 /* Reject illegal initializers. */
4001 if (sym->value && whynot)
4003 gfc_error ("%s '%s' at %L cannot have an initializer",
4004 whynot, sym->name, &sym->declared_at);
4008 /* Assign default initializer. */
4009 if (sym->ts.type == BT_DERIVED && !(sym->value || whynot))
4010 sym->value = gfc_default_initializer (&sym->ts);
4014 /* Make sure that intrinsic exist */
4015 if (sym->attr.intrinsic
4016 && ! gfc_intrinsic_name(sym->name, 0)
4017 && ! gfc_intrinsic_name(sym->name, 1))
4018 gfc_error("Intrinsic at %L does not exist", &sym->declared_at);
4020 /* Resolve array specifier. Check as well some constraints
4021 on COMMON blocks. */
4023 check_constant = sym->attr.in_common && !sym->attr.pointer;
4024 gfc_resolve_array_spec (sym->as, check_constant);
4026 /* Resolve formal namespaces. */
4028 if (formal_ns_flag && sym != NULL && sym->formal_ns != NULL)
4030 formal_ns_save = formal_ns_flag;
4032 gfc_resolve (sym->formal_ns);
4033 formal_ns_flag = formal_ns_save;
4039 /************* Resolve DATA statements *************/
4043 gfc_data_value *vnode;
4049 /* Advance the values structure to point to the next value in the data list. */
4052 next_data_value (void)
4054 while (values.left == 0)
4056 if (values.vnode->next == NULL)
4059 values.vnode = values.vnode->next;
4060 values.left = values.vnode->repeat;
4068 check_data_variable (gfc_data_variable * var, locus * where)
4074 ar_type mark = AR_UNKNOWN;
4076 mpz_t section_index[GFC_MAX_DIMENSIONS];
4080 if (gfc_resolve_expr (var->expr) == FAILURE)
4084 mpz_init_set_si (offset, 0);
4087 if (e->expr_type != EXPR_VARIABLE)
4088 gfc_internal_error ("check_data_variable(): Bad expression");
4092 mpz_init_set_ui (size, 1);
4099 /* Find the array section reference. */
4100 for (ref = e->ref; ref; ref = ref->next)
4102 if (ref->type != REF_ARRAY)
4104 if (ref->u.ar.type == AR_ELEMENT)
4110 /* Set marks asscording to the reference pattern. */
4111 switch (ref->u.ar.type)
4119 /* Get the start position of array section. */
4120 gfc_get_section_index (ar, section_index, &offset);
4128 if (gfc_array_size (e, &size) == FAILURE)
4130 gfc_error ("Nonconstant array section at %L in DATA statement",
4139 while (mpz_cmp_ui (size, 0) > 0)
4141 if (next_data_value () == FAILURE)
4143 gfc_error ("DATA statement at %L has more variables than values",
4149 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
4153 /* If we have more than one element left in the repeat count,
4154 and we have more than one element left in the target variable,
4155 then create a range assignment. */
4156 /* ??? Only done for full arrays for now, since array sections
4158 if (mark == AR_FULL && ref && ref->next == NULL
4159 && values.left > 1 && mpz_cmp_ui (size, 1) > 0)
4163 if (mpz_cmp_ui (size, values.left) >= 0)
4165 mpz_init_set_ui (range, values.left);
4166 mpz_sub_ui (size, size, values.left);
4171 mpz_init_set (range, size);
4172 values.left -= mpz_get_ui (size);
4173 mpz_set_ui (size, 0);
4176 gfc_assign_data_value_range (var->expr, values.vnode->expr,
4179 mpz_add (offset, offset, range);
4183 /* Assign initial value to symbol. */
4187 mpz_sub_ui (size, size, 1);
4189 gfc_assign_data_value (var->expr, values.vnode->expr, offset);
4191 if (mark == AR_FULL)
4192 mpz_add_ui (offset, offset, 1);
4194 /* Modify the array section indexes and recalculate the offset
4195 for next element. */
4196 else if (mark == AR_SECTION)
4197 gfc_advance_section (section_index, ar, &offset);
4201 if (mark == AR_SECTION)
4203 for (i = 0; i < ar->dimen; i++)
4204 mpz_clear (section_index[i]);
4214 static try traverse_data_var (gfc_data_variable *, locus *);
4216 /* Iterate over a list of elements in a DATA statement. */
4219 traverse_data_list (gfc_data_variable * var, locus * where)
4222 iterator_stack frame;
4225 mpz_init (frame.value);
4227 mpz_init_set (trip, var->iter.end->value.integer);
4228 mpz_sub (trip, trip, var->iter.start->value.integer);
4229 mpz_add (trip, trip, var->iter.step->value.integer);
4231 mpz_div (trip, trip, var->iter.step->value.integer);
4233 mpz_set (frame.value, var->iter.start->value.integer);
4235 frame.prev = iter_stack;
4236 frame.variable = var->iter.var->symtree;
4237 iter_stack = &frame;
4239 while (mpz_cmp_ui (trip, 0) > 0)
4241 if (traverse_data_var (var->list, where) == FAILURE)
4247 e = gfc_copy_expr (var->expr);
4248 if (gfc_simplify_expr (e, 1) == FAILURE)
4254 mpz_add (frame.value, frame.value, var->iter.step->value.integer);
4256 mpz_sub_ui (trip, trip, 1);
4260 mpz_clear (frame.value);
4262 iter_stack = frame.prev;
4267 /* Type resolve variables in the variable list of a DATA statement. */
4270 traverse_data_var (gfc_data_variable * var, locus * where)
4274 for (; var; var = var->next)
4276 if (var->expr == NULL)
4277 t = traverse_data_list (var, where);
4279 t = check_data_variable (var, where);
4289 /* Resolve the expressions and iterators associated with a data statement.
4290 This is separate from the assignment checking because data lists should
4291 only be resolved once. */
4294 resolve_data_variables (gfc_data_variable * d)
4296 for (; d; d = d->next)
4298 if (d->list == NULL)
4300 if (gfc_resolve_expr (d->expr) == FAILURE)
4305 if (gfc_resolve_iterator (&d->iter) == FAILURE)
4308 if (d->iter.start->expr_type != EXPR_CONSTANT
4309 || d->iter.end->expr_type != EXPR_CONSTANT
4310 || d->iter.step->expr_type != EXPR_CONSTANT)
4311 gfc_internal_error ("resolve_data_variables(): Bad iterator");
4313 if (resolve_data_variables (d->list) == FAILURE)
4322 /* Resolve a single DATA statement. We implement this by storing a pointer to
4323 the value list into static variables, and then recursively traversing the
4324 variables list, expanding iterators and such. */
4327 resolve_data (gfc_data * d)
4329 if (resolve_data_variables (d->var) == FAILURE)
4332 values.vnode = d->value;
4333 values.left = (d->value == NULL) ? 0 : d->value->repeat;
4335 if (traverse_data_var (d->var, &d->where) == FAILURE)
4338 /* At this point, we better not have any values left. */
4340 if (next_data_value () == SUCCESS)
4341 gfc_error ("DATA statement at %L has more values than variables",
4346 /* Determines if a variable is not 'pure', ie not assignable within a pure
4347 procedure. Returns zero if assignment is OK, nonzero if there is a problem.
4351 gfc_impure_variable (gfc_symbol * sym)
4353 if (sym->attr.use_assoc || sym->attr.in_common)
4356 if (sym->ns != gfc_current_ns)
4357 return !sym->attr.function;
4359 /* TODO: Check storage association through EQUIVALENCE statements */
4365 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
4366 symbol of the current procedure. */
4369 gfc_pure (gfc_symbol * sym)
4371 symbol_attribute attr;
4374 sym = gfc_current_ns->proc_name;
4380 return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental);
4384 /* Test whether the current procedure is elemental or not. */
4387 gfc_elemental (gfc_symbol * sym)
4389 symbol_attribute attr;
4392 sym = gfc_current_ns->proc_name;
4397 return attr.flavor == FL_PROCEDURE && attr.elemental;
4401 /* Warn about unused labels. */
4404 warn_unused_label (gfc_namespace * ns)
4415 for (; l; l = l->prev)
4417 if (l->defined == ST_LABEL_UNKNOWN)
4420 switch (l->referenced)
4422 case ST_LABEL_UNKNOWN:
4423 gfc_warning ("Label %d at %L defined but not used", l->value,
4427 case ST_LABEL_BAD_TARGET:
4428 gfc_warning ("Label %d at %L defined but cannot be used", l->value,
4439 /* Resolve derived type EQUIVALENCE object. */
4442 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
4445 gfc_component *c = derived->components;
4450 /* Shall not be an object of nonsequence derived type. */
4451 if (!derived->attr.sequence)
4453 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
4454 "attribute to be an EQUIVALENCE object", sym->name, &e->where);
4458 for (; c ; c = c->next)
4461 if (d && (resolve_equivalence_derived (c->ts.derived, sym, e) == FAILURE))
4464 /* Shall not be an object of sequence derived type containing a pointer
4465 in the structure. */
4468 gfc_error ("Derived type variable '%s' at %L has pointer componet(s) "
4469 "cannot be an EQUIVALENCE object", sym->name, &e->where);
4477 /* Resolve equivalence object.
4478 An EQUIVALENCE object shall not be a dummy argument, a pointer, an
4479 allocatable array, an object of nonsequence derived type, an object of
4480 sequence derived type containing a pointer at any level of component
4481 selection, an automatic object, a function name, an entry name, a result
4482 name, a named constant, a structure component, or a subobject of any of
4483 the preceding objects. */
4486 resolve_equivalence (gfc_equiv *eq)
4489 gfc_symbol *derived;
4493 for (; eq; eq = eq->eq)
4496 if (gfc_resolve_expr (e) == FAILURE)
4499 sym = e->symtree->n.sym;
4501 /* Shall not be a dummy argument. */
4502 if (sym->attr.dummy)
4504 gfc_error ("Dummy argument '%s' at %L cannot be an EQUIVALENCE "
4505 "object", sym->name, &e->where);
4509 /* Shall not be an allocatable array. */
4510 if (sym->attr.allocatable)
4512 gfc_error ("Allocatable array '%s' at %L cannot be an EQUIVALENCE "
4513 "object", sym->name, &e->where);
4517 /* Shall not be a pointer. */
4518 if (sym->attr.pointer)
4520 gfc_error ("Pointer '%s' at %L cannot be an EQUIVALENCE object",
4521 sym->name, &e->where);
4525 /* Shall not be a function name, ... */
4526 if (sym->attr.function || sym->attr.result || sym->attr.entry
4527 || sym->attr.subroutine)
4529 gfc_error ("Entity '%s' at %L cannot be an EQUIVALENCE object",
4530 sym->name, &e->where);
4534 /* Shall not be a named constant. */
4535 if (e->expr_type == EXPR_CONSTANT)
4537 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
4538 "object", sym->name, &e->where);
4542 derived = e->ts.derived;
4543 if (derived && resolve_equivalence_derived (derived, sym, e) == FAILURE)
4549 /* Shall not be an automatic array. */
4550 if (e->ref->type == REF_ARRAY
4551 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
4553 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
4554 "an EQUIVALENCE object", sym->name, &e->where);
4558 /* Shall not be a structure component. */
4562 if (r->type == REF_COMPONENT)
4564 gfc_error ("Structure component '%s' at %L cannot be an "
4565 "EQUIVALENCE object",
4566 r->u.c.component->name, &e->where);
4575 /* This function is called after a complete program unit has been compiled.
4576 Its purpose is to examine all of the expressions associated with a program
4577 unit, assign types to all intermediate expressions, make sure that all
4578 assignments are to compatible types and figure out which names refer to
4579 which functions or subroutines. */
4582 gfc_resolve (gfc_namespace * ns)
4584 gfc_namespace *old_ns, *n;
4589 old_ns = gfc_current_ns;
4590 gfc_current_ns = ns;
4592 resolve_entries (ns);
4594 resolve_contained_functions (ns);
4596 gfc_traverse_ns (ns, resolve_symbol);
4598 for (n = ns->contained; n; n = n->sibling)
4600 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
4601 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
4602 "also be PURE", n->proc_name->name,
4603 &n->proc_name->declared_at);
4609 gfc_check_interfaces (ns);
4611 for (cl = ns->cl_list; cl; cl = cl->next)
4613 if (cl->length == NULL || gfc_resolve_expr (cl->length) == FAILURE)
4616 if (cl->length->ts.type != BT_INTEGER)
4618 ("Character length specification at %L must be of type INTEGER",
4619 &cl->length->where);
4622 gfc_traverse_ns (ns, resolve_values);
4628 for (d = ns->data; d; d = d->next)
4632 gfc_traverse_ns (ns, gfc_formalize_init_value);
4634 for (eq = ns->equiv; eq; eq = eq->next)
4635 resolve_equivalence (eq);
4638 resolve_code (ns->code, ns);
4640 /* Warn about unused labels. */
4641 if (gfc_option.warn_unused_labels)
4642 warn_unused_label (ns);
4644 gfc_current_ns = old_ns;