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 new_arglist->next = proc->formal;
316 proc->formal = new_arglist;
321 /* Resolve alternate entry points. If a symbol has multiple entry points we
322 create a new master symbol for the main routine, and turn the existing
323 symbol into an entry point. */
326 resolve_entries (gfc_namespace * ns)
328 gfc_namespace *old_ns;
332 char name[GFC_MAX_SYMBOL_LEN + 1];
333 static int master_count = 0;
335 if (ns->proc_name == NULL)
338 /* No need to do anything if this procedure doesn't have alternate entry
343 /* We may already have resolved alternate entry points. */
344 if (ns->proc_name->attr.entry_master)
347 /* If this isn't a procedure something has gone horribly wrong. */
348 assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
350 /* Remember the current namespace. */
351 old_ns = gfc_current_ns;
355 /* Add the main entry point to the list of entry points. */
356 el = gfc_get_entry_list ();
357 el->sym = ns->proc_name;
359 el->next = ns->entries;
361 ns->proc_name->attr.entry = 1;
363 /* Add an entry statement for it. */
370 /* Create a new symbol for the master function. */
371 /* Give the internal function a unique name (within this file).
372 Also include the function name so the user has some hope of figuring
373 out what is going on. */
374 snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
375 master_count++, ns->proc_name->name);
376 name[GFC_MAX_SYMBOL_LEN] = '\0';
377 gfc_get_ha_symbol (name, &proc);
378 assert (proc != NULL);
380 gfc_add_procedure (&proc->attr, PROC_INTERNAL, NULL);
381 if (ns->proc_name->attr.subroutine)
382 gfc_add_subroutine (&proc->attr, NULL);
385 gfc_add_function (&proc->attr, NULL);
386 gfc_internal_error ("TODO: Functions with alternate entry points");
388 proc->attr.access = ACCESS_PRIVATE;
389 proc->attr.entry_master = 1;
391 /* Merge all the entry point arguments. */
392 for (el = ns->entries; el; el = el->next)
393 merge_argument_lists (proc, el->sym->formal);
395 /* Use the master function for the function body. */
396 ns->proc_name = proc;
398 /* Finalize the new symbols. */
399 gfc_commit_symbols ();
401 /* Restore the original namespace. */
402 gfc_current_ns = old_ns;
406 /* Resolve contained function types. Because contained functions can call one
407 another, they have to be worked out before any of the contained procedures
410 The good news is that if a function doesn't already have a type, the only
411 way it can get one is through an IMPLICIT type or a RESULT variable, because
412 by definition contained functions are contained namespace they're contained
413 in, not in a sibling or parent namespace. */
416 resolve_contained_functions (gfc_namespace * ns)
418 gfc_namespace *child;
421 resolve_formal_arglists (ns);
423 for (child = ns->contained; child; child = child->sibling)
425 /* Resolve alternate entry points first. */
426 resolve_entries (child);
428 /* Then check function return types. */
429 resolve_contained_fntype (child->proc_name, child);
430 for (el = child->entries; el; el = el->next)
431 resolve_contained_fntype (el->sym, child);
436 /* Resolve all of the elements of a structure constructor and make sure that
437 the types are correct. */
440 resolve_structure_cons (gfc_expr * expr)
442 gfc_constructor *cons;
447 cons = expr->value.constructor;
448 /* A constructor may have references if it is the result of substituting a
449 parameter variable. In this case we just pull out the component we
452 comp = expr->ref->u.c.sym->components;
454 comp = expr->ts.derived->components;
456 for (; comp; comp = comp->next, cons = cons->next)
464 if (gfc_resolve_expr (cons->expr) == FAILURE)
470 /* If we don't have the right type, try to convert it. */
472 if (!gfc_compare_types (&cons->expr->ts, &comp->ts)
473 && gfc_convert_type (cons->expr, &comp->ts, 1) == FAILURE)
482 /****************** Expression name resolution ******************/
484 /* Returns 0 if a symbol was not declared with a type or
485 attribute declaration statement, nonzero otherwise. */
488 was_declared (gfc_symbol * sym)
494 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
497 if (a.allocatable || a.dimension || a.external || a.intrinsic
498 || a.optional || a.pointer || a.save || a.target
499 || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
506 /* Determine if a symbol is generic or not. */
509 generic_sym (gfc_symbol * sym)
513 if (sym->attr.generic ||
514 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
517 if (was_declared (sym) || sym->ns->parent == NULL)
520 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
522 return (s == NULL) ? 0 : generic_sym (s);
526 /* Determine if a symbol is specific or not. */
529 specific_sym (gfc_symbol * sym)
533 if (sym->attr.if_source == IFSRC_IFBODY
534 || sym->attr.proc == PROC_MODULE
535 || sym->attr.proc == PROC_INTERNAL
536 || sym->attr.proc == PROC_ST_FUNCTION
537 || (sym->attr.intrinsic &&
538 gfc_specific_intrinsic (sym->name))
539 || sym->attr.external)
542 if (was_declared (sym) || sym->ns->parent == NULL)
545 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
547 return (s == NULL) ? 0 : specific_sym (s);
551 /* Figure out if the procedure is specific, generic or unknown. */
554 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
558 procedure_kind (gfc_symbol * sym)
561 if (generic_sym (sym))
562 return PTYPE_GENERIC;
564 if (specific_sym (sym))
565 return PTYPE_SPECIFIC;
567 return PTYPE_UNKNOWN;
571 /* Resolve an actual argument list. Most of the time, this is just
572 resolving the expressions in the list.
573 The exception is that we sometimes have to decide whether arguments
574 that look like procedure arguments are really simple variable
578 resolve_actual_arglist (gfc_actual_arglist * arg)
581 gfc_symtree *parent_st;
584 for (; arg; arg = arg->next)
590 /* Check the label is a valid branching target. */
593 if (arg->label->defined == ST_LABEL_UNKNOWN)
595 gfc_error ("Label %d referenced at %L is never defined",
596 arg->label->value, &arg->label->where);
603 if (e->ts.type != BT_PROCEDURE)
605 if (gfc_resolve_expr (e) != SUCCESS)
610 /* See if the expression node should really be a variable
613 sym = e->symtree->n.sym;
615 if (sym->attr.flavor == FL_PROCEDURE
616 || sym->attr.intrinsic
617 || sym->attr.external)
620 /* If the symbol is the function that names the current (or
621 parent) scope, then we really have a variable reference. */
623 if (sym->attr.function && sym->result == sym
624 && (sym->ns->proc_name == sym
625 || (sym->ns->parent != NULL
626 && sym->ns->parent->proc_name == sym)))
632 /* See if the name is a module procedure in a parent unit. */
634 if (was_declared (sym) || sym->ns->parent == NULL)
637 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
639 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
643 if (parent_st == NULL)
646 sym = parent_st->n.sym;
647 e->symtree = parent_st; /* Point to the right thing. */
649 if (sym->attr.flavor == FL_PROCEDURE
650 || sym->attr.intrinsic
651 || sym->attr.external)
657 e->expr_type = EXPR_VARIABLE;
661 e->rank = sym->as->rank;
662 e->ref = gfc_get_ref ();
663 e->ref->type = REF_ARRAY;
664 e->ref->u.ar.type = AR_FULL;
665 e->ref->u.ar.as = sym->as;
673 /************* Function resolution *************/
675 /* Resolve a function call known to be generic.
676 Section 14.1.2.4.1. */
679 resolve_generic_f0 (gfc_expr * expr, gfc_symbol * sym)
683 if (sym->attr.generic)
686 gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
689 expr->value.function.name = s->name;
690 expr->value.function.esym = s;
693 expr->rank = s->as->rank;
697 /* TODO: Need to search for elemental references in generic interface */
700 if (sym->attr.intrinsic)
701 return gfc_intrinsic_func_interface (expr, 0);
708 resolve_generic_f (gfc_expr * expr)
713 sym = expr->symtree->n.sym;
717 m = resolve_generic_f0 (expr, sym);
720 else if (m == MATCH_ERROR)
724 if (sym->ns->parent == NULL)
726 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
730 if (!generic_sym (sym))
734 /* Last ditch attempt. */
736 if (!gfc_generic_intrinsic (expr->symtree->n.sym->name))
738 gfc_error ("Generic function '%s' at %L is not an intrinsic function",
739 expr->symtree->n.sym->name, &expr->where);
743 m = gfc_intrinsic_func_interface (expr, 0);
748 ("Generic function '%s' at %L is not consistent with a specific "
749 "intrinsic interface", expr->symtree->n.sym->name, &expr->where);
755 /* Resolve a function call known to be specific. */
758 resolve_specific_f0 (gfc_symbol * sym, gfc_expr * expr)
762 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
766 sym->attr.proc = PROC_DUMMY;
770 sym->attr.proc = PROC_EXTERNAL;
774 if (sym->attr.proc == PROC_MODULE
775 || sym->attr.proc == PROC_ST_FUNCTION
776 || sym->attr.proc == PROC_INTERNAL)
779 if (sym->attr.intrinsic)
781 m = gfc_intrinsic_func_interface (expr, 1);
786 ("Function '%s' at %L is INTRINSIC but is not compatible with "
787 "an intrinsic", sym->name, &expr->where);
795 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
798 expr->value.function.name = sym->name;
799 expr->value.function.esym = sym;
801 expr->rank = sym->as->rank;
808 resolve_specific_f (gfc_expr * expr)
813 sym = expr->symtree->n.sym;
817 m = resolve_specific_f0 (sym, expr);
820 if (m == MATCH_ERROR)
823 if (sym->ns->parent == NULL)
826 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
832 gfc_error ("Unable to resolve the specific function '%s' at %L",
833 expr->symtree->n.sym->name, &expr->where);
839 /* Resolve a procedure call not known to be generic nor specific. */
842 resolve_unknown_f (gfc_expr * expr)
847 sym = expr->symtree->n.sym;
851 sym->attr.proc = PROC_DUMMY;
852 expr->value.function.name = sym->name;
856 /* See if we have an intrinsic function reference. */
858 if (gfc_intrinsic_name (sym->name, 0))
860 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
865 /* The reference is to an external name. */
867 sym->attr.proc = PROC_EXTERNAL;
868 expr->value.function.name = sym->name;
869 expr->value.function.esym = expr->symtree->n.sym;
872 expr->rank = sym->as->rank;
874 /* Type of the expression is either the type of the symbol or the
875 default type of the symbol. */
878 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
880 if (sym->ts.type != BT_UNKNOWN)
884 ts = gfc_get_default_type (sym, sym->ns);
886 if (ts->type == BT_UNKNOWN)
888 gfc_error ("Function '%s' at %L has no implicit type",
889 sym->name, &expr->where);
900 /* Figure out if if a function reference is pure or not. Also sets the name
901 of the function for a potential error message. Returns nonzero if the
902 function is PURE, zero if not. */
905 pure_function (gfc_expr * e, char **name)
909 if (e->value.function.esym)
911 pure = gfc_pure (e->value.function.esym);
912 *name = e->value.function.esym->name;
914 else if (e->value.function.isym)
916 pure = e->value.function.isym->pure
917 || e->value.function.isym->elemental;
918 *name = e->value.function.isym->name;
922 /* Implicit functions are not pure. */
924 *name = e->value.function.name;
931 /* Resolve a function call, which means resolving the arguments, then figuring
932 out which entity the name refers to. */
933 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
934 to INTENT(OUT) or INTENT(INOUT). */
937 resolve_function (gfc_expr * expr)
939 gfc_actual_arglist *arg;
943 if (resolve_actual_arglist (expr->value.function.actual) == FAILURE)
946 /* See if function is already resolved. */
948 if (expr->value.function.name != NULL)
950 if (expr->ts.type == BT_UNKNOWN)
951 expr->ts = expr->symtree->n.sym->ts;
956 /* Apply the rules of section 14.1.2. */
958 switch (procedure_kind (expr->symtree->n.sym))
961 t = resolve_generic_f (expr);
965 t = resolve_specific_f (expr);
969 t = resolve_unknown_f (expr);
973 gfc_internal_error ("resolve_function(): bad function type");
977 /* If the expression is still a function (it might have simplified),
978 then we check to see if we are calling an elemental function. */
980 if (expr->expr_type != EXPR_FUNCTION)
983 if (expr->value.function.actual != NULL
984 && ((expr->value.function.esym != NULL
985 && expr->value.function.esym->attr.elemental)
986 || (expr->value.function.isym != NULL
987 && expr->value.function.isym->elemental)))
990 /* The rank of an elemental is the rank of its array argument(s). */
992 for (arg = expr->value.function.actual; arg; arg = arg->next)
994 if (arg->expr != NULL && arg->expr->rank > 0)
996 expr->rank = arg->expr->rank;
1002 if (!pure_function (expr, &name))
1007 ("Function reference to '%s' at %L is inside a FORALL block",
1008 name, &expr->where);
1011 else if (gfc_pure (NULL))
1013 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
1014 "procedure within a PURE procedure", name, &expr->where);
1023 /************* Subroutine resolution *************/
1026 pure_subroutine (gfc_code * c, gfc_symbol * sym)
1033 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
1034 sym->name, &c->loc);
1035 else if (gfc_pure (NULL))
1036 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
1042 resolve_generic_s0 (gfc_code * c, gfc_symbol * sym)
1046 if (sym->attr.generic)
1048 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
1051 c->resolved_sym = s;
1052 pure_subroutine (c, s);
1056 /* TODO: Need to search for elemental references in generic interface. */
1059 if (sym->attr.intrinsic)
1060 return gfc_intrinsic_sub_interface (c, 0);
1067 resolve_generic_s (gfc_code * c)
1072 sym = c->symtree->n.sym;
1074 m = resolve_generic_s0 (c, sym);
1077 if (m == MATCH_ERROR)
1080 if (sym->ns->parent != NULL)
1082 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1085 m = resolve_generic_s0 (c, sym);
1088 if (m == MATCH_ERROR)
1093 /* Last ditch attempt. */
1095 if (!gfc_generic_intrinsic (sym->name))
1098 ("Generic subroutine '%s' at %L is not an intrinsic subroutine",
1099 sym->name, &c->loc);
1103 m = gfc_intrinsic_sub_interface (c, 0);
1107 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
1108 "intrinsic subroutine interface", sym->name, &c->loc);
1114 /* Resolve a subroutine call known to be specific. */
1117 resolve_specific_s0 (gfc_code * c, gfc_symbol * sym)
1121 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1123 if (sym->attr.dummy)
1125 sym->attr.proc = PROC_DUMMY;
1129 sym->attr.proc = PROC_EXTERNAL;
1133 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
1136 if (sym->attr.intrinsic)
1138 m = gfc_intrinsic_sub_interface (c, 1);
1142 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
1143 "with an intrinsic", sym->name, &c->loc);
1151 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
1153 c->resolved_sym = sym;
1154 pure_subroutine (c, sym);
1161 resolve_specific_s (gfc_code * c)
1166 sym = c->symtree->n.sym;
1168 m = resolve_specific_s0 (c, sym);
1171 if (m == MATCH_ERROR)
1174 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1178 m = resolve_specific_s0 (c, sym);
1181 if (m == MATCH_ERROR)
1185 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
1186 sym->name, &c->loc);
1192 /* Resolve a subroutine call not known to be generic nor specific. */
1195 resolve_unknown_s (gfc_code * c)
1199 sym = c->symtree->n.sym;
1201 if (sym->attr.dummy)
1203 sym->attr.proc = PROC_DUMMY;
1207 /* See if we have an intrinsic function reference. */
1209 if (gfc_intrinsic_name (sym->name, 1))
1211 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
1216 /* The reference is to an external name. */
1219 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
1221 c->resolved_sym = sym;
1223 pure_subroutine (c, sym);
1229 /* Resolve a subroutine call. Although it was tempting to use the same code
1230 for functions, subroutines and functions are stored differently and this
1231 makes things awkward. */
1234 resolve_call (gfc_code * c)
1238 if (resolve_actual_arglist (c->ext.actual) == FAILURE)
1241 if (c->resolved_sym != NULL)
1244 switch (procedure_kind (c->symtree->n.sym))
1247 t = resolve_generic_s (c);
1250 case PTYPE_SPECIFIC:
1251 t = resolve_specific_s (c);
1255 t = resolve_unknown_s (c);
1259 gfc_internal_error ("resolve_subroutine(): bad function type");
1266 /* Resolve an operator expression node. This can involve replacing the
1267 operation with a user defined function call. */
1270 resolve_operator (gfc_expr * e)
1272 gfc_expr *op1, *op2;
1276 /* Resolve all subnodes-- give them types. */
1278 switch (e->operator)
1281 if (gfc_resolve_expr (e->op2) == FAILURE)
1284 /* Fall through... */
1287 case INTRINSIC_UPLUS:
1288 case INTRINSIC_UMINUS:
1289 if (gfc_resolve_expr (e->op1) == FAILURE)
1294 /* Typecheck the new node. */
1299 switch (e->operator)
1301 case INTRINSIC_UPLUS:
1302 case INTRINSIC_UMINUS:
1303 if (op1->ts.type == BT_INTEGER
1304 || op1->ts.type == BT_REAL
1305 || op1->ts.type == BT_COMPLEX)
1311 sprintf (msg, "Operand of unary numeric operator '%s' at %%L is %s",
1312 gfc_op2string (e->operator), gfc_typename (&e->ts));
1315 case INTRINSIC_PLUS:
1316 case INTRINSIC_MINUS:
1317 case INTRINSIC_TIMES:
1318 case INTRINSIC_DIVIDE:
1319 case INTRINSIC_POWER:
1320 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
1322 gfc_type_convert_binary (e);
1327 "Operands of binary numeric operator '%s' at %%L are %s/%s",
1328 gfc_op2string (e->operator), gfc_typename (&op1->ts),
1329 gfc_typename (&op2->ts));
1332 case INTRINSIC_CONCAT:
1333 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1335 e->ts.type = BT_CHARACTER;
1336 e->ts.kind = op1->ts.kind;
1341 "Operands of string concatenation operator at %%L are %s/%s",
1342 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
1348 case INTRINSIC_NEQV:
1349 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
1351 e->ts.type = BT_LOGICAL;
1352 e->ts.kind = gfc_kind_max (op1, op2);
1353 if (op1->ts.kind < e->ts.kind)
1354 gfc_convert_type (op1, &e->ts, 2);
1355 else if (op2->ts.kind < e->ts.kind)
1356 gfc_convert_type (op2, &e->ts, 2);
1360 sprintf (msg, "Operands of logical operator '%s' at %%L are %s/%s",
1361 gfc_op2string (e->operator), gfc_typename (&op1->ts),
1362 gfc_typename (&op2->ts));
1367 if (op1->ts.type == BT_LOGICAL)
1369 e->ts.type = BT_LOGICAL;
1370 e->ts.kind = op1->ts.kind;
1374 sprintf (msg, "Operand of .NOT. operator at %%L is %s",
1375 gfc_typename (&op1->ts));
1382 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
1384 strcpy (msg, "COMPLEX quantities cannot be compared at %L");
1388 /* Fall through... */
1392 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1394 e->ts.type = BT_LOGICAL;
1395 e->ts.kind = gfc_default_logical_kind ();
1399 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
1401 gfc_type_convert_binary (e);
1403 e->ts.type = BT_LOGICAL;
1404 e->ts.kind = gfc_default_logical_kind ();
1408 sprintf (msg, "Operands of comparison operator '%s' at %%L are %s/%s",
1409 gfc_op2string (e->operator), gfc_typename (&op1->ts),
1410 gfc_typename (&op2->ts));
1414 case INTRINSIC_USER:
1416 sprintf (msg, "Operand of user operator '%s' at %%L is %s",
1417 e->uop->ns->proc_name->name, gfc_typename (&op1->ts));
1419 sprintf (msg, "Operands of user operator '%s' at %%L are %s/%s",
1420 e->uop->ns->proc_name->name, gfc_typename (&op1->ts),
1421 gfc_typename (&op2->ts));
1426 gfc_internal_error ("resolve_operator(): Bad intrinsic");
1429 /* Deal with arrayness of an operand through an operator. */
1433 switch (e->operator)
1435 case INTRINSIC_PLUS:
1436 case INTRINSIC_MINUS:
1437 case INTRINSIC_TIMES:
1438 case INTRINSIC_DIVIDE:
1439 case INTRINSIC_POWER:
1440 case INTRINSIC_CONCAT:
1444 case INTRINSIC_NEQV:
1452 if (op1->rank == 0 && op2->rank == 0)
1455 if (op1->rank == 0 && op2->rank != 0)
1457 e->rank = op2->rank;
1459 if (e->shape == NULL)
1460 e->shape = gfc_copy_shape (op2->shape, op2->rank);
1463 if (op1->rank != 0 && op2->rank == 0)
1465 e->rank = op1->rank;
1467 if (e->shape == NULL)
1468 e->shape = gfc_copy_shape (op1->shape, op1->rank);
1471 if (op1->rank != 0 && op2->rank != 0)
1473 if (op1->rank == op2->rank)
1475 e->rank = op1->rank;
1477 if (e->shape == NULL)
1478 e->shape = gfc_copy_shape (op1->shape, op1->rank);
1483 gfc_error ("Inconsistent ranks for operator at %L and %L",
1484 &op1->where, &op2->where);
1487 /* Allow higher level expressions to work. */
1495 case INTRINSIC_UPLUS:
1496 case INTRINSIC_UMINUS:
1497 e->rank = op1->rank;
1499 if (e->shape == NULL)
1500 e->shape = gfc_copy_shape (op1->shape, op1->rank);
1502 /* Simply copy arrayness attribute */
1509 /* Attempt to simplify the expression. */
1511 t = gfc_simplify_expr (e, 0);
1515 if (gfc_extend_expr (e) == SUCCESS)
1518 gfc_error (msg, &e->where);
1523 /************** Array resolution subroutines **************/
1527 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
1530 /* Compare two integer expressions. */
1533 compare_bound (gfc_expr * a, gfc_expr * b)
1537 if (a == NULL || a->expr_type != EXPR_CONSTANT
1538 || b == NULL || b->expr_type != EXPR_CONSTANT)
1541 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
1542 gfc_internal_error ("compare_bound(): Bad expression");
1544 i = mpz_cmp (a->value.integer, b->value.integer);
1554 /* Compare an integer expression with an integer. */
1557 compare_bound_int (gfc_expr * a, int b)
1561 if (a == NULL || a->expr_type != EXPR_CONSTANT)
1564 if (a->ts.type != BT_INTEGER)
1565 gfc_internal_error ("compare_bound_int(): Bad expression");
1567 i = mpz_cmp_si (a->value.integer, b);
1577 /* Compare a single dimension of an array reference to the array
1581 check_dimension (int i, gfc_array_ref * ar, gfc_array_spec * as)
1584 /* Given start, end and stride values, calculate the minimum and
1585 maximum referenced indexes. */
1593 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
1595 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
1601 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
1603 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
1607 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
1609 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
1612 /* TODO: Possibly, we could warn about end[i] being out-of-bound although
1613 it is legal (see 6.2.2.3.1). */
1618 gfc_internal_error ("check_dimension(): Bad array reference");
1624 gfc_warning ("Array reference at %L is out of bounds", &ar->c_where[i]);
1629 /* Compare an array reference with an array specification. */
1632 compare_spec_to_ref (gfc_array_ref * ar)
1639 /* TODO: Full array sections are only allowed as actual parameters. */
1640 if (as->type == AS_ASSUMED_SIZE
1641 && (/*ar->type == AR_FULL
1642 ||*/ (ar->type == AR_SECTION
1643 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
1645 gfc_error ("Rightmost upper bound of assumed size array section"
1646 " not specified at %L", &ar->where);
1650 if (ar->type == AR_FULL)
1653 if (as->rank != ar->dimen)
1655 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
1656 &ar->where, ar->dimen, as->rank);
1660 for (i = 0; i < as->rank; i++)
1661 if (check_dimension (i, ar, as) == FAILURE)
1668 /* Resolve one part of an array index. */
1671 gfc_resolve_index (gfc_expr * index, int check_scalar)
1678 if (gfc_resolve_expr (index) == FAILURE)
1681 if (index->ts.type != BT_INTEGER)
1683 gfc_error ("Array index at %L must be of INTEGER type", &index->where);
1687 if (check_scalar && index->rank != 0)
1689 gfc_error ("Array index at %L must be scalar", &index->where);
1693 if (index->ts.kind != gfc_index_integer_kind)
1695 ts.type = BT_INTEGER;
1696 ts.kind = gfc_index_integer_kind;
1698 gfc_convert_type_warn (index, &ts, 2, 0);
1705 /* Given an expression that contains array references, update those array
1706 references to point to the right array specifications. While this is
1707 filled in during matching, this information is difficult to save and load
1708 in a module, so we take care of it here.
1710 The idea here is that the original array reference comes from the
1711 base symbol. We traverse the list of reference structures, setting
1712 the stored reference to references. Component references can
1713 provide an additional array specification. */
1716 find_array_spec (gfc_expr * e)
1722 as = e->symtree->n.sym->as;
1723 c = e->symtree->n.sym->components;
1725 for (ref = e->ref; ref; ref = ref->next)
1730 gfc_internal_error ("find_array_spec(): Missing spec");
1737 for (; c; c = c->next)
1738 if (c == ref->u.c.component)
1742 gfc_internal_error ("find_array_spec(): Component not found");
1747 gfc_internal_error ("find_array_spec(): unused as(1)");
1751 c = c->ts.derived->components;
1759 gfc_internal_error ("find_array_spec(): unused as(2)");
1763 /* Resolve an array reference. */
1766 resolve_array_ref (gfc_array_ref * ar)
1768 int i, check_scalar;
1770 for (i = 0; i < ar->dimen; i++)
1772 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
1774 if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
1776 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
1778 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
1781 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
1782 switch (ar->start[i]->rank)
1785 ar->dimen_type[i] = DIMEN_ELEMENT;
1789 ar->dimen_type[i] = DIMEN_VECTOR;
1793 gfc_error ("Array index at %L is an array of rank %d",
1794 &ar->c_where[i], ar->start[i]->rank);
1799 /* If the reference type is unknown, figure out what kind it is. */
1801 if (ar->type == AR_UNKNOWN)
1803 ar->type = AR_ELEMENT;
1804 for (i = 0; i < ar->dimen; i++)
1805 if (ar->dimen_type[i] == DIMEN_RANGE
1806 || ar->dimen_type[i] == DIMEN_VECTOR)
1808 ar->type = AR_SECTION;
1813 if (compare_spec_to_ref (ar) == FAILURE)
1821 resolve_substring (gfc_ref * ref)
1824 if (ref->u.ss.start != NULL)
1826 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
1829 if (ref->u.ss.start->ts.type != BT_INTEGER)
1831 gfc_error ("Substring start index at %L must be of type INTEGER",
1832 &ref->u.ss.start->where);
1836 if (ref->u.ss.start->rank != 0)
1838 gfc_error ("Substring start index at %L must be scalar",
1839 &ref->u.ss.start->where);
1843 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT)
1845 gfc_error ("Substring start index at %L is less than one",
1846 &ref->u.ss.start->where);
1851 if (ref->u.ss.end != NULL)
1853 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
1856 if (ref->u.ss.end->ts.type != BT_INTEGER)
1858 gfc_error ("Substring end index at %L must be of type INTEGER",
1859 &ref->u.ss.end->where);
1863 if (ref->u.ss.end->rank != 0)
1865 gfc_error ("Substring end index at %L must be scalar",
1866 &ref->u.ss.end->where);
1870 if (ref->u.ss.length != NULL
1871 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT)
1873 gfc_error ("Substring end index at %L is out of bounds",
1874 &ref->u.ss.start->where);
1883 /* Resolve subtype references. */
1886 resolve_ref (gfc_expr * expr)
1888 int current_part_dimension, n_components, seen_part_dimension;
1891 for (ref = expr->ref; ref; ref = ref->next)
1892 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
1894 find_array_spec (expr);
1898 for (ref = expr->ref; ref; ref = ref->next)
1902 if (resolve_array_ref (&ref->u.ar) == FAILURE)
1910 resolve_substring (ref);
1914 /* Check constraints on part references. */
1916 current_part_dimension = 0;
1917 seen_part_dimension = 0;
1920 for (ref = expr->ref; ref; ref = ref->next)
1925 switch (ref->u.ar.type)
1929 current_part_dimension = 1;
1933 current_part_dimension = 0;
1937 gfc_internal_error ("resolve_ref(): Bad array reference");
1943 if ((current_part_dimension || seen_part_dimension)
1944 && ref->u.c.component->pointer)
1947 ("Component to the right of a part reference with nonzero "
1948 "rank must not have the POINTER attribute at %L",
1960 if (((ref->type == REF_COMPONENT && n_components > 1)
1961 || ref->next == NULL)
1962 && current_part_dimension
1963 && seen_part_dimension)
1966 gfc_error ("Two or more part references with nonzero rank must "
1967 "not be specified at %L", &expr->where);
1971 if (ref->type == REF_COMPONENT)
1973 if (current_part_dimension)
1974 seen_part_dimension = 1;
1976 /* reset to make sure */
1977 current_part_dimension = 0;
1985 /* Given an expression, determine its shape. This is easier than it sounds.
1986 Leaves the shape array NULL if it is not possible to determine the shape. */
1989 expression_shape (gfc_expr * e)
1991 mpz_t array[GFC_MAX_DIMENSIONS];
1994 if (e->rank == 0 || e->shape != NULL)
1997 for (i = 0; i < e->rank; i++)
1998 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
2001 e->shape = gfc_get_shape (e->rank);
2003 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
2008 for (i--; i >= 0; i--)
2009 mpz_clear (array[i]);
2013 /* Given a variable expression node, compute the rank of the expression by
2014 examining the base symbol and any reference structures it may have. */
2017 expression_rank (gfc_expr * e)
2024 if (e->expr_type == EXPR_ARRAY)
2026 /* Constructors can have a rank different from one via RESHAPE(). */
2028 if (e->symtree == NULL)
2034 e->rank = (e->symtree->n.sym->as == NULL)
2035 ? 0 : e->symtree->n.sym->as->rank;
2041 for (ref = e->ref; ref; ref = ref->next)
2043 if (ref->type != REF_ARRAY)
2046 if (ref->u.ar.type == AR_FULL)
2048 rank = ref->u.ar.as->rank;
2052 if (ref->u.ar.type == AR_SECTION)
2054 /* Figure out the rank of the section. */
2056 gfc_internal_error ("expression_rank(): Two array specs");
2058 for (i = 0; i < ref->u.ar.dimen; i++)
2059 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
2060 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
2070 expression_shape (e);
2074 /* Resolve a variable expression. */
2077 resolve_variable (gfc_expr * e)
2081 if (e->ref && resolve_ref (e) == FAILURE)
2084 sym = e->symtree->n.sym;
2085 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
2087 e->ts.type = BT_PROCEDURE;
2091 if (sym->ts.type != BT_UNKNOWN)
2092 gfc_variable_attr (e, &e->ts);
2095 /* Must be a simple variable reference. */
2096 if (gfc_set_default_type (sym, 1, NULL) == FAILURE)
2105 /* Resolve an expression. That is, make sure that types of operands agree
2106 with their operators, intrinsic operators are converted to function calls
2107 for overloaded types and unresolved function references are resolved. */
2110 gfc_resolve_expr (gfc_expr * e)
2117 switch (e->expr_type)
2120 t = resolve_operator (e);
2124 t = resolve_function (e);
2128 t = resolve_variable (e);
2130 expression_rank (e);
2133 case EXPR_SUBSTRING:
2134 t = resolve_ref (e);
2144 if (resolve_ref (e) == FAILURE)
2147 t = gfc_resolve_array_constructor (e);
2148 /* Also try to expand a constructor. */
2151 expression_rank (e);
2152 gfc_expand_constructor (e);
2157 case EXPR_STRUCTURE:
2158 t = resolve_ref (e);
2162 t = resolve_structure_cons (e);
2166 t = gfc_simplify_expr (e, 0);
2170 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
2177 /* Resolve the expressions in an iterator structure and require that they all
2178 be of integer type. */
2181 gfc_resolve_iterator (gfc_iterator * iter)
2184 if (gfc_resolve_expr (iter->var) == FAILURE)
2187 if (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0)
2189 gfc_error ("Loop variable at %L must be a scalar INTEGER",
2194 if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
2196 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
2201 if (gfc_resolve_expr (iter->start) == FAILURE)
2204 if (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0)
2206 gfc_error ("Start expression in DO loop at %L must be a scalar INTEGER",
2207 &iter->start->where);
2211 if (gfc_resolve_expr (iter->end) == FAILURE)
2214 if (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0)
2216 gfc_error ("End expression in DO loop at %L must be a scalar INTEGER",
2221 if (gfc_resolve_expr (iter->step) == FAILURE)
2224 if (iter->step->ts.type != BT_INTEGER || iter->step->rank != 0)
2226 gfc_error ("Step expression in DO loop at %L must be a scalar INTEGER",
2227 &iter->step->where);
2231 if (iter->step->expr_type == EXPR_CONSTANT
2232 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
2234 gfc_error ("Step expression in DO loop at %L cannot be zero",
2235 &iter->step->where);
2243 /* Resolve a list of FORALL iterators. */
2246 resolve_forall_iterators (gfc_forall_iterator * iter)
2251 if (gfc_resolve_expr (iter->var) == SUCCESS
2252 && iter->var->ts.type != BT_INTEGER)
2253 gfc_error ("FORALL Iteration variable at %L must be INTEGER",
2256 if (gfc_resolve_expr (iter->start) == SUCCESS
2257 && iter->start->ts.type != BT_INTEGER)
2258 gfc_error ("FORALL start expression at %L must be INTEGER",
2259 &iter->start->where);
2260 if (iter->var->ts.kind != iter->start->ts.kind)
2261 gfc_convert_type (iter->start, &iter->var->ts, 2);
2263 if (gfc_resolve_expr (iter->end) == SUCCESS
2264 && iter->end->ts.type != BT_INTEGER)
2265 gfc_error ("FORALL end expression at %L must be INTEGER",
2267 if (iter->var->ts.kind != iter->end->ts.kind)
2268 gfc_convert_type (iter->end, &iter->var->ts, 2);
2270 if (gfc_resolve_expr (iter->stride) == SUCCESS
2271 && iter->stride->ts.type != BT_INTEGER)
2272 gfc_error ("FORALL Stride expression at %L must be INTEGER",
2273 &iter->stride->where);
2274 if (iter->var->ts.kind != iter->stride->ts.kind)
2275 gfc_convert_type (iter->stride, &iter->var->ts, 2);
2282 /* Given a pointer to a symbol that is a derived type, see if any components
2283 have the POINTER attribute. The search is recursive if necessary.
2284 Returns zero if no pointer components are found, nonzero otherwise. */
2287 derived_pointer (gfc_symbol * sym)
2291 for (c = sym->components; c; c = c->next)
2296 if (c->ts.type == BT_DERIVED && derived_pointer (c->ts.derived))
2304 /* Resolve the argument of a deallocate expression. The expression must be
2305 a pointer or a full array. */
2308 resolve_deallocate_expr (gfc_expr * e)
2310 symbol_attribute attr;
2314 if (gfc_resolve_expr (e) == FAILURE)
2317 attr = gfc_expr_attr (e);
2321 if (e->expr_type != EXPR_VARIABLE)
2324 allocatable = e->symtree->n.sym->attr.allocatable;
2325 for (ref = e->ref; ref; ref = ref->next)
2329 if (ref->u.ar.type != AR_FULL)
2334 allocatable = (ref->u.c.component->as != NULL
2335 && ref->u.c.component->as->type == AS_DEFERRED);
2343 if (allocatable == 0)
2346 gfc_error ("Expression in DEALLOCATE statement at %L must be "
2347 "ALLOCATABLE or a POINTER", &e->where);
2354 /* Resolve the expression in an ALLOCATE statement, doing the additional
2355 checks to see whether the expression is OK or not. The expression must
2356 have a trailing array reference that gives the size of the array. */
2359 resolve_allocate_expr (gfc_expr * e)
2361 int i, pointer, allocatable, dimension;
2362 symbol_attribute attr;
2363 gfc_ref *ref, *ref2;
2366 if (gfc_resolve_expr (e) == FAILURE)
2369 /* Make sure the expression is allocatable or a pointer. If it is
2370 pointer, the next-to-last reference must be a pointer. */
2374 if (e->expr_type != EXPR_VARIABLE)
2378 attr = gfc_expr_attr (e);
2379 pointer = attr.pointer;
2380 dimension = attr.dimension;
2385 allocatable = e->symtree->n.sym->attr.allocatable;
2386 pointer = e->symtree->n.sym->attr.pointer;
2387 dimension = e->symtree->n.sym->attr.dimension;
2389 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
2393 if (ref->next != NULL)
2398 allocatable = (ref->u.c.component->as != NULL
2399 && ref->u.c.component->as->type == AS_DEFERRED);
2401 pointer = ref->u.c.component->pointer;
2402 dimension = ref->u.c.component->dimension;
2412 if (allocatable == 0 && pointer == 0)
2414 gfc_error ("Expression in ALLOCATE statement at %L must be "
2415 "ALLOCATABLE or a POINTER", &e->where);
2419 if (pointer && dimension == 0)
2422 /* Make sure the next-to-last reference node is an array specification. */
2424 if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
2426 gfc_error ("Array specification required in ALLOCATE statement "
2427 "at %L", &e->where);
2431 if (ref2->u.ar.type == AR_ELEMENT)
2434 /* Make sure that the array section reference makes sense in the
2435 context of an ALLOCATE specification. */
2439 for (i = 0; i < ar->dimen; i++)
2440 switch (ar->dimen_type[i])
2446 if (ar->start[i] != NULL
2447 && ar->end[i] != NULL
2448 && ar->stride[i] == NULL)
2451 /* Fall Through... */
2455 gfc_error ("Bad array specification in ALLOCATE statement at %L",
2464 /************ SELECT CASE resolution subroutines ************/
2466 /* Callback function for our mergesort variant. Determines interval
2467 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
2468 op1 > op2. Assumes we're not dealing with the default case. */
2471 compare_cases (const void * _op1, const void * _op2)
2473 const gfc_case *op1, *op2;
2475 op1 = (const gfc_case *) _op1;
2476 op2 = (const gfc_case *) _op2;
2478 if (op1->low == NULL) /* op1 = (:N) */
2480 if (op2->low == NULL) /* op2 = (:M), so overlap. */
2483 else if (op2->high == NULL) /* op2 = (M:) */
2485 if (gfc_compare_expr (op1->high, op2->low) < 0)
2486 return -1; /* N < M */
2491 else /* op2 = (L:M) */
2493 if (gfc_compare_expr (op1->high, op2->low) < 0)
2494 return -1; /* N < L */
2500 else if (op1->high == NULL) /* op1 = (N:) */
2502 if (op2->low == NULL) /* op2 = (:M) */
2504 if (gfc_compare_expr (op1->low, op2->high) > 0)
2505 return 1; /* N > M */
2510 else if (op2->high == NULL) /* op2 = (M:), so overlap. */
2513 else /* op2 = (L:M) */
2515 if (gfc_compare_expr (op1->low, op2->high) > 0)
2516 return 1; /* N > M */
2522 else /* op1 = (N:P) */
2524 if (op2->low == NULL) /* op2 = (:M) */
2526 if (gfc_compare_expr (op1->low, op2->high) > 0)
2527 return 1; /* N > M */
2532 else if (op2->high == NULL) /* op2 = (M:) */
2534 if (gfc_compare_expr (op1->high, op2->low) < 0)
2535 return -1; /* P < M */
2540 else /* op2 = (L:M) */
2542 if (gfc_compare_expr (op1->high, op2->low) < 0)
2543 return -1; /* P < L */
2545 if (gfc_compare_expr (op1->low, op2->high) > 0)
2546 return 1; /* N > M */
2554 /* Merge-sort a double linked case list, detecting overlap in the
2555 process. LIST is the head of the double linked case list before it
2556 is sorted. Returns the head of the sorted list if we don't see any
2557 overlap, or NULL otherwise. */
2560 check_case_overlap (gfc_case * list)
2562 gfc_case *p, *q, *e, *tail;
2563 int insize, nmerges, psize, qsize, cmp, overlap_seen;
2565 /* If the passed list was empty, return immediately. */
2572 /* Loop unconditionally. The only exit from this loop is a return
2573 statement, when we've finished sorting the case list. */
2580 /* Count the number of merges we do in this pass. */
2583 /* Loop while there exists a merge to be done. */
2588 /* Count this merge. */
2591 /* Cut the list in two pieces by steppin INSIZE places
2592 forward in the list, starting from P. */
2595 for (i = 0; i < insize; i++)
2604 /* Now we have two lists. Merge them! */
2605 while (psize > 0 || (qsize > 0 && q != NULL))
2608 /* See from which the next case to merge comes from. */
2611 /* P is empty so the next case must come from Q. */
2616 else if (qsize == 0 || q == NULL)
2625 cmp = compare_cases (p, q);
2628 /* The whole case range for P is less than the
2636 /* The whole case range for Q is greater than
2637 the case range for P. */
2644 /* The cases overlap, or they are the same
2645 element in the list. Either way, we must
2646 issue an error and get the next case from P. */
2647 /* FIXME: Sort P and Q by line number. */
2648 gfc_error ("CASE label at %L overlaps with CASE "
2649 "label at %L", &p->where, &q->where);
2657 /* Add the next element to the merged list. */
2666 /* P has now stepped INSIZE places along, and so has Q. So
2667 they're the same. */
2672 /* If we have done only one merge or none at all, we've
2673 finished sorting the cases. */
2682 /* Otherwise repeat, merging lists twice the size. */
2688 /* Check to see if an expression is suitable for use in a CASE
2689 statement. Makes sure that all case expressions are scalar
2690 constants of the same type/kind. Return FAILURE if anything
2694 validate_case_label_expr (gfc_expr * e, gfc_expr * case_expr)
2696 gfc_typespec case_ts = case_expr->ts;
2698 if (e == NULL) return SUCCESS;
2700 if (e->ts.type != case_ts.type)
2702 gfc_error ("Expression in CASE statement at %L must be of type %s",
2703 &e->where, gfc_basic_typename (case_ts.type));
2707 if (e->ts.kind != case_ts.kind)
2709 gfc_error("Expression in CASE statement at %L must be kind %d",
2710 &e->where, case_ts.kind);
2716 gfc_error ("Expression in CASE statement at %L must be scalar",
2725 /* Given a completely parsed select statement, we:
2727 - Validate all expressions and code within the SELECT.
2728 - Make sure that the selection expression is not of the wrong type.
2729 - Make sure that no case ranges overlap.
2730 - Eliminate unreachable cases and unreachable code resulting from
2731 removing case labels.
2733 The standard does allow unreachable cases, e.g. CASE (5:3). But
2734 they are a hassle for code generation, and to prevent that, we just
2735 cut them out here. This is not necessary for overlapping cases
2736 because they are illegal and we never even try to generate code.
2738 We have the additional caveat that a SELECT construct could have
2739 been a computed GOTO in the source code. Furtunately we can fairly
2740 easily work around that here: The case_expr for a "real" SELECT CASE
2741 is in code->expr1, but for a computed GOTO it is in code->expr2. All
2742 we have to do is make sure that the case_expr is a scalar integer
2746 resolve_select (gfc_code * code)
2749 gfc_expr *case_expr;
2750 gfc_case *cp, *default_case, *tail, *head;
2751 int seen_unreachable;
2756 if (code->expr == NULL)
2758 /* This was actually a computed GOTO statement. */
2759 case_expr = code->expr2;
2760 if (case_expr->ts.type != BT_INTEGER
2761 || case_expr->rank != 0)
2762 gfc_error ("Selection expression in computed GOTO statement "
2763 "at %L must be a scalar integer expression",
2766 /* Further checking is not necessary because this SELECT was built
2767 by the compiler, so it should always be OK. Just move the
2768 case_expr from expr2 to expr so that we can handle computed
2769 GOTOs as normal SELECTs from here on. */
2770 code->expr = code->expr2;
2775 case_expr = code->expr;
2777 type = case_expr->ts.type;
2778 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
2780 gfc_error ("Argument of SELECT statement at %L cannot be %s",
2781 &case_expr->where, gfc_typename (&case_expr->ts));
2783 /* Punt. Going on here just produce more garbage error messages. */
2787 if (case_expr->rank != 0)
2789 gfc_error ("Argument of SELECT statement at %L must be a scalar "
2790 "expression", &case_expr->where);
2796 /* Assume there is no DEFAULT case. */
2797 default_case = NULL;
2801 for (body = code->block; body; body = body->block)
2803 /* Assume the CASE list is OK, and all CASE labels can be matched. */
2805 seen_unreachable = 0;
2807 /* Walk the case label list, making sure that all case labels
2809 for (cp = body->ext.case_list; cp; cp = cp->next)
2811 /* Count the number of cases in the whole construct. */
2814 /* Intercept the DEFAULT case. */
2815 if (cp->low == NULL && cp->high == NULL)
2817 if (default_case != NULL)
2819 gfc_error ("The DEFAULT CASE at %L cannot be followed "
2820 "by a second DEFAULT CASE at %L",
2821 &default_case->where, &cp->where);
2832 /* Deal with single value cases and case ranges. Errors are
2833 issued from the validation function. */
2834 if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
2835 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
2841 if (type == BT_LOGICAL
2842 && ((cp->low == NULL || cp->high == NULL)
2843 || cp->low != cp->high))
2846 ("Logical range in CASE statement at %L is not allowed",
2852 if (cp->low != NULL && cp->high != NULL
2853 && cp->low != cp->high
2854 && gfc_compare_expr (cp->low, cp->high) > 0)
2856 if (gfc_option.warn_surprising)
2857 gfc_warning ("Range specification at %L can never "
2858 "be matched", &cp->where);
2860 cp->unreachable = 1;
2861 seen_unreachable = 1;
2865 /* If the case range can be matched, it can also overlap with
2866 other cases. To make sure it does not, we put it in a
2867 double linked list here. We sort that with a merge sort
2868 later on to detect any overlapping cases. */
2872 head->right = head->left = NULL;
2877 tail->right->left = tail;
2884 /* It there was a failure in the previous case label, give up
2885 for this case label list. Continue with the next block. */
2889 /* See if any case labels that are unreachable have been seen.
2890 If so, we eliminate them. This is a bit of a kludge because
2891 the case lists for a single case statement (label) is a
2892 single forward linked lists. */
2893 if (seen_unreachable)
2895 /* Advance until the first case in the list is reachable. */
2896 while (body->ext.case_list != NULL
2897 && body->ext.case_list->unreachable)
2899 gfc_case *n = body->ext.case_list;
2900 body->ext.case_list = body->ext.case_list->next;
2902 gfc_free_case_list (n);
2905 /* Strip all other unreachable cases. */
2906 if (body->ext.case_list)
2908 for (cp = body->ext.case_list; cp->next; cp = cp->next)
2910 if (cp->next->unreachable)
2912 gfc_case *n = cp->next;
2913 cp->next = cp->next->next;
2915 gfc_free_case_list (n);
2922 /* See if there were overlapping cases. If the check returns NULL,
2923 there was overlap. In that case we don't do anything. If head
2924 is non-NULL, we prepend the DEFAULT case. The sorted list can
2925 then used during code generation for SELECT CASE constructs with
2926 a case expression of a CHARACTER type. */
2929 head = check_case_overlap (head);
2931 /* Prepend the default_case if it is there. */
2932 if (head != NULL && default_case)
2934 default_case->left = NULL;
2935 default_case->right = head;
2936 head->left = default_case;
2940 /* Eliminate dead blocks that may be the result if we've seen
2941 unreachable case labels for a block. */
2942 for (body = code; body && body->block; body = body->block)
2944 if (body->block->ext.case_list == NULL)
2946 /* Cut the unreachable block from the code chain. */
2947 gfc_code *c = body->block;
2948 body->block = c->block;
2950 /* Kill the dead block, but not the blocks below it. */
2952 gfc_free_statements (c);
2956 /* More than two cases is legal but insane for logical selects.
2957 Issue a warning for it. */
2958 if (gfc_option.warn_surprising && type == BT_LOGICAL
2960 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
2965 /*********** Toplevel code resolution subroutines ***********/
2967 /* Given a branch to a label and a namespace, if the branch is conforming.
2968 The code node described where the branch is located. */
2971 resolve_branch (gfc_st_label * label, gfc_code * code)
2973 gfc_code *block, *found;
2981 /* Step one: is this a valid branching target? */
2983 if (lp->defined == ST_LABEL_UNKNOWN)
2985 gfc_error ("Label %d referenced at %L is never defined", lp->value,
2990 if (lp->defined != ST_LABEL_TARGET)
2992 gfc_error ("Statement at %L is not a valid branch target statement "
2993 "for the branch statement at %L", &lp->where, &code->loc);
2997 /* Step two: make sure this branch is not a branch to itself ;-) */
2999 if (code->here == label)
3001 gfc_warning ("Branch at %L causes an infinite loop", &code->loc);
3005 /* Step three: Try to find the label in the parse tree. To do this,
3006 we traverse the tree block-by-block: first the block that
3007 contains this GOTO, then the block that it is nested in, etc. We
3008 can ignore other blocks because branching into another block is
3013 for (stack = cs_base; stack; stack = stack->prev)
3015 for (block = stack->head; block; block = block->next)
3017 if (block->here == label)
3030 /* still nothing, so illegal. */
3031 gfc_error_now ("Label at %L is not in the same block as the "
3032 "GOTO statement at %L", &lp->where, &code->loc);
3036 /* Step four: Make sure that the branching target is legal if
3037 the statement is an END {SELECT,DO,IF}. */
3039 if (found->op == EXEC_NOP)
3041 for (stack = cs_base; stack; stack = stack->prev)
3042 if (stack->current->next == found)
3046 gfc_notify_std (GFC_STD_F95_DEL,
3047 "Obsolete: GOTO at %L jumps to END of construct at %L",
3048 &code->loc, &found->loc);
3053 /* Check whether EXPR1 has the same shape as EXPR2. */
3056 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
3058 mpz_t shape[GFC_MAX_DIMENSIONS];
3059 mpz_t shape2[GFC_MAX_DIMENSIONS];
3060 try result = FAILURE;
3063 /* Compare the rank. */
3064 if (expr1->rank != expr2->rank)
3067 /* Compare the size of each dimension. */
3068 for (i=0; i<expr1->rank; i++)
3070 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
3073 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
3076 if (mpz_cmp (shape[i], shape2[i]))
3080 /* When either of the two expression is an assumed size array, we
3081 ignore the comparison of dimension sizes. */
3086 for (i--; i>=0; i--)
3088 mpz_clear (shape[i]);
3089 mpz_clear (shape2[i]);
3095 /* Check whether a WHERE assignment target or a WHERE mask expression
3096 has the same shape as the outmost WHERE mask expression. */
3099 resolve_where (gfc_code *code, gfc_expr *mask)
3105 cblock = code->block;
3107 /* Store the first WHERE mask-expr of the WHERE statement or construct.
3108 In case of nested WHERE, only the outmost one is stored. */
3109 if (mask == NULL) /* outmost WHERE */
3111 else /* inner WHERE */
3118 /* Check if the mask-expr has a consistent shape with the
3119 outmost WHERE mask-expr. */
3120 if (resolve_where_shape (cblock->expr, e) == FAILURE)
3121 gfc_error ("WHERE mask at %L has inconsistent shape",
3122 &cblock->expr->where);
3125 /* the assignment statement of a WHERE statement, or the first
3126 statement in where-body-construct of a WHERE construct */
3127 cnext = cblock->next;
3132 /* WHERE assignment statement */
3135 /* Check shape consistent for WHERE assignment target. */
3136 if (e && resolve_where_shape (cnext->expr, e) == FAILURE)
3137 gfc_error ("WHERE assignment target at %L has "
3138 "inconsistent shape", &cnext->expr->where);
3141 /* WHERE or WHERE construct is part of a where-body-construct */
3143 resolve_where (cnext, e);
3147 gfc_error ("Unsupported statement inside WHERE at %L",
3150 /* the next statement within the same where-body-construct */
3151 cnext = cnext->next;
3153 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
3154 cblock = cblock->block;
3159 /* Check whether the FORALL index appears in the expression or not. */
3162 gfc_find_forall_index (gfc_expr *expr, gfc_symbol *symbol)
3166 gfc_actual_arglist *args;
3169 switch (expr->expr_type)
3172 assert (expr->symtree->n.sym);
3174 /* A scalar assignment */
3177 if (expr->symtree->n.sym == symbol)
3183 /* the expr is array ref, substring or struct component. */
3190 /* Check if the symbol appears in the array subscript. */
3192 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
3195 if (gfc_find_forall_index (ar.start[i], symbol) == SUCCESS)
3199 if (gfc_find_forall_index (ar.end[i], symbol) == SUCCESS)
3203 if (gfc_find_forall_index (ar.stride[i], symbol) == SUCCESS)
3209 if (expr->symtree->n.sym == symbol)
3212 /* Check if the symbol appears in the substring section. */
3213 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
3215 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
3223 gfc_error("expresion reference type error at %L", &expr->where);
3229 /* If the expression is a function call, then check if the symbol
3230 appears in the actual arglist of the function. */
3232 for (args = expr->value.function.actual; args; args = args->next)
3234 if (gfc_find_forall_index(args->expr,symbol) == SUCCESS)
3239 /* It seems not to happen. */
3240 case EXPR_SUBSTRING:
3244 assert(expr->ref->type == REF_SUBSTRING);
3245 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
3247 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
3252 /* It seems not to happen. */
3253 case EXPR_STRUCTURE:
3255 gfc_error ("Unsupported statement while finding forall index in "
3262 /* Find the FORALL index in the first operand. */
3265 if (gfc_find_forall_index (expr->op1, symbol) == SUCCESS)
3269 /* Find the FORALL index in the second operand. */
3272 if (gfc_find_forall_index (expr->op2, symbol) == SUCCESS)
3279 /* Resolve assignment in FORALL construct.
3280 NVAR is the number of FORALL index variables, and VAR_EXPR records the
3281 FORALL index variables. */
3284 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
3288 for (n = 0; n < nvar; n++)
3290 gfc_symbol *forall_index;
3292 forall_index = var_expr[n]->symtree->n.sym;
3294 /* Check whether the assignment target is one of the FORALL index
3296 if ((code->expr->expr_type == EXPR_VARIABLE)
3297 && (code->expr->symtree->n.sym == forall_index))
3298 gfc_error ("Assignment to a FORALL index variable at %L",
3299 &code->expr->where);
3302 /* If one of the FORALL index variables doesn't appear in the
3303 assignment target, then there will be a many-to-one
3305 if (gfc_find_forall_index (code->expr, forall_index) == FAILURE)
3306 gfc_error ("The FORALL with index '%s' cause more than one "
3307 "assignment to this object at %L",
3308 var_expr[n]->symtree->name, &code->expr->where);
3314 /* Resolve WHERE statement in FORALL construct. */
3317 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr){
3321 cblock = code->block;
3324 /* the assignment statement of a WHERE statement, or the first
3325 statement in where-body-construct of a WHERE construct */
3326 cnext = cblock->next;
3331 /* WHERE assignment statement */
3333 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
3336 /* WHERE or WHERE construct is part of a where-body-construct */
3338 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
3342 gfc_error ("Unsupported statement inside WHERE at %L",
3345 /* the next statement within the same where-body-construct */
3346 cnext = cnext->next;
3348 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
3349 cblock = cblock->block;
3354 /* Traverse the FORALL body to check whether the following errors exist:
3355 1. For assignment, check if a many-to-one assignment happens.
3356 2. For WHERE statement, check the WHERE body to see if there is any
3357 many-to-one assignment. */
3360 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
3364 c = code->block->next;
3370 case EXEC_POINTER_ASSIGN:
3371 gfc_resolve_assign_in_forall (c, nvar, var_expr);
3374 /* Because the resolve_blocks() will handle the nested FORALL,
3375 there is no need to handle it here. */
3379 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
3384 /* The next statement in the FORALL body. */
3390 /* Given a FORALL construct, first resolve the FORALL iterator, then call
3391 gfc_resolve_forall_body to resolve the FORALL body. */
3393 static void resolve_blocks (gfc_code *, gfc_namespace *);
3396 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
3398 static gfc_expr **var_expr;
3399 static int total_var = 0;
3400 static int nvar = 0;
3401 gfc_forall_iterator *fa;
3402 gfc_symbol *forall_index;
3406 /* Start to resolve a FORALL construct */
3407 if (forall_save == 0)
3409 /* Count the total number of FORALL index in the nested FORALL
3410 construct in order to allocate the VAR_EXPR with proper size. */
3412 while ((next != NULL) && (next->op == EXEC_FORALL))
3414 for (fa = next->ext.forall_iterator; fa; fa = fa->next)
3416 next = next->block->next;
3419 /* allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
3420 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
3423 /* The information about FORALL iterator, including FORALL index start, end
3424 and stride. The FORALL index can not appear in start, end or stride. */
3425 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
3427 /* Check if any outer FORALL index name is the same as the current
3429 for (i = 0; i < nvar; i++)
3431 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
3433 gfc_error ("An outer FORALL construct already has an index "
3434 "with this name %L", &fa->var->where);
3438 /* Record the current FORALL index. */
3439 var_expr[nvar] = gfc_copy_expr (fa->var);
3441 forall_index = fa->var->symtree->n.sym;
3443 /* Check if the FORALL index appears in start, end or stride. */
3444 if (gfc_find_forall_index (fa->start, forall_index) == SUCCESS)
3445 gfc_error ("A FORALL index must not appear in a limit or stride "
3446 "expression in the same FORALL at %L", &fa->start->where);
3447 if (gfc_find_forall_index (fa->end, forall_index) == SUCCESS)
3448 gfc_error ("A FORALL index must not appear in a limit or stride "
3449 "expression in the same FORALL at %L", &fa->end->where);
3450 if (gfc_find_forall_index (fa->stride, forall_index) == SUCCESS)
3451 gfc_error ("A FORALL index must not appear in a limit or stride "
3452 "expression in the same FORALL at %L", &fa->stride->where);
3456 /* Resolve the FORALL body. */
3457 gfc_resolve_forall_body (code, nvar, var_expr);
3459 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
3460 resolve_blocks (code->block, ns);
3462 /* Free VAR_EXPR after the whole FORALL construct resolved. */
3463 for (i = 0; i < total_var; i++)
3464 gfc_free_expr (var_expr[i]);
3466 /* Reset the counters. */
3472 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
3475 static void resolve_code (gfc_code *, gfc_namespace *);
3478 resolve_blocks (gfc_code * b, gfc_namespace * ns)
3482 for (; b; b = b->block)
3484 t = gfc_resolve_expr (b->expr);
3485 if (gfc_resolve_expr (b->expr2) == FAILURE)
3491 if (t == SUCCESS && b->expr != NULL
3492 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank != 0))
3494 ("ELSE IF clause at %L requires a scalar LOGICAL expression",
3501 && (b->expr->ts.type != BT_LOGICAL
3502 || b->expr->rank == 0))
3504 ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
3509 resolve_branch (b->label, b);
3519 gfc_internal_error ("resolve_block(): Bad block type");
3522 resolve_code (b->next, ns);
3527 /* Given a block of code, recursively resolve everything pointed to by this
3531 resolve_code (gfc_code * code, gfc_namespace * ns)
3533 int forall_save = 0;
3538 frame.prev = cs_base;
3542 for (; code; code = code->next)
3544 frame.current = code;
3546 if (code->op == EXEC_FORALL)
3548 forall_save = forall_flag;
3550 gfc_resolve_forall (code, ns, forall_save);
3553 resolve_blocks (code->block, ns);
3555 if (code->op == EXEC_FORALL)
3556 forall_flag = forall_save;
3558 t = gfc_resolve_expr (code->expr);
3559 if (gfc_resolve_expr (code->expr2) == FAILURE)
3576 resolve_where (code, NULL);
3580 if (code->expr != NULL && code->expr->ts.type != BT_INTEGER)
3581 gfc_error ("ASSIGNED GOTO statement at %L requires an INTEGER "
3582 "variable", &code->expr->where);
3584 resolve_branch (code->label, code);
3588 if (code->expr != NULL && code->expr->ts.type != BT_INTEGER)
3589 gfc_error ("Alternate RETURN statement at %L requires an INTEGER "
3590 "return specifier", &code->expr->where);
3597 if (gfc_extend_assign (code, ns) == SUCCESS)
3600 if (gfc_pure (NULL))
3602 if (gfc_impure_variable (code->expr->symtree->n.sym))
3605 ("Cannot assign to variable '%s' in PURE procedure at %L",
3606 code->expr->symtree->n.sym->name, &code->expr->where);
3610 if (code->expr2->ts.type == BT_DERIVED
3611 && derived_pointer (code->expr2->ts.derived))
3614 ("Right side of assignment at %L is a derived type "
3615 "containing a POINTER in a PURE procedure",
3616 &code->expr2->where);
3621 gfc_check_assign (code->expr, code->expr2, 1);
3624 case EXEC_LABEL_ASSIGN:
3625 if (code->label->defined == ST_LABEL_UNKNOWN)
3626 gfc_error ("Label %d referenced at %L is never defined",
3627 code->label->value, &code->label->where);
3628 if (t == SUCCESS && code->expr->ts.type != BT_INTEGER)
3629 gfc_error ("ASSIGN statement at %L requires an INTEGER "
3630 "variable", &code->expr->where);
3633 case EXEC_POINTER_ASSIGN:
3637 gfc_check_pointer_assign (code->expr, code->expr2);
3640 case EXEC_ARITHMETIC_IF:
3642 && code->expr->ts.type != BT_INTEGER
3643 && code->expr->ts.type != BT_REAL)
3644 gfc_error ("Arithmetic IF statement at %L requires a numeric "
3645 "expression", &code->expr->where);
3647 resolve_branch (code->label, code);
3648 resolve_branch (code->label2, code);
3649 resolve_branch (code->label3, code);
3653 if (t == SUCCESS && code->expr != NULL
3654 && (code->expr->ts.type != BT_LOGICAL
3655 || code->expr->rank != 0))
3656 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
3657 &code->expr->where);
3662 resolve_call (code);
3666 /* Select is complicated. Also, a SELECT construct could be
3667 a transformed computed GOTO. */
3668 resolve_select (code);
3672 if (code->ext.iterator != NULL)
3673 gfc_resolve_iterator (code->ext.iterator);
3677 if (code->expr == NULL)
3678 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
3680 && (code->expr->rank != 0
3681 || code->expr->ts.type != BT_LOGICAL))
3682 gfc_error ("Exit condition of DO WHILE loop at %L must be "
3683 "a scalar LOGICAL expression", &code->expr->where);
3687 if (t == SUCCESS && code->expr != NULL
3688 && code->expr->ts.type != BT_INTEGER)
3689 gfc_error ("STAT tag in ALLOCATE statement at %L must be "
3690 "of type INTEGER", &code->expr->where);
3692 for (a = code->ext.alloc_list; a; a = a->next)
3693 resolve_allocate_expr (a->expr);
3697 case EXEC_DEALLOCATE:
3698 if (t == SUCCESS && code->expr != NULL
3699 && code->expr->ts.type != BT_INTEGER)
3701 ("STAT tag in DEALLOCATE statement at %L must be of type "
3702 "INTEGER", &code->expr->where);
3704 for (a = code->ext.alloc_list; a; a = a->next)
3705 resolve_deallocate_expr (a->expr);
3710 if (gfc_resolve_open (code->ext.open) == FAILURE)
3713 resolve_branch (code->ext.open->err, code);
3717 if (gfc_resolve_close (code->ext.close) == FAILURE)
3720 resolve_branch (code->ext.close->err, code);
3723 case EXEC_BACKSPACE:
3726 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
3729 resolve_branch (code->ext.filepos->err, code);
3733 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
3736 resolve_branch (code->ext.inquire->err, code);
3740 assert(code->ext.inquire != NULL);
3741 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
3744 resolve_branch (code->ext.inquire->err, code);
3749 if (gfc_resolve_dt (code->ext.dt) == FAILURE)
3752 resolve_branch (code->ext.dt->err, code);
3753 resolve_branch (code->ext.dt->end, code);
3754 resolve_branch (code->ext.dt->eor, code);
3758 resolve_forall_iterators (code->ext.forall_iterator);
3760 if (code->expr != NULL && code->expr->ts.type != BT_LOGICAL)
3762 ("FORALL mask clause at %L requires a LOGICAL expression",
3763 &code->expr->where);
3767 gfc_internal_error ("resolve_code(): Bad statement code");
3771 cs_base = frame.prev;
3775 /* Resolve initial values and make sure they are compatible with
3779 resolve_values (gfc_symbol * sym)
3782 if (sym->value == NULL)
3785 if (gfc_resolve_expr (sym->value) == FAILURE)
3788 gfc_check_assign_symbol (sym, sym->value);
3792 /* Do anything necessary to resolve a symbol. Right now, we just
3793 assume that an otherwise unknown symbol is a variable. This sort
3794 of thing commonly happens for symbols in module. */
3797 resolve_symbol (gfc_symbol * sym)
3799 /* Zero if we are checking a formal namespace. */
3800 static int formal_ns_flag = 1;
3801 int formal_ns_save, check_constant, mp_flag;
3806 if (sym->attr.flavor == FL_UNKNOWN)
3808 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
3809 sym->attr.flavor = FL_VARIABLE;
3812 sym->attr.flavor = FL_PROCEDURE;
3813 if (sym->attr.dimension)
3814 sym->attr.function = 1;
3818 /* Symbols that are module procedures with results (functions) have
3819 the types and array specification copied for type checking in
3820 procedures that call them, as well as for saving to a module
3821 file. These symbols can't stand the scrutiny that their results
3823 mp_flag = (sym->result != NULL && sym->result != sym);
3825 /* Assign default type to symbols that need one and don't have one. */
3826 if (sym->ts.type == BT_UNKNOWN)
3828 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
3829 gfc_set_default_type (sym, 1, NULL);
3831 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
3834 gfc_set_default_type (sym, 0, NULL);
3837 /* Result may be in another namespace. */
3838 resolve_symbol (sym->result);
3840 sym->ts = sym->result->ts;
3841 sym->as = gfc_copy_array_spec (sym->result->as);
3846 /* Assumed size arrays and assumed shape arrays must be dummy
3850 && (sym->as->type == AS_ASSUMED_SIZE
3851 || sym->as->type == AS_ASSUMED_SHAPE)
3852 && sym->attr.dummy == 0)
3854 gfc_error ("Assumed %s array at %L must be a dummy argument",
3855 sym->as->type == AS_ASSUMED_SIZE ? "size" : "shape",
3860 /* A parameter array's shape needs to be constant. */
3862 if (sym->attr.flavor == FL_PARAMETER && sym->as != NULL
3863 && !gfc_is_compile_time_shape (sym->as))
3865 gfc_error ("Parameter array '%s' at %L cannot be automatic "
3866 "or assumed shape", sym->name, &sym->declared_at);
3870 /* Make sure that character string variables with assumed length are
3873 if (sym->attr.flavor == FL_VARIABLE && !sym->attr.result
3874 && sym->ts.type == BT_CHARACTER
3875 && sym->ts.cl->length == NULL && sym->attr.dummy == 0)
3877 gfc_error ("Entity with assumed character length at %L must be a "
3878 "dummy argument or a PARAMETER", &sym->declared_at);
3882 /* Make sure a parameter that has been implicitly typed still
3883 matches the implicit type, since PARAMETER statements can precede
3884 IMPLICIT statements. */
3886 if (sym->attr.flavor == FL_PARAMETER
3887 && sym->attr.implicit_type
3888 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym, sym->ns)))
3889 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
3890 "later IMPLICIT type", sym->name, &sym->declared_at);
3892 /* Make sure the types of derived parameters are consistent. This
3893 type checking is deferred until resolution because the type may
3894 refer to a derived type from the host. */
3896 if (sym->attr.flavor == FL_PARAMETER
3897 && sym->ts.type == BT_DERIVED
3898 && !gfc_compare_types (&sym->ts, &sym->value->ts))
3899 gfc_error ("Incompatible derived type in PARAMETER at %L",
3900 &sym->value->where);
3902 /* Make sure symbols with known intent or optional are really dummy
3903 variable. Because of ENTRY statement, this has to be deferred
3904 until resolution time. */
3906 if (! sym->attr.dummy
3907 && (sym->attr.optional
3908 || sym->attr.intent != INTENT_UNKNOWN))
3910 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
3914 if (sym->attr.proc == PROC_ST_FUNCTION)
3916 if (sym->ts.type == BT_CHARACTER)
3918 gfc_charlen *cl = sym->ts.cl;
3919 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
3921 gfc_error ("Character-valued statement function '%s' at %L must "
3922 "have constant length", sym->name, &sym->declared_at);
3928 /* Constraints on deferred shape variable. */
3929 if (sym->attr.flavor == FL_VARIABLE
3930 || (sym->attr.flavor == FL_PROCEDURE
3931 && sym->attr.function))
3933 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
3935 if (sym->attr.allocatable)
3937 if (sym->attr.dimension)
3938 gfc_error ("Allocatable array at %L must have a deferred shape",
3941 gfc_error ("Object at %L may not be ALLOCATABLE",
3946 if (sym->attr.pointer && sym->attr.dimension)
3948 gfc_error ("Pointer to array at %L must have a deferred shape",
3956 if (!mp_flag && !sym->attr.allocatable
3957 && !sym->attr.pointer && !sym->attr.dummy)
3959 gfc_error ("Array at %L cannot have a deferred shape",
3966 if (sym->attr.flavor == FL_VARIABLE)
3968 /* Can the sybol have an initializer? */
3970 if (sym->attr.allocatable)
3971 whynot = "Allocatable";
3972 else if (sym->attr.external)
3973 whynot = "External";
3974 else if (sym->attr.dummy)
3976 else if (sym->attr.intrinsic)
3977 whynot = "Intrinsic";
3978 else if (sym->attr.result)
3979 whynot = "Function Result";
3980 else if (sym->attr.dimension && !sym->attr.pointer)
3982 /* Don't allow initialization of automatic arrays. */
3983 for (i = 0; i < sym->as->rank; i++)
3985 if (sym->as->lower[i] == NULL
3986 || sym->as->lower[i]->expr_type != EXPR_CONSTANT
3987 || sym->as->upper[i] == NULL
3988 || sym->as->upper[i]->expr_type != EXPR_CONSTANT)
3990 whynot = "Automatic array";
3996 /* Reject illegal initializers. */
3997 if (sym->value && whynot)
3999 gfc_error ("%s '%s' at %L cannot have an initializer",
4000 whynot, sym->name, &sym->declared_at);
4004 /* Assign default initializer. */
4005 if (sym->ts.type == BT_DERIVED && !(sym->value || whynot))
4006 sym->value = gfc_default_initializer (&sym->ts);
4010 /* Make sure that intrinsic exist */
4011 if (sym->attr.intrinsic
4012 && ! gfc_intrinsic_name(sym->name, 0)
4013 && ! gfc_intrinsic_name(sym->name, 1))
4014 gfc_error("Intrinsic at %L does not exist", &sym->declared_at);
4016 /* Resolve array specifier. Check as well some constraints
4017 on COMMON blocks. */
4019 check_constant = sym->attr.in_common && !sym->attr.pointer;
4020 gfc_resolve_array_spec (sym->as, check_constant);
4022 /* Resolve formal namespaces. */
4024 if (formal_ns_flag && sym != NULL && sym->formal_ns != NULL)
4026 formal_ns_save = formal_ns_flag;
4028 gfc_resolve (sym->formal_ns);
4029 formal_ns_flag = formal_ns_save;
4035 /************* Resolve DATA statements *************/
4039 gfc_data_value *vnode;
4045 /* Advance the values structure to point to the next value in the data list. */
4048 next_data_value (void)
4050 while (values.left == 0)
4052 if (values.vnode->next == NULL)
4055 values.vnode = values.vnode->next;
4056 values.left = values.vnode->repeat;
4064 check_data_variable (gfc_data_variable * var, locus * where)
4070 ar_type mark = AR_UNKNOWN;
4072 mpz_t section_index[GFC_MAX_DIMENSIONS];
4076 if (gfc_resolve_expr (var->expr) == FAILURE)
4080 mpz_init_set_si (offset, 0);
4083 if (e->expr_type != EXPR_VARIABLE)
4084 gfc_internal_error ("check_data_variable(): Bad expression");
4088 mpz_init_set_ui (size, 1);
4095 /* Find the array section reference. */
4096 for (ref = e->ref; ref; ref = ref->next)
4098 if (ref->type != REF_ARRAY)
4100 if (ref->u.ar.type == AR_ELEMENT)
4106 /* Set marks asscording to the reference pattern. */
4107 switch (ref->u.ar.type)
4115 /* Get the start position of array section. */
4116 gfc_get_section_index (ar, section_index, &offset);
4124 if (gfc_array_size (e, &size) == FAILURE)
4126 gfc_error ("Nonconstant array section at %L in DATA statement",
4135 while (mpz_cmp_ui (size, 0) > 0)
4137 if (next_data_value () == FAILURE)
4139 gfc_error ("DATA statement at %L has more variables than values",
4145 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
4149 /* If we have more than one element left in the repeat count,
4150 and we have more than one element left in the target variable,
4151 then create a range assignment. */
4152 /* ??? Only done for full arrays for now, since array sections
4154 if (mark == AR_FULL && ref && ref->next == NULL
4155 && values.left > 1 && mpz_cmp_ui (size, 1) > 0)
4159 if (mpz_cmp_ui (size, values.left) >= 0)
4161 mpz_init_set_ui (range, values.left);
4162 mpz_sub_ui (size, size, values.left);
4167 mpz_init_set (range, size);
4168 values.left -= mpz_get_ui (size);
4169 mpz_set_ui (size, 0);
4172 gfc_assign_data_value_range (var->expr, values.vnode->expr,
4175 mpz_add (offset, offset, range);
4179 /* Assign initial value to symbol. */
4183 mpz_sub_ui (size, size, 1);
4185 gfc_assign_data_value (var->expr, values.vnode->expr, offset);
4187 if (mark == AR_FULL)
4188 mpz_add_ui (offset, offset, 1);
4190 /* Modify the array section indexes and recalculate the offset
4191 for next element. */
4192 else if (mark == AR_SECTION)
4193 gfc_advance_section (section_index, ar, &offset);
4197 if (mark == AR_SECTION)
4199 for (i = 0; i < ar->dimen; i++)
4200 mpz_clear (section_index[i]);
4210 static try traverse_data_var (gfc_data_variable *, locus *);
4212 /* Iterate over a list of elements in a DATA statement. */
4215 traverse_data_list (gfc_data_variable * var, locus * where)
4218 iterator_stack frame;
4221 mpz_init (frame.value);
4223 mpz_init_set (trip, var->iter.end->value.integer);
4224 mpz_sub (trip, trip, var->iter.start->value.integer);
4225 mpz_add (trip, trip, var->iter.step->value.integer);
4227 mpz_div (trip, trip, var->iter.step->value.integer);
4229 mpz_set (frame.value, var->iter.start->value.integer);
4231 frame.prev = iter_stack;
4232 frame.variable = var->iter.var->symtree;
4233 iter_stack = &frame;
4235 while (mpz_cmp_ui (trip, 0) > 0)
4237 if (traverse_data_var (var->list, where) == FAILURE)
4243 e = gfc_copy_expr (var->expr);
4244 if (gfc_simplify_expr (e, 1) == FAILURE)
4250 mpz_add (frame.value, frame.value, var->iter.step->value.integer);
4252 mpz_sub_ui (trip, trip, 1);
4256 mpz_clear (frame.value);
4258 iter_stack = frame.prev;
4263 /* Type resolve variables in the variable list of a DATA statement. */
4266 traverse_data_var (gfc_data_variable * var, locus * where)
4270 for (; var; var = var->next)
4272 if (var->expr == NULL)
4273 t = traverse_data_list (var, where);
4275 t = check_data_variable (var, where);
4285 /* Resolve the expressions and iterators associated with a data statement.
4286 This is separate from the assignment checking because data lists should
4287 only be resolved once. */
4290 resolve_data_variables (gfc_data_variable * d)
4292 for (; d; d = d->next)
4294 if (d->list == NULL)
4296 if (gfc_resolve_expr (d->expr) == FAILURE)
4301 if (gfc_resolve_iterator (&d->iter) == FAILURE)
4304 if (d->iter.start->expr_type != EXPR_CONSTANT
4305 || d->iter.end->expr_type != EXPR_CONSTANT
4306 || d->iter.step->expr_type != EXPR_CONSTANT)
4307 gfc_internal_error ("resolve_data_variables(): Bad iterator");
4309 if (resolve_data_variables (d->list) == FAILURE)
4318 /* Resolve a single DATA statement. We implement this by storing a pointer to
4319 the value list into static variables, and then recursively traversing the
4320 variables list, expanding iterators and such. */
4323 resolve_data (gfc_data * d)
4325 if (resolve_data_variables (d->var) == FAILURE)
4328 values.vnode = d->value;
4329 values.left = (d->value == NULL) ? 0 : d->value->repeat;
4331 if (traverse_data_var (d->var, &d->where) == FAILURE)
4334 /* At this point, we better not have any values left. */
4336 if (next_data_value () == SUCCESS)
4337 gfc_error ("DATA statement at %L has more values than variables",
4342 /* Determines if a variable is not 'pure', ie not assignable within a pure
4343 procedure. Returns zero if assignment is OK, nonzero if there is a problem.
4347 gfc_impure_variable (gfc_symbol * sym)
4349 if (sym->attr.use_assoc || sym->attr.in_common)
4352 if (sym->ns != gfc_current_ns)
4353 return !sym->attr.function;
4355 /* TODO: Check storage association through EQUIVALENCE statements */
4361 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
4362 symbol of the current procedure. */
4365 gfc_pure (gfc_symbol * sym)
4367 symbol_attribute attr;
4370 sym = gfc_current_ns->proc_name;
4376 return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental);
4380 /* Test whether the current procedure is elemental or not. */
4383 gfc_elemental (gfc_symbol * sym)
4385 symbol_attribute attr;
4388 sym = gfc_current_ns->proc_name;
4393 return attr.flavor == FL_PROCEDURE && attr.elemental;
4397 /* Warn about unused labels. */
4400 warn_unused_label (gfc_namespace * ns)
4411 for (; l; l = l->prev)
4413 if (l->defined == ST_LABEL_UNKNOWN)
4416 switch (l->referenced)
4418 case ST_LABEL_UNKNOWN:
4419 gfc_warning ("Label %d at %L defined but not used", l->value,
4423 case ST_LABEL_BAD_TARGET:
4424 gfc_warning ("Label %d at %L defined but cannot be used", l->value,
4435 /* Resolve derived type EQUIVALENCE object. */
4438 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
4441 gfc_component *c = derived->components;
4446 /* Shall not be an object of nonsequence derived type. */
4447 if (!derived->attr.sequence)
4449 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
4450 "attribute to be an EQUIVALENCE object", sym->name, &e->where);
4454 for (; c ; c = c->next)
4457 if (d && (resolve_equivalence_derived (c->ts.derived, sym, e) == FAILURE))
4460 /* Shall not be an object of sequence derived type containing a pointer
4461 in the structure. */
4464 gfc_error ("Derived type variable '%s' at %L has pointer componet(s) "
4465 "cannot be an EQUIVALENCE object", sym->name, &e->where);
4473 /* Resolve equivalence object.
4474 An EQUIVALENCE object shall not be a dummy argument, a pointer, an
4475 allocatable array, an object of nonsequence derived type, an object of
4476 sequence derived type containing a pointer at any level of component
4477 selection, an automatic object, a function name, an entry name, a result
4478 name, a named constant, a structure component, or a subobject of any of
4479 the preceding objects. */
4482 resolve_equivalence (gfc_equiv *eq)
4485 gfc_symbol *derived;
4489 for (; eq; eq = eq->eq)
4492 if (gfc_resolve_expr (e) == FAILURE)
4495 sym = e->symtree->n.sym;
4497 /* Shall not be a dummy argument. */
4498 if (sym->attr.dummy)
4500 gfc_error ("Dummy argument '%s' at %L cannot be an EQUIVALENCE "
4501 "object", sym->name, &e->where);
4505 /* Shall not be an allocatable array. */
4506 if (sym->attr.allocatable)
4508 gfc_error ("Allocatable array '%s' at %L cannot be an EQUIVALENCE "
4509 "object", sym->name, &e->where);
4513 /* Shall not be a pointer. */
4514 if (sym->attr.pointer)
4516 gfc_error ("Pointer '%s' at %L cannot be an EQUIVALENCE object",
4517 sym->name, &e->where);
4521 /* Shall not be a function name, ... */
4522 if (sym->attr.function || sym->attr.result || sym->attr.entry
4523 || sym->attr.subroutine)
4525 gfc_error ("Entity '%s' at %L cannot be an EQUIVALENCE object",
4526 sym->name, &e->where);
4530 /* Shall not be a named constant. */
4531 if (e->expr_type == EXPR_CONSTANT)
4533 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
4534 "object", sym->name, &e->where);
4538 derived = e->ts.derived;
4539 if (derived && resolve_equivalence_derived (derived, sym, e) == FAILURE)
4545 /* Shall not be an automatic array. */
4546 if (e->ref->type == REF_ARRAY
4547 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
4549 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
4550 "an EQUIVALENCE object", sym->name, &e->where);
4554 /* Shall not be a structure component. */
4558 if (r->type == REF_COMPONENT)
4560 gfc_error ("Structure component '%s' at %L cannot be an "
4561 "EQUIVALENCE object",
4562 r->u.c.component->name, &e->where);
4571 /* This function is called after a complete program unit has been compiled.
4572 Its purpose is to examine all of the expressions associated with a program
4573 unit, assign types to all intermediate expressions, make sure that all
4574 assignments are to compatible types and figure out which names refer to
4575 which functions or subroutines. */
4578 gfc_resolve (gfc_namespace * ns)
4580 gfc_namespace *old_ns, *n;
4585 old_ns = gfc_current_ns;
4586 gfc_current_ns = ns;
4588 resolve_entries (ns);
4590 resolve_contained_functions (ns);
4592 gfc_traverse_ns (ns, resolve_symbol);
4594 for (n = ns->contained; n; n = n->sibling)
4596 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
4597 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
4598 "also be PURE", n->proc_name->name,
4599 &n->proc_name->declared_at);
4605 gfc_check_interfaces (ns);
4607 for (cl = ns->cl_list; cl; cl = cl->next)
4609 if (cl->length == NULL || gfc_resolve_expr (cl->length) == FAILURE)
4612 if (cl->length->ts.type != BT_INTEGER)
4614 ("Character length specification at %L must be of type INTEGER",
4615 &cl->length->where);
4618 gfc_traverse_ns (ns, resolve_values);
4624 for (d = ns->data; d; d = d->next)
4628 gfc_traverse_ns (ns, gfc_formalize_init_value);
4630 for (eq = ns->equiv; eq; eq = eq->next)
4631 resolve_equivalence (eq);
4634 resolve_code (ns->code, ns);
4636 /* Warn about unused labels. */
4637 if (gfc_option.warn_unused_labels)
4638 warn_unused_label (ns);
4640 gfc_current_ns = old_ns;