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(). */
27 /* Stack to push the current if we descend into a block during
28 resolution. See resolve_branch() and resolve_code(). */
30 typedef struct code_stack
32 struct gfc_code *head, *current;
33 struct code_stack *prev;
37 static code_stack *cs_base = NULL;
40 /* Nonzero if we're inside a FORALL block */
42 static int forall_flag;
44 /* Resolve types of formal argument lists. These have to be done early so that
45 the formal argument lists of module procedures can be copied to the
46 containing module before the individual procedures are resolved
47 individually. We also resolve argument lists of procedures in interface
48 blocks because they are self-contained scoping units.
50 Since a dummy argument cannot be a non-dummy procedure, the only
51 resort left for untyped names are the IMPLICIT types. */
54 resolve_formal_arglist (gfc_symbol * proc)
56 gfc_formal_arglist *f;
60 /* TODO: Procedures whose return character length parameter is not constant
61 or assumed must also have explicit interfaces. */
62 if (proc->result != NULL)
67 if (gfc_elemental (proc)
68 || sym->attr.pointer || sym->attr.allocatable
69 || (sym->as && sym->as->rank > 0))
70 proc->attr.always_explicit = 1;
72 for (f = proc->formal; f; f = f->next)
78 /* Alternate return placeholder. */
79 if (gfc_elemental (proc))
80 gfc_error ("Alternate return specifier in elemental subroutine "
81 "'%s' at %L is not allowed", proc->name,
83 if (proc->attr.function)
84 gfc_error ("Alternate return specifier in function "
85 "'%s' at %L is not allowed", proc->name,
90 if (sym->attr.if_source != IFSRC_UNKNOWN)
91 resolve_formal_arglist (sym);
93 if (sym->attr.subroutine || sym->attr.external || sym->attr.intrinsic)
95 if (gfc_pure (proc) && !gfc_pure (sym))
98 ("Dummy procedure '%s' of PURE procedure at %L must also "
99 "be PURE", sym->name, &sym->declared_at);
103 if (gfc_elemental (proc))
106 ("Dummy procedure at %L not allowed in ELEMENTAL procedure",
114 if (sym->ts.type == BT_UNKNOWN)
116 if (!sym->attr.function || sym->result == sym)
117 gfc_set_default_type (sym, 1, sym->ns);
120 /* Set the type of the RESULT, then copy. */
121 if (sym->result->ts.type == BT_UNKNOWN)
122 gfc_set_default_type (sym->result, 1, sym->result->ns);
124 sym->ts = sym->result->ts;
126 sym->as = gfc_copy_array_spec (sym->result->as);
130 gfc_resolve_array_spec (sym->as, 0);
132 /* We can't tell if an array with dimension (:) is assumed or deferred
133 shape until we know if it has the pointer or allocatable attributes.
135 if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
136 && !(sym->attr.pointer || sym->attr.allocatable))
138 sym->as->type = AS_ASSUMED_SHAPE;
139 for (i = 0; i < sym->as->rank; i++)
140 sym->as->lower[i] = gfc_int_expr (1);
143 if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
144 || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
145 || sym->attr.optional)
146 proc->attr.always_explicit = 1;
148 /* If the flavor is unknown at this point, it has to be a variable.
149 A procedure specification would have already set the type. */
151 if (sym->attr.flavor == FL_UNKNOWN)
152 gfc_add_flavor (&sym->attr, FL_VARIABLE, &sym->declared_at);
156 if (proc->attr.function && !sym->attr.pointer
157 && sym->attr.flavor != FL_PROCEDURE
158 && sym->attr.intent != INTENT_IN)
160 gfc_error ("Argument '%s' of pure function '%s' at %L must be "
161 "INTENT(IN)", sym->name, proc->name,
164 if (proc->attr.subroutine && !sym->attr.pointer
165 && sym->attr.intent == INTENT_UNKNOWN)
168 ("Argument '%s' of pure subroutine '%s' at %L must have "
169 "its INTENT specified", sym->name, proc->name,
174 if (gfc_elemental (proc))
179 ("Argument '%s' of elemental procedure at %L must be scalar",
180 sym->name, &sym->declared_at);
184 if (sym->attr.pointer)
187 ("Argument '%s' of elemental procedure at %L cannot have "
188 "the POINTER attribute", sym->name, &sym->declared_at);
193 /* Each dummy shall be specified to be scalar. */
194 if (proc->attr.proc == PROC_ST_FUNCTION)
199 ("Argument '%s' of statement function at %L must be scalar",
200 sym->name, &sym->declared_at);
204 if (sym->ts.type == BT_CHARACTER)
206 gfc_charlen *cl = sym->ts.cl;
207 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
210 ("Character-valued argument '%s' of statement function at "
211 "%L must has constant length",
212 sym->name, &sym->declared_at);
221 /* Work function called when searching for symbols that have argument lists
222 associated with them. */
225 find_arglists (gfc_symbol * sym)
228 if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
231 resolve_formal_arglist (sym);
235 /* Given a namespace, resolve all formal argument lists within the namespace.
239 resolve_formal_arglists (gfc_namespace * ns)
245 gfc_traverse_ns (ns, find_arglists);
250 resolve_contained_fntype (gfc_symbol * sym, gfc_namespace * ns)
254 /* If this namespace is not a function, ignore it. */
256 || !(sym->attr.function
257 || sym->attr.flavor == FL_VARIABLE))
260 /* Try to find out of what type the function is. If there was an
261 explicit RESULT clause, try to get the type from it. If the
262 function is never defined, set it to the implicit type. If
263 even that fails, give up. */
264 if (sym->result != NULL)
267 if (sym->ts.type == BT_UNKNOWN)
269 /* Assume we can find an implicit type. */
272 if (sym->result == NULL)
273 t = gfc_set_default_type (sym, 0, ns);
276 if (sym->result->ts.type == BT_UNKNOWN)
277 t = gfc_set_default_type (sym->result, 0, NULL);
279 sym->ts = sym->result->ts;
283 gfc_error ("Contained function '%s' at %L has no IMPLICIT type",
284 sym->name, &sym->declared_at); /* FIXME */
289 /* Add NEW_ARGS to the formal argument list of PROC, taking care not to
290 introduce duplicates. */
293 merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
295 gfc_formal_arglist *f, *new_arglist;
298 for (; new_args != NULL; new_args = new_args->next)
300 new_sym = new_args->sym;
301 /* See if ths arg is already in the formal argument list. */
302 for (f = proc->formal; f; f = f->next)
304 if (new_sym == f->sym)
311 /* Add a new argument. Argument order is not important. */
312 new_arglist = gfc_get_formal_arglist ();
313 new_arglist->sym = new_sym;
314 new_arglist->next = proc->formal;
315 proc->formal = new_arglist;
320 /* Resolve alternate entry points. If a symbol has multiple entry points we
321 create a new master symbol for the main routine, and turn the existing
322 symbol into an entry point. */
325 resolve_entries (gfc_namespace * ns)
327 gfc_namespace *old_ns;
331 char name[GFC_MAX_SYMBOL_LEN + 1];
332 static int master_count = 0;
334 if (ns->proc_name == NULL)
337 /* No need to do anything if this procedure doesn't have alternate entry
342 /* We may already have resolved alternate entry points. */
343 if (ns->proc_name->attr.entry_master)
346 /* If this isn't a procedure something has gone horribly wrong. */
347 gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE);
349 /* Remember the current namespace. */
350 old_ns = gfc_current_ns;
354 /* Add the main entry point to the list of entry points. */
355 el = gfc_get_entry_list ();
356 el->sym = ns->proc_name;
358 el->next = ns->entries;
360 ns->proc_name->attr.entry = 1;
362 /* Add an entry statement for it. */
369 /* Create a new symbol for the master function. */
370 /* Give the internal function a unique name (within this file).
371 Also include the function name so the user has some hope of figuring
372 out what is going on. */
373 snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
374 master_count++, ns->proc_name->name);
375 name[GFC_MAX_SYMBOL_LEN] = '\0';
376 gfc_get_ha_symbol (name, &proc);
377 gcc_assert (proc != NULL);
379 gfc_add_procedure (&proc->attr, PROC_INTERNAL, NULL);
380 if (ns->proc_name->attr.subroutine)
381 gfc_add_subroutine (&proc->attr, NULL);
384 gfc_add_function (&proc->attr, NULL);
385 gfc_internal_error ("TODO: Functions with alternate entry points");
387 proc->attr.access = ACCESS_PRIVATE;
388 proc->attr.entry_master = 1;
390 /* Merge all the entry point arguments. */
391 for (el = ns->entries; el; el = el->next)
392 merge_argument_lists (proc, el->sym->formal);
394 /* Use the master function for the function body. */
395 ns->proc_name = proc;
397 /* Finalize the new symbols. */
398 gfc_commit_symbols ();
400 /* Restore the original namespace. */
401 gfc_current_ns = old_ns;
405 /* Resolve contained function types. Because contained functions can call one
406 another, they have to be worked out before any of the contained procedures
409 The good news is that if a function doesn't already have a type, the only
410 way it can get one is through an IMPLICIT type or a RESULT variable, because
411 by definition contained functions are contained namespace they're contained
412 in, not in a sibling or parent namespace. */
415 resolve_contained_functions (gfc_namespace * ns)
417 gfc_namespace *child;
420 resolve_formal_arglists (ns);
422 for (child = ns->contained; child; child = child->sibling)
424 /* Resolve alternate entry points first. */
425 resolve_entries (child);
427 /* Then check function return types. */
428 resolve_contained_fntype (child->proc_name, child);
429 for (el = child->entries; el; el = el->next)
430 resolve_contained_fntype (el->sym, child);
435 /* Resolve all of the elements of a structure constructor and make sure that
436 the types are correct. */
439 resolve_structure_cons (gfc_expr * expr)
441 gfc_constructor *cons;
446 cons = expr->value.constructor;
447 /* A constructor may have references if it is the result of substituting a
448 parameter variable. In this case we just pull out the component we
451 comp = expr->ref->u.c.sym->components;
453 comp = expr->ts.derived->components;
455 for (; comp; comp = comp->next, cons = cons->next)
463 if (gfc_resolve_expr (cons->expr) == FAILURE)
469 /* If we don't have the right type, try to convert it. */
471 if (!gfc_compare_types (&cons->expr->ts, &comp->ts)
472 && gfc_convert_type (cons->expr, &comp->ts, 1) == FAILURE)
481 /****************** Expression name resolution ******************/
483 /* Returns 0 if a symbol was not declared with a type or
484 attribute declaration statement, nonzero otherwise. */
487 was_declared (gfc_symbol * sym)
493 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN)
496 if (a.allocatable || a.dimension || a.external || a.intrinsic
497 || a.optional || a.pointer || a.save || a.target
498 || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
505 /* Determine if a symbol is generic or not. */
508 generic_sym (gfc_symbol * sym)
512 if (sym->attr.generic ||
513 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name)))
516 if (was_declared (sym) || sym->ns->parent == NULL)
519 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
521 return (s == NULL) ? 0 : generic_sym (s);
525 /* Determine if a symbol is specific or not. */
528 specific_sym (gfc_symbol * sym)
532 if (sym->attr.if_source == IFSRC_IFBODY
533 || sym->attr.proc == PROC_MODULE
534 || sym->attr.proc == PROC_INTERNAL
535 || sym->attr.proc == PROC_ST_FUNCTION
536 || (sym->attr.intrinsic &&
537 gfc_specific_intrinsic (sym->name))
538 || sym->attr.external)
541 if (was_declared (sym) || sym->ns->parent == NULL)
544 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s);
546 return (s == NULL) ? 0 : specific_sym (s);
550 /* Figure out if the procedure is specific, generic or unknown. */
553 { PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }
557 procedure_kind (gfc_symbol * sym)
560 if (generic_sym (sym))
561 return PTYPE_GENERIC;
563 if (specific_sym (sym))
564 return PTYPE_SPECIFIC;
566 return PTYPE_UNKNOWN;
570 /* Resolve an actual argument list. Most of the time, this is just
571 resolving the expressions in the list.
572 The exception is that we sometimes have to decide whether arguments
573 that look like procedure arguments are really simple variable
577 resolve_actual_arglist (gfc_actual_arglist * arg)
580 gfc_symtree *parent_st;
583 for (; arg; arg = arg->next)
589 /* Check the label is a valid branching target. */
592 if (arg->label->defined == ST_LABEL_UNKNOWN)
594 gfc_error ("Label %d referenced at %L is never defined",
595 arg->label->value, &arg->label->where);
602 if (e->ts.type != BT_PROCEDURE)
604 if (gfc_resolve_expr (e) != SUCCESS)
609 /* See if the expression node should really be a variable
612 sym = e->symtree->n.sym;
614 if (sym->attr.flavor == FL_PROCEDURE
615 || sym->attr.intrinsic
616 || sym->attr.external)
619 /* If the symbol is the function that names the current (or
620 parent) scope, then we really have a variable reference. */
622 if (sym->attr.function && sym->result == sym
623 && (sym->ns->proc_name == sym
624 || (sym->ns->parent != NULL
625 && sym->ns->parent->proc_name == sym)))
631 /* See if the name is a module procedure in a parent unit. */
633 if (was_declared (sym) || sym->ns->parent == NULL)
636 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
638 gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
642 if (parent_st == NULL)
645 sym = parent_st->n.sym;
646 e->symtree = parent_st; /* Point to the right thing. */
648 if (sym->attr.flavor == FL_PROCEDURE
649 || sym->attr.intrinsic
650 || sym->attr.external)
656 e->expr_type = EXPR_VARIABLE;
660 e->rank = sym->as->rank;
661 e->ref = gfc_get_ref ();
662 e->ref->type = REF_ARRAY;
663 e->ref->u.ar.type = AR_FULL;
664 e->ref->u.ar.as = sym->as;
672 /************* Function resolution *************/
674 /* Resolve a function call known to be generic.
675 Section 14.1.2.4.1. */
678 resolve_generic_f0 (gfc_expr * expr, gfc_symbol * sym)
682 if (sym->attr.generic)
685 gfc_search_interface (sym->generic, 0, &expr->value.function.actual);
688 expr->value.function.name = s->name;
689 expr->value.function.esym = s;
692 expr->rank = s->as->rank;
696 /* TODO: Need to search for elemental references in generic interface */
699 if (sym->attr.intrinsic)
700 return gfc_intrinsic_func_interface (expr, 0);
707 resolve_generic_f (gfc_expr * expr)
712 sym = expr->symtree->n.sym;
716 m = resolve_generic_f0 (expr, sym);
719 else if (m == MATCH_ERROR)
723 if (sym->ns->parent == NULL)
725 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
729 if (!generic_sym (sym))
733 /* Last ditch attempt. */
735 if (!gfc_generic_intrinsic (expr->symtree->n.sym->name))
737 gfc_error ("Generic function '%s' at %L is not an intrinsic function",
738 expr->symtree->n.sym->name, &expr->where);
742 m = gfc_intrinsic_func_interface (expr, 0);
747 ("Generic function '%s' at %L is not consistent with a specific "
748 "intrinsic interface", expr->symtree->n.sym->name, &expr->where);
754 /* Resolve a function call known to be specific. */
757 resolve_specific_f0 (gfc_symbol * sym, gfc_expr * expr)
761 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
765 sym->attr.proc = PROC_DUMMY;
769 sym->attr.proc = PROC_EXTERNAL;
773 if (sym->attr.proc == PROC_MODULE
774 || sym->attr.proc == PROC_ST_FUNCTION
775 || sym->attr.proc == PROC_INTERNAL)
778 if (sym->attr.intrinsic)
780 m = gfc_intrinsic_func_interface (expr, 1);
785 ("Function '%s' at %L is INTRINSIC but is not compatible with "
786 "an intrinsic", sym->name, &expr->where);
794 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
797 expr->value.function.name = sym->name;
798 expr->value.function.esym = sym;
800 expr->rank = sym->as->rank;
807 resolve_specific_f (gfc_expr * expr)
812 sym = expr->symtree->n.sym;
816 m = resolve_specific_f0 (sym, expr);
819 if (m == MATCH_ERROR)
822 if (sym->ns->parent == NULL)
825 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
831 gfc_error ("Unable to resolve the specific function '%s' at %L",
832 expr->symtree->n.sym->name, &expr->where);
838 /* Resolve a procedure call not known to be generic nor specific. */
841 resolve_unknown_f (gfc_expr * expr)
846 sym = expr->symtree->n.sym;
850 sym->attr.proc = PROC_DUMMY;
851 expr->value.function.name = sym->name;
855 /* See if we have an intrinsic function reference. */
857 if (gfc_intrinsic_name (sym->name, 0))
859 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES)
864 /* The reference is to an external name. */
866 sym->attr.proc = PROC_EXTERNAL;
867 expr->value.function.name = sym->name;
868 expr->value.function.esym = expr->symtree->n.sym;
871 expr->rank = sym->as->rank;
873 /* Type of the expression is either the type of the symbol or the
874 default type of the symbol. */
877 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where);
879 if (sym->ts.type != BT_UNKNOWN)
883 ts = gfc_get_default_type (sym, sym->ns);
885 if (ts->type == BT_UNKNOWN)
887 gfc_error ("Function '%s' at %L has no implicit type",
888 sym->name, &expr->where);
899 /* Figure out if if a function reference is pure or not. Also sets the name
900 of the function for a potential error message. Returns nonzero if the
901 function is PURE, zero if not. */
904 pure_function (gfc_expr * e, char **name)
908 if (e->value.function.esym)
910 pure = gfc_pure (e->value.function.esym);
911 *name = e->value.function.esym->name;
913 else if (e->value.function.isym)
915 pure = e->value.function.isym->pure
916 || e->value.function.isym->elemental;
917 *name = e->value.function.isym->name;
921 /* Implicit functions are not pure. */
923 *name = e->value.function.name;
930 /* Resolve a function call, which means resolving the arguments, then figuring
931 out which entity the name refers to. */
932 /* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
933 to INTENT(OUT) or INTENT(INOUT). */
936 resolve_function (gfc_expr * expr)
938 gfc_actual_arglist *arg;
942 if (resolve_actual_arglist (expr->value.function.actual) == FAILURE)
945 /* See if function is already resolved. */
947 if (expr->value.function.name != NULL)
949 if (expr->ts.type == BT_UNKNOWN)
950 expr->ts = expr->symtree->n.sym->ts;
955 /* Apply the rules of section 14.1.2. */
957 switch (procedure_kind (expr->symtree->n.sym))
960 t = resolve_generic_f (expr);
964 t = resolve_specific_f (expr);
968 t = resolve_unknown_f (expr);
972 gfc_internal_error ("resolve_function(): bad function type");
976 /* If the expression is still a function (it might have simplified),
977 then we check to see if we are calling an elemental function. */
979 if (expr->expr_type != EXPR_FUNCTION)
982 if (expr->value.function.actual != NULL
983 && ((expr->value.function.esym != NULL
984 && expr->value.function.esym->attr.elemental)
985 || (expr->value.function.isym != NULL
986 && expr->value.function.isym->elemental)))
989 /* The rank of an elemental is the rank of its array argument(s). */
991 for (arg = expr->value.function.actual; arg; arg = arg->next)
993 if (arg->expr != NULL && arg->expr->rank > 0)
995 expr->rank = arg->expr->rank;
1001 if (!pure_function (expr, &name))
1006 ("Function reference to '%s' at %L is inside a FORALL block",
1007 name, &expr->where);
1010 else if (gfc_pure (NULL))
1012 gfc_error ("Function reference to '%s' at %L is to a non-PURE "
1013 "procedure within a PURE procedure", name, &expr->where);
1022 /************* Subroutine resolution *************/
1025 pure_subroutine (gfc_code * c, gfc_symbol * sym)
1032 gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE",
1033 sym->name, &c->loc);
1034 else if (gfc_pure (NULL))
1035 gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name,
1041 resolve_generic_s0 (gfc_code * c, gfc_symbol * sym)
1045 if (sym->attr.generic)
1047 s = gfc_search_interface (sym->generic, 1, &c->ext.actual);
1050 c->resolved_sym = s;
1051 pure_subroutine (c, s);
1055 /* TODO: Need to search for elemental references in generic interface. */
1058 if (sym->attr.intrinsic)
1059 return gfc_intrinsic_sub_interface (c, 0);
1066 resolve_generic_s (gfc_code * c)
1071 sym = c->symtree->n.sym;
1073 m = resolve_generic_s0 (c, sym);
1076 if (m == MATCH_ERROR)
1079 if (sym->ns->parent != NULL)
1081 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1084 m = resolve_generic_s0 (c, sym);
1087 if (m == MATCH_ERROR)
1092 /* Last ditch attempt. */
1094 if (!gfc_generic_intrinsic (sym->name))
1097 ("Generic subroutine '%s' at %L is not an intrinsic subroutine",
1098 sym->name, &c->loc);
1102 m = gfc_intrinsic_sub_interface (c, 0);
1106 gfc_error ("Generic subroutine '%s' at %L is not consistent with an "
1107 "intrinsic subroutine interface", sym->name, &c->loc);
1113 /* Resolve a subroutine call known to be specific. */
1116 resolve_specific_s0 (gfc_code * c, gfc_symbol * sym)
1120 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
1122 if (sym->attr.dummy)
1124 sym->attr.proc = PROC_DUMMY;
1128 sym->attr.proc = PROC_EXTERNAL;
1132 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL)
1135 if (sym->attr.intrinsic)
1137 m = gfc_intrinsic_sub_interface (c, 1);
1141 gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible "
1142 "with an intrinsic", sym->name, &c->loc);
1150 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
1152 c->resolved_sym = sym;
1153 pure_subroutine (c, sym);
1160 resolve_specific_s (gfc_code * c)
1165 sym = c->symtree->n.sym;
1167 m = resolve_specific_s0 (c, sym);
1170 if (m == MATCH_ERROR)
1173 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
1177 m = resolve_specific_s0 (c, sym);
1180 if (m == MATCH_ERROR)
1184 gfc_error ("Unable to resolve the specific subroutine '%s' at %L",
1185 sym->name, &c->loc);
1191 /* Resolve a subroutine call not known to be generic nor specific. */
1194 resolve_unknown_s (gfc_code * c)
1198 sym = c->symtree->n.sym;
1200 if (sym->attr.dummy)
1202 sym->attr.proc = PROC_DUMMY;
1206 /* See if we have an intrinsic function reference. */
1208 if (gfc_intrinsic_name (sym->name, 1))
1210 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES)
1215 /* The reference is to an external name. */
1218 gfc_procedure_use (sym, &c->ext.actual, &c->loc);
1220 c->resolved_sym = sym;
1222 pure_subroutine (c, sym);
1228 /* Resolve a subroutine call. Although it was tempting to use the same code
1229 for functions, subroutines and functions are stored differently and this
1230 makes things awkward. */
1233 resolve_call (gfc_code * c)
1237 if (resolve_actual_arglist (c->ext.actual) == FAILURE)
1240 if (c->resolved_sym != NULL)
1243 switch (procedure_kind (c->symtree->n.sym))
1246 t = resolve_generic_s (c);
1249 case PTYPE_SPECIFIC:
1250 t = resolve_specific_s (c);
1254 t = resolve_unknown_s (c);
1258 gfc_internal_error ("resolve_subroutine(): bad function type");
1265 /* Resolve an operator expression node. This can involve replacing the
1266 operation with a user defined function call. */
1269 resolve_operator (gfc_expr * e)
1271 gfc_expr *op1, *op2;
1275 /* Resolve all subnodes-- give them types. */
1277 switch (e->operator)
1280 if (gfc_resolve_expr (e->op2) == FAILURE)
1283 /* Fall through... */
1286 case INTRINSIC_UPLUS:
1287 case INTRINSIC_UMINUS:
1288 if (gfc_resolve_expr (e->op1) == FAILURE)
1293 /* Typecheck the new node. */
1298 switch (e->operator)
1300 case INTRINSIC_UPLUS:
1301 case INTRINSIC_UMINUS:
1302 if (op1->ts.type == BT_INTEGER
1303 || op1->ts.type == BT_REAL
1304 || op1->ts.type == BT_COMPLEX)
1310 sprintf (msg, "Operand of unary numeric operator '%s' at %%L is %s",
1311 gfc_op2string (e->operator), gfc_typename (&e->ts));
1314 case INTRINSIC_PLUS:
1315 case INTRINSIC_MINUS:
1316 case INTRINSIC_TIMES:
1317 case INTRINSIC_DIVIDE:
1318 case INTRINSIC_POWER:
1319 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
1321 gfc_type_convert_binary (e);
1326 "Operands of binary numeric operator '%s' at %%L are %s/%s",
1327 gfc_op2string (e->operator), gfc_typename (&op1->ts),
1328 gfc_typename (&op2->ts));
1331 case INTRINSIC_CONCAT:
1332 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1334 e->ts.type = BT_CHARACTER;
1335 e->ts.kind = op1->ts.kind;
1340 "Operands of string concatenation operator at %%L are %s/%s",
1341 gfc_typename (&op1->ts), gfc_typename (&op2->ts));
1347 case INTRINSIC_NEQV:
1348 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
1350 e->ts.type = BT_LOGICAL;
1351 e->ts.kind = gfc_kind_max (op1, op2);
1352 if (op1->ts.kind < e->ts.kind)
1353 gfc_convert_type (op1, &e->ts, 2);
1354 else if (op2->ts.kind < e->ts.kind)
1355 gfc_convert_type (op2, &e->ts, 2);
1359 sprintf (msg, "Operands of logical operator '%s' at %%L are %s/%s",
1360 gfc_op2string (e->operator), gfc_typename (&op1->ts),
1361 gfc_typename (&op2->ts));
1366 if (op1->ts.type == BT_LOGICAL)
1368 e->ts.type = BT_LOGICAL;
1369 e->ts.kind = op1->ts.kind;
1373 sprintf (msg, "Operand of .NOT. operator at %%L is %s",
1374 gfc_typename (&op1->ts));
1381 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
1383 strcpy (msg, "COMPLEX quantities cannot be compared at %L");
1387 /* Fall through... */
1391 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
1393 e->ts.type = BT_LOGICAL;
1394 e->ts.kind = gfc_default_logical_kind;
1398 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))
1400 gfc_type_convert_binary (e);
1402 e->ts.type = BT_LOGICAL;
1403 e->ts.kind = gfc_default_logical_kind;
1407 sprintf (msg, "Operands of comparison operator '%s' at %%L are %s/%s",
1408 gfc_op2string (e->operator), gfc_typename (&op1->ts),
1409 gfc_typename (&op2->ts));
1413 case INTRINSIC_USER:
1415 sprintf (msg, "Operand of user operator '%s' at %%L is %s",
1416 e->uop->name, gfc_typename (&op1->ts));
1418 sprintf (msg, "Operands of user operator '%s' at %%L are %s/%s",
1419 e->uop->name, gfc_typename (&op1->ts),
1420 gfc_typename (&op2->ts));
1425 gfc_internal_error ("resolve_operator(): Bad intrinsic");
1428 /* Deal with arrayness of an operand through an operator. */
1432 switch (e->operator)
1434 case INTRINSIC_PLUS:
1435 case INTRINSIC_MINUS:
1436 case INTRINSIC_TIMES:
1437 case INTRINSIC_DIVIDE:
1438 case INTRINSIC_POWER:
1439 case INTRINSIC_CONCAT:
1443 case INTRINSIC_NEQV:
1451 if (op1->rank == 0 && op2->rank == 0)
1454 if (op1->rank == 0 && op2->rank != 0)
1456 e->rank = op2->rank;
1458 if (e->shape == NULL)
1459 e->shape = gfc_copy_shape (op2->shape, op2->rank);
1462 if (op1->rank != 0 && op2->rank == 0)
1464 e->rank = op1->rank;
1466 if (e->shape == NULL)
1467 e->shape = gfc_copy_shape (op1->shape, op1->rank);
1470 if (op1->rank != 0 && op2->rank != 0)
1472 if (op1->rank == op2->rank)
1474 e->rank = op1->rank;
1476 if (e->shape == NULL)
1477 e->shape = gfc_copy_shape (op1->shape, op1->rank);
1482 gfc_error ("Inconsistent ranks for operator at %L and %L",
1483 &op1->where, &op2->where);
1486 /* Allow higher level expressions to work. */
1494 case INTRINSIC_UPLUS:
1495 case INTRINSIC_UMINUS:
1496 e->rank = op1->rank;
1498 if (e->shape == NULL)
1499 e->shape = gfc_copy_shape (op1->shape, op1->rank);
1501 /* Simply copy arrayness attribute */
1508 /* Attempt to simplify the expression. */
1510 t = gfc_simplify_expr (e, 0);
1514 if (gfc_extend_expr (e) == SUCCESS)
1517 gfc_error (msg, &e->where);
1522 /************** Array resolution subroutines **************/
1526 { CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }
1529 /* Compare two integer expressions. */
1532 compare_bound (gfc_expr * a, gfc_expr * b)
1536 if (a == NULL || a->expr_type != EXPR_CONSTANT
1537 || b == NULL || b->expr_type != EXPR_CONSTANT)
1540 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER)
1541 gfc_internal_error ("compare_bound(): Bad expression");
1543 i = mpz_cmp (a->value.integer, b->value.integer);
1553 /* Compare an integer expression with an integer. */
1556 compare_bound_int (gfc_expr * a, int b)
1560 if (a == NULL || a->expr_type != EXPR_CONSTANT)
1563 if (a->ts.type != BT_INTEGER)
1564 gfc_internal_error ("compare_bound_int(): Bad expression");
1566 i = mpz_cmp_si (a->value.integer, b);
1576 /* Compare a single dimension of an array reference to the array
1580 check_dimension (int i, gfc_array_ref * ar, gfc_array_spec * as)
1583 /* Given start, end and stride values, calculate the minimum and
1584 maximum referenced indexes. */
1592 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
1594 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
1600 if (compare_bound_int (ar->stride[i], 0) == CMP_EQ)
1602 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]);
1606 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
1608 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT)
1611 /* TODO: Possibly, we could warn about end[i] being out-of-bound although
1612 it is legal (see 6.2.2.3.1). */
1617 gfc_internal_error ("check_dimension(): Bad array reference");
1623 gfc_warning ("Array reference at %L is out of bounds", &ar->c_where[i]);
1628 /* Compare an array reference with an array specification. */
1631 compare_spec_to_ref (gfc_array_ref * ar)
1638 /* TODO: Full array sections are only allowed as actual parameters. */
1639 if (as->type == AS_ASSUMED_SIZE
1640 && (/*ar->type == AR_FULL
1641 ||*/ (ar->type == AR_SECTION
1642 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL)))
1644 gfc_error ("Rightmost upper bound of assumed size array section"
1645 " not specified at %L", &ar->where);
1649 if (ar->type == AR_FULL)
1652 if (as->rank != ar->dimen)
1654 gfc_error ("Rank mismatch in array reference at %L (%d/%d)",
1655 &ar->where, ar->dimen, as->rank);
1659 for (i = 0; i < as->rank; i++)
1660 if (check_dimension (i, ar, as) == FAILURE)
1667 /* Resolve one part of an array index. */
1670 gfc_resolve_index (gfc_expr * index, int check_scalar)
1677 if (gfc_resolve_expr (index) == FAILURE)
1680 if (index->ts.type != BT_INTEGER)
1682 gfc_error ("Array index at %L must be of INTEGER type", &index->where);
1686 if (check_scalar && index->rank != 0)
1688 gfc_error ("Array index at %L must be scalar", &index->where);
1692 if (index->ts.kind != gfc_index_integer_kind)
1694 ts.type = BT_INTEGER;
1695 ts.kind = gfc_index_integer_kind;
1697 gfc_convert_type_warn (index, &ts, 2, 0);
1704 /* Given an expression that contains array references, update those array
1705 references to point to the right array specifications. While this is
1706 filled in during matching, this information is difficult to save and load
1707 in a module, so we take care of it here.
1709 The idea here is that the original array reference comes from the
1710 base symbol. We traverse the list of reference structures, setting
1711 the stored reference to references. Component references can
1712 provide an additional array specification. */
1715 find_array_spec (gfc_expr * e)
1721 as = e->symtree->n.sym->as;
1722 c = e->symtree->n.sym->components;
1724 for (ref = e->ref; ref; ref = ref->next)
1729 gfc_internal_error ("find_array_spec(): Missing spec");
1736 for (; c; c = c->next)
1737 if (c == ref->u.c.component)
1741 gfc_internal_error ("find_array_spec(): Component not found");
1746 gfc_internal_error ("find_array_spec(): unused as(1)");
1750 c = c->ts.derived->components;
1758 gfc_internal_error ("find_array_spec(): unused as(2)");
1762 /* Resolve an array reference. */
1765 resolve_array_ref (gfc_array_ref * ar)
1767 int i, check_scalar;
1769 for (i = 0; i < ar->dimen; i++)
1771 check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
1773 if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE)
1775 if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE)
1777 if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE)
1780 if (ar->dimen_type[i] == DIMEN_UNKNOWN)
1781 switch (ar->start[i]->rank)
1784 ar->dimen_type[i] = DIMEN_ELEMENT;
1788 ar->dimen_type[i] = DIMEN_VECTOR;
1792 gfc_error ("Array index at %L is an array of rank %d",
1793 &ar->c_where[i], ar->start[i]->rank);
1798 /* If the reference type is unknown, figure out what kind it is. */
1800 if (ar->type == AR_UNKNOWN)
1802 ar->type = AR_ELEMENT;
1803 for (i = 0; i < ar->dimen; i++)
1804 if (ar->dimen_type[i] == DIMEN_RANGE
1805 || ar->dimen_type[i] == DIMEN_VECTOR)
1807 ar->type = AR_SECTION;
1812 if (compare_spec_to_ref (ar) == FAILURE)
1820 resolve_substring (gfc_ref * ref)
1823 if (ref->u.ss.start != NULL)
1825 if (gfc_resolve_expr (ref->u.ss.start) == FAILURE)
1828 if (ref->u.ss.start->ts.type != BT_INTEGER)
1830 gfc_error ("Substring start index at %L must be of type INTEGER",
1831 &ref->u.ss.start->where);
1835 if (ref->u.ss.start->rank != 0)
1837 gfc_error ("Substring start index at %L must be scalar",
1838 &ref->u.ss.start->where);
1842 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT)
1844 gfc_error ("Substring start index at %L is less than one",
1845 &ref->u.ss.start->where);
1850 if (ref->u.ss.end != NULL)
1852 if (gfc_resolve_expr (ref->u.ss.end) == FAILURE)
1855 if (ref->u.ss.end->ts.type != BT_INTEGER)
1857 gfc_error ("Substring end index at %L must be of type INTEGER",
1858 &ref->u.ss.end->where);
1862 if (ref->u.ss.end->rank != 0)
1864 gfc_error ("Substring end index at %L must be scalar",
1865 &ref->u.ss.end->where);
1869 if (ref->u.ss.length != NULL
1870 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT)
1872 gfc_error ("Substring end index at %L is out of bounds",
1873 &ref->u.ss.start->where);
1882 /* Resolve subtype references. */
1885 resolve_ref (gfc_expr * expr)
1887 int current_part_dimension, n_components, seen_part_dimension;
1890 for (ref = expr->ref; ref; ref = ref->next)
1891 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
1893 find_array_spec (expr);
1897 for (ref = expr->ref; ref; ref = ref->next)
1901 if (resolve_array_ref (&ref->u.ar) == FAILURE)
1909 resolve_substring (ref);
1913 /* Check constraints on part references. */
1915 current_part_dimension = 0;
1916 seen_part_dimension = 0;
1919 for (ref = expr->ref; ref; ref = ref->next)
1924 switch (ref->u.ar.type)
1928 current_part_dimension = 1;
1932 current_part_dimension = 0;
1936 gfc_internal_error ("resolve_ref(): Bad array reference");
1942 if ((current_part_dimension || seen_part_dimension)
1943 && ref->u.c.component->pointer)
1946 ("Component to the right of a part reference with nonzero "
1947 "rank must not have the POINTER attribute at %L",
1959 if (((ref->type == REF_COMPONENT && n_components > 1)
1960 || ref->next == NULL)
1961 && current_part_dimension
1962 && seen_part_dimension)
1965 gfc_error ("Two or more part references with nonzero rank must "
1966 "not be specified at %L", &expr->where);
1970 if (ref->type == REF_COMPONENT)
1972 if (current_part_dimension)
1973 seen_part_dimension = 1;
1975 /* reset to make sure */
1976 current_part_dimension = 0;
1984 /* Given an expression, determine its shape. This is easier than it sounds.
1985 Leaves the shape array NULL if it is not possible to determine the shape. */
1988 expression_shape (gfc_expr * e)
1990 mpz_t array[GFC_MAX_DIMENSIONS];
1993 if (e->rank == 0 || e->shape != NULL)
1996 for (i = 0; i < e->rank; i++)
1997 if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE)
2000 e->shape = gfc_get_shape (e->rank);
2002 memcpy (e->shape, array, e->rank * sizeof (mpz_t));
2007 for (i--; i >= 0; i--)
2008 mpz_clear (array[i]);
2012 /* Given a variable expression node, compute the rank of the expression by
2013 examining the base symbol and any reference structures it may have. */
2016 expression_rank (gfc_expr * e)
2023 if (e->expr_type == EXPR_ARRAY)
2025 /* Constructors can have a rank different from one via RESHAPE(). */
2027 if (e->symtree == NULL)
2033 e->rank = (e->symtree->n.sym->as == NULL)
2034 ? 0 : e->symtree->n.sym->as->rank;
2040 for (ref = e->ref; ref; ref = ref->next)
2042 if (ref->type != REF_ARRAY)
2045 if (ref->u.ar.type == AR_FULL)
2047 rank = ref->u.ar.as->rank;
2051 if (ref->u.ar.type == AR_SECTION)
2053 /* Figure out the rank of the section. */
2055 gfc_internal_error ("expression_rank(): Two array specs");
2057 for (i = 0; i < ref->u.ar.dimen; i++)
2058 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
2059 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
2069 expression_shape (e);
2073 /* Resolve a variable expression. */
2076 resolve_variable (gfc_expr * e)
2080 if (e->ref && resolve_ref (e) == FAILURE)
2083 sym = e->symtree->n.sym;
2084 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
2086 e->ts.type = BT_PROCEDURE;
2090 if (sym->ts.type != BT_UNKNOWN)
2091 gfc_variable_attr (e, &e->ts);
2094 /* Must be a simple variable reference. */
2095 if (gfc_set_default_type (sym, 1, NULL) == FAILURE)
2104 /* Resolve an expression. That is, make sure that types of operands agree
2105 with their operators, intrinsic operators are converted to function calls
2106 for overloaded types and unresolved function references are resolved. */
2109 gfc_resolve_expr (gfc_expr * e)
2116 switch (e->expr_type)
2119 t = resolve_operator (e);
2123 t = resolve_function (e);
2127 t = resolve_variable (e);
2129 expression_rank (e);
2132 case EXPR_SUBSTRING:
2133 t = resolve_ref (e);
2143 if (resolve_ref (e) == FAILURE)
2146 t = gfc_resolve_array_constructor (e);
2147 /* Also try to expand a constructor. */
2150 expression_rank (e);
2151 gfc_expand_constructor (e);
2156 case EXPR_STRUCTURE:
2157 t = resolve_ref (e);
2161 t = resolve_structure_cons (e);
2165 t = gfc_simplify_expr (e, 0);
2169 gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
2176 /* Resolve the expressions in an iterator structure and require that they all
2177 be of integer type. */
2180 gfc_resolve_iterator (gfc_iterator * iter)
2183 if (gfc_resolve_expr (iter->var) == FAILURE)
2186 if (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0)
2188 gfc_error ("Loop variable at %L must be a scalar INTEGER",
2193 if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
2195 gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
2200 if (gfc_resolve_expr (iter->start) == FAILURE)
2203 if (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0)
2205 gfc_error ("Start expression in DO loop at %L must be a scalar INTEGER",
2206 &iter->start->where);
2210 if (gfc_resolve_expr (iter->end) == FAILURE)
2213 if (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0)
2215 gfc_error ("End expression in DO loop at %L must be a scalar INTEGER",
2220 if (gfc_resolve_expr (iter->step) == FAILURE)
2223 if (iter->step->ts.type != BT_INTEGER || iter->step->rank != 0)
2225 gfc_error ("Step expression in DO loop at %L must be a scalar INTEGER",
2226 &iter->step->where);
2230 if (iter->step->expr_type == EXPR_CONSTANT
2231 && mpz_cmp_ui (iter->step->value.integer, 0) == 0)
2233 gfc_error ("Step expression in DO loop at %L cannot be zero",
2234 &iter->step->where);
2242 /* Resolve a list of FORALL iterators. */
2245 resolve_forall_iterators (gfc_forall_iterator * iter)
2250 if (gfc_resolve_expr (iter->var) == SUCCESS
2251 && iter->var->ts.type != BT_INTEGER)
2252 gfc_error ("FORALL Iteration variable at %L must be INTEGER",
2255 if (gfc_resolve_expr (iter->start) == SUCCESS
2256 && iter->start->ts.type != BT_INTEGER)
2257 gfc_error ("FORALL start expression at %L must be INTEGER",
2258 &iter->start->where);
2259 if (iter->var->ts.kind != iter->start->ts.kind)
2260 gfc_convert_type (iter->start, &iter->var->ts, 2);
2262 if (gfc_resolve_expr (iter->end) == SUCCESS
2263 && iter->end->ts.type != BT_INTEGER)
2264 gfc_error ("FORALL end expression at %L must be INTEGER",
2266 if (iter->var->ts.kind != iter->end->ts.kind)
2267 gfc_convert_type (iter->end, &iter->var->ts, 2);
2269 if (gfc_resolve_expr (iter->stride) == SUCCESS
2270 && iter->stride->ts.type != BT_INTEGER)
2271 gfc_error ("FORALL Stride expression at %L must be INTEGER",
2272 &iter->stride->where);
2273 if (iter->var->ts.kind != iter->stride->ts.kind)
2274 gfc_convert_type (iter->stride, &iter->var->ts, 2);
2281 /* Given a pointer to a symbol that is a derived type, see if any components
2282 have the POINTER attribute. The search is recursive if necessary.
2283 Returns zero if no pointer components are found, nonzero otherwise. */
2286 derived_pointer (gfc_symbol * sym)
2290 for (c = sym->components; c; c = c->next)
2295 if (c->ts.type == BT_DERIVED && derived_pointer (c->ts.derived))
2303 /* Resolve the argument of a deallocate expression. The expression must be
2304 a pointer or a full array. */
2307 resolve_deallocate_expr (gfc_expr * e)
2309 symbol_attribute attr;
2313 if (gfc_resolve_expr (e) == FAILURE)
2316 attr = gfc_expr_attr (e);
2320 if (e->expr_type != EXPR_VARIABLE)
2323 allocatable = e->symtree->n.sym->attr.allocatable;
2324 for (ref = e->ref; ref; ref = ref->next)
2328 if (ref->u.ar.type != AR_FULL)
2333 allocatable = (ref->u.c.component->as != NULL
2334 && ref->u.c.component->as->type == AS_DEFERRED);
2342 if (allocatable == 0)
2345 gfc_error ("Expression in DEALLOCATE statement at %L must be "
2346 "ALLOCATABLE or a POINTER", &e->where);
2353 /* Resolve the expression in an ALLOCATE statement, doing the additional
2354 checks to see whether the expression is OK or not. The expression must
2355 have a trailing array reference that gives the size of the array. */
2358 resolve_allocate_expr (gfc_expr * e)
2360 int i, pointer, allocatable, dimension;
2361 symbol_attribute attr;
2362 gfc_ref *ref, *ref2;
2365 if (gfc_resolve_expr (e) == FAILURE)
2368 /* Make sure the expression is allocatable or a pointer. If it is
2369 pointer, the next-to-last reference must be a pointer. */
2373 if (e->expr_type != EXPR_VARIABLE)
2377 attr = gfc_expr_attr (e);
2378 pointer = attr.pointer;
2379 dimension = attr.dimension;
2384 allocatable = e->symtree->n.sym->attr.allocatable;
2385 pointer = e->symtree->n.sym->attr.pointer;
2386 dimension = e->symtree->n.sym->attr.dimension;
2388 for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
2392 if (ref->next != NULL)
2397 allocatable = (ref->u.c.component->as != NULL
2398 && ref->u.c.component->as->type == AS_DEFERRED);
2400 pointer = ref->u.c.component->pointer;
2401 dimension = ref->u.c.component->dimension;
2411 if (allocatable == 0 && pointer == 0)
2413 gfc_error ("Expression in ALLOCATE statement at %L must be "
2414 "ALLOCATABLE or a POINTER", &e->where);
2418 if (pointer && dimension == 0)
2421 /* Make sure the next-to-last reference node is an array specification. */
2423 if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL)
2425 gfc_error ("Array specification required in ALLOCATE statement "
2426 "at %L", &e->where);
2430 if (ref2->u.ar.type == AR_ELEMENT)
2433 /* Make sure that the array section reference makes sense in the
2434 context of an ALLOCATE specification. */
2438 for (i = 0; i < ar->dimen; i++)
2439 switch (ar->dimen_type[i])
2445 if (ar->start[i] != NULL
2446 && ar->end[i] != NULL
2447 && ar->stride[i] == NULL)
2450 /* Fall Through... */
2454 gfc_error ("Bad array specification in ALLOCATE statement at %L",
2463 /************ SELECT CASE resolution subroutines ************/
2465 /* Callback function for our mergesort variant. Determines interval
2466 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for
2467 op1 > op2. Assumes we're not dealing with the default case. */
2470 compare_cases (const void * _op1, const void * _op2)
2472 const gfc_case *op1, *op2;
2474 op1 = (const gfc_case *) _op1;
2475 op2 = (const gfc_case *) _op2;
2477 if (op1->low == NULL) /* op1 = (:N) */
2479 if (op2->low == NULL) /* op2 = (:M), so overlap. */
2482 else if (op2->high == NULL) /* op2 = (M:) */
2484 if (gfc_compare_expr (op1->high, op2->low) < 0)
2485 return -1; /* N < M */
2490 else /* op2 = (L:M) */
2492 if (gfc_compare_expr (op1->high, op2->low) < 0)
2493 return -1; /* N < L */
2499 else if (op1->high == NULL) /* op1 = (N:) */
2501 if (op2->low == NULL) /* op2 = (:M) */
2503 if (gfc_compare_expr (op1->low, op2->high) > 0)
2504 return 1; /* N > M */
2509 else if (op2->high == NULL) /* op2 = (M:), so overlap. */
2512 else /* op2 = (L:M) */
2514 if (gfc_compare_expr (op1->low, op2->high) > 0)
2515 return 1; /* N > M */
2521 else /* op1 = (N:P) */
2523 if (op2->low == NULL) /* op2 = (:M) */
2525 if (gfc_compare_expr (op1->low, op2->high) > 0)
2526 return 1; /* N > M */
2531 else if (op2->high == NULL) /* op2 = (M:) */
2533 if (gfc_compare_expr (op1->high, op2->low) < 0)
2534 return -1; /* P < M */
2539 else /* op2 = (L:M) */
2541 if (gfc_compare_expr (op1->high, op2->low) < 0)
2542 return -1; /* P < L */
2544 if (gfc_compare_expr (op1->low, op2->high) > 0)
2545 return 1; /* N > M */
2553 /* Merge-sort a double linked case list, detecting overlap in the
2554 process. LIST is the head of the double linked case list before it
2555 is sorted. Returns the head of the sorted list if we don't see any
2556 overlap, or NULL otherwise. */
2559 check_case_overlap (gfc_case * list)
2561 gfc_case *p, *q, *e, *tail;
2562 int insize, nmerges, psize, qsize, cmp, overlap_seen;
2564 /* If the passed list was empty, return immediately. */
2571 /* Loop unconditionally. The only exit from this loop is a return
2572 statement, when we've finished sorting the case list. */
2579 /* Count the number of merges we do in this pass. */
2582 /* Loop while there exists a merge to be done. */
2587 /* Count this merge. */
2590 /* Cut the list in two pieces by steppin INSIZE places
2591 forward in the list, starting from P. */
2594 for (i = 0; i < insize; i++)
2603 /* Now we have two lists. Merge them! */
2604 while (psize > 0 || (qsize > 0 && q != NULL))
2607 /* See from which the next case to merge comes from. */
2610 /* P is empty so the next case must come from Q. */
2615 else if (qsize == 0 || q == NULL)
2624 cmp = compare_cases (p, q);
2627 /* The whole case range for P is less than the
2635 /* The whole case range for Q is greater than
2636 the case range for P. */
2643 /* The cases overlap, or they are the same
2644 element in the list. Either way, we must
2645 issue an error and get the next case from P. */
2646 /* FIXME: Sort P and Q by line number. */
2647 gfc_error ("CASE label at %L overlaps with CASE "
2648 "label at %L", &p->where, &q->where);
2656 /* Add the next element to the merged list. */
2665 /* P has now stepped INSIZE places along, and so has Q. So
2666 they're the same. */
2671 /* If we have done only one merge or none at all, we've
2672 finished sorting the cases. */
2681 /* Otherwise repeat, merging lists twice the size. */
2687 /* Check to see if an expression is suitable for use in a CASE
2688 statement. Makes sure that all case expressions are scalar
2689 constants of the same type/kind. Return FAILURE if anything
2693 validate_case_label_expr (gfc_expr * e, gfc_expr * case_expr)
2695 gfc_typespec case_ts = case_expr->ts;
2697 if (e == NULL) return SUCCESS;
2699 if (e->ts.type != case_ts.type)
2701 gfc_error ("Expression in CASE statement at %L must be of type %s",
2702 &e->where, gfc_basic_typename (case_ts.type));
2706 if (e->ts.kind != case_ts.kind)
2708 gfc_error("Expression in CASE statement at %L must be kind %d",
2709 &e->where, case_ts.kind);
2715 gfc_error ("Expression in CASE statement at %L must be scalar",
2724 /* Given a completely parsed select statement, we:
2726 - Validate all expressions and code within the SELECT.
2727 - Make sure that the selection expression is not of the wrong type.
2728 - Make sure that no case ranges overlap.
2729 - Eliminate unreachable cases and unreachable code resulting from
2730 removing case labels.
2732 The standard does allow unreachable cases, e.g. CASE (5:3). But
2733 they are a hassle for code generation, and to prevent that, we just
2734 cut them out here. This is not necessary for overlapping cases
2735 because they are illegal and we never even try to generate code.
2737 We have the additional caveat that a SELECT construct could have
2738 been a computed GOTO in the source code. Fortunately we can fairly
2739 easily work around that here: The case_expr for a "real" SELECT CASE
2740 is in code->expr1, but for a computed GOTO it is in code->expr2. All
2741 we have to do is make sure that the case_expr is a scalar integer
2745 resolve_select (gfc_code * code)
2748 gfc_expr *case_expr;
2749 gfc_case *cp, *default_case, *tail, *head;
2750 int seen_unreachable;
2755 if (code->expr == NULL)
2757 /* This was actually a computed GOTO statement. */
2758 case_expr = code->expr2;
2759 if (case_expr->ts.type != BT_INTEGER
2760 || case_expr->rank != 0)
2761 gfc_error ("Selection expression in computed GOTO statement "
2762 "at %L must be a scalar integer expression",
2765 /* Further checking is not necessary because this SELECT was built
2766 by the compiler, so it should always be OK. Just move the
2767 case_expr from expr2 to expr so that we can handle computed
2768 GOTOs as normal SELECTs from here on. */
2769 code->expr = code->expr2;
2774 case_expr = code->expr;
2776 type = case_expr->ts.type;
2777 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
2779 gfc_error ("Argument of SELECT statement at %L cannot be %s",
2780 &case_expr->where, gfc_typename (&case_expr->ts));
2782 /* Punt. Going on here just produce more garbage error messages. */
2786 if (case_expr->rank != 0)
2788 gfc_error ("Argument of SELECT statement at %L must be a scalar "
2789 "expression", &case_expr->where);
2795 /* Assume there is no DEFAULT case. */
2796 default_case = NULL;
2800 for (body = code->block; body; body = body->block)
2802 /* Assume the CASE list is OK, and all CASE labels can be matched. */
2804 seen_unreachable = 0;
2806 /* Walk the case label list, making sure that all case labels
2808 for (cp = body->ext.case_list; cp; cp = cp->next)
2810 /* Count the number of cases in the whole construct. */
2813 /* Intercept the DEFAULT case. */
2814 if (cp->low == NULL && cp->high == NULL)
2816 if (default_case != NULL)
2818 gfc_error ("The DEFAULT CASE at %L cannot be followed "
2819 "by a second DEFAULT CASE at %L",
2820 &default_case->where, &cp->where);
2831 /* Deal with single value cases and case ranges. Errors are
2832 issued from the validation function. */
2833 if(validate_case_label_expr (cp->low, case_expr) != SUCCESS
2834 || validate_case_label_expr (cp->high, case_expr) != SUCCESS)
2840 if (type == BT_LOGICAL
2841 && ((cp->low == NULL || cp->high == NULL)
2842 || cp->low != cp->high))
2845 ("Logical range in CASE statement at %L is not allowed",
2851 if (cp->low != NULL && cp->high != NULL
2852 && cp->low != cp->high
2853 && gfc_compare_expr (cp->low, cp->high) > 0)
2855 if (gfc_option.warn_surprising)
2856 gfc_warning ("Range specification at %L can never "
2857 "be matched", &cp->where);
2859 cp->unreachable = 1;
2860 seen_unreachable = 1;
2864 /* If the case range can be matched, it can also overlap with
2865 other cases. To make sure it does not, we put it in a
2866 double linked list here. We sort that with a merge sort
2867 later on to detect any overlapping cases. */
2871 head->right = head->left = NULL;
2876 tail->right->left = tail;
2883 /* It there was a failure in the previous case label, give up
2884 for this case label list. Continue with the next block. */
2888 /* See if any case labels that are unreachable have been seen.
2889 If so, we eliminate them. This is a bit of a kludge because
2890 the case lists for a single case statement (label) is a
2891 single forward linked lists. */
2892 if (seen_unreachable)
2894 /* Advance until the first case in the list is reachable. */
2895 while (body->ext.case_list != NULL
2896 && body->ext.case_list->unreachable)
2898 gfc_case *n = body->ext.case_list;
2899 body->ext.case_list = body->ext.case_list->next;
2901 gfc_free_case_list (n);
2904 /* Strip all other unreachable cases. */
2905 if (body->ext.case_list)
2907 for (cp = body->ext.case_list; cp->next; cp = cp->next)
2909 if (cp->next->unreachable)
2911 gfc_case *n = cp->next;
2912 cp->next = cp->next->next;
2914 gfc_free_case_list (n);
2921 /* See if there were overlapping cases. If the check returns NULL,
2922 there was overlap. In that case we don't do anything. If head
2923 is non-NULL, we prepend the DEFAULT case. The sorted list can
2924 then used during code generation for SELECT CASE constructs with
2925 a case expression of a CHARACTER type. */
2928 head = check_case_overlap (head);
2930 /* Prepend the default_case if it is there. */
2931 if (head != NULL && default_case)
2933 default_case->left = NULL;
2934 default_case->right = head;
2935 head->left = default_case;
2939 /* Eliminate dead blocks that may be the result if we've seen
2940 unreachable case labels for a block. */
2941 for (body = code; body && body->block; body = body->block)
2943 if (body->block->ext.case_list == NULL)
2945 /* Cut the unreachable block from the code chain. */
2946 gfc_code *c = body->block;
2947 body->block = c->block;
2949 /* Kill the dead block, but not the blocks below it. */
2951 gfc_free_statements (c);
2955 /* More than two cases is legal but insane for logical selects.
2956 Issue a warning for it. */
2957 if (gfc_option.warn_surprising && type == BT_LOGICAL
2959 gfc_warning ("Logical SELECT CASE block at %L has more that two cases",
2964 /* Resolve a transfer statement. This is making sure that:
2965 -- a derived type being transferred has only non-pointer components
2966 -- a derived type being transferred doesn't have private components
2967 -- we're not trying to transfer a whole assumed size array. */
2970 resolve_transfer (gfc_code * code)
2979 if (exp->expr_type != EXPR_VARIABLE)
2982 sym = exp->symtree->n.sym;
2985 /* Go to actual component transferred. */
2986 for (ref = code->expr->ref; ref; ref = ref->next)
2987 if (ref->type == REF_COMPONENT)
2988 ts = &ref->u.c.component->ts;
2990 if (ts->type == BT_DERIVED)
2992 /* Check that transferred derived type doesn't contain POINTER
2994 if (derived_pointer (ts->derived))
2996 gfc_error ("Data transfer element at %L cannot have "
2997 "POINTER components", &code->loc);
3001 if (ts->derived->component_access == ACCESS_PRIVATE)
3003 gfc_error ("Data transfer element at %L cannot have "
3004 "PRIVATE components",&code->loc);
3009 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE
3010 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL)
3012 gfc_error ("Data transfer element at %L cannot be a full reference to "
3013 "an assumed-size array", &code->loc);
3019 /*********** Toplevel code resolution subroutines ***********/
3021 /* Given a branch to a label and a namespace, if the branch is conforming.
3022 The code node described where the branch is located. */
3025 resolve_branch (gfc_st_label * label, gfc_code * code)
3027 gfc_code *block, *found;
3035 /* Step one: is this a valid branching target? */
3037 if (lp->defined == ST_LABEL_UNKNOWN)
3039 gfc_error ("Label %d referenced at %L is never defined", lp->value,
3044 if (lp->defined != ST_LABEL_TARGET)
3046 gfc_error ("Statement at %L is not a valid branch target statement "
3047 "for the branch statement at %L", &lp->where, &code->loc);
3051 /* Step two: make sure this branch is not a branch to itself ;-) */
3053 if (code->here == label)
3055 gfc_warning ("Branch at %L causes an infinite loop", &code->loc);
3059 /* Step three: Try to find the label in the parse tree. To do this,
3060 we traverse the tree block-by-block: first the block that
3061 contains this GOTO, then the block that it is nested in, etc. We
3062 can ignore other blocks because branching into another block is
3067 for (stack = cs_base; stack; stack = stack->prev)
3069 for (block = stack->head; block; block = block->next)
3071 if (block->here == label)
3084 /* still nothing, so illegal. */
3085 gfc_error_now ("Label at %L is not in the same block as the "
3086 "GOTO statement at %L", &lp->where, &code->loc);
3090 /* Step four: Make sure that the branching target is legal if
3091 the statement is an END {SELECT,DO,IF}. */
3093 if (found->op == EXEC_NOP)
3095 for (stack = cs_base; stack; stack = stack->prev)
3096 if (stack->current->next == found)
3100 gfc_notify_std (GFC_STD_F95_DEL,
3101 "Obsolete: GOTO at %L jumps to END of construct at %L",
3102 &code->loc, &found->loc);
3107 /* Check whether EXPR1 has the same shape as EXPR2. */
3110 resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2)
3112 mpz_t shape[GFC_MAX_DIMENSIONS];
3113 mpz_t shape2[GFC_MAX_DIMENSIONS];
3114 try result = FAILURE;
3117 /* Compare the rank. */
3118 if (expr1->rank != expr2->rank)
3121 /* Compare the size of each dimension. */
3122 for (i=0; i<expr1->rank; i++)
3124 if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE)
3127 if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE)
3130 if (mpz_cmp (shape[i], shape2[i]))
3134 /* When either of the two expression is an assumed size array, we
3135 ignore the comparison of dimension sizes. */
3140 for (i--; i>=0; i--)
3142 mpz_clear (shape[i]);
3143 mpz_clear (shape2[i]);
3149 /* Check whether a WHERE assignment target or a WHERE mask expression
3150 has the same shape as the outmost WHERE mask expression. */
3153 resolve_where (gfc_code *code, gfc_expr *mask)
3159 cblock = code->block;
3161 /* Store the first WHERE mask-expr of the WHERE statement or construct.
3162 In case of nested WHERE, only the outmost one is stored. */
3163 if (mask == NULL) /* outmost WHERE */
3165 else /* inner WHERE */
3172 /* Check if the mask-expr has a consistent shape with the
3173 outmost WHERE mask-expr. */
3174 if (resolve_where_shape (cblock->expr, e) == FAILURE)
3175 gfc_error ("WHERE mask at %L has inconsistent shape",
3176 &cblock->expr->where);
3179 /* the assignment statement of a WHERE statement, or the first
3180 statement in where-body-construct of a WHERE construct */
3181 cnext = cblock->next;
3186 /* WHERE assignment statement */
3189 /* Check shape consistent for WHERE assignment target. */
3190 if (e && resolve_where_shape (cnext->expr, e) == FAILURE)
3191 gfc_error ("WHERE assignment target at %L has "
3192 "inconsistent shape", &cnext->expr->where);
3195 /* WHERE or WHERE construct is part of a where-body-construct */
3197 resolve_where (cnext, e);
3201 gfc_error ("Unsupported statement inside WHERE at %L",
3204 /* the next statement within the same where-body-construct */
3205 cnext = cnext->next;
3207 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
3208 cblock = cblock->block;
3213 /* Check whether the FORALL index appears in the expression or not. */
3216 gfc_find_forall_index (gfc_expr *expr, gfc_symbol *symbol)
3220 gfc_actual_arglist *args;
3223 switch (expr->expr_type)
3226 gcc_assert (expr->symtree->n.sym);
3228 /* A scalar assignment */
3231 if (expr->symtree->n.sym == symbol)
3237 /* the expr is array ref, substring or struct component. */
3244 /* Check if the symbol appears in the array subscript. */
3246 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
3249 if (gfc_find_forall_index (ar.start[i], symbol) == SUCCESS)
3253 if (gfc_find_forall_index (ar.end[i], symbol) == SUCCESS)
3257 if (gfc_find_forall_index (ar.stride[i], symbol) == SUCCESS)
3263 if (expr->symtree->n.sym == symbol)
3266 /* Check if the symbol appears in the substring section. */
3267 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
3269 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
3277 gfc_error("expresion reference type error at %L", &expr->where);
3283 /* If the expression is a function call, then check if the symbol
3284 appears in the actual arglist of the function. */
3286 for (args = expr->value.function.actual; args; args = args->next)
3288 if (gfc_find_forall_index(args->expr,symbol) == SUCCESS)
3293 /* It seems not to happen. */
3294 case EXPR_SUBSTRING:
3298 gcc_assert (expr->ref->type == REF_SUBSTRING);
3299 if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS)
3301 if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS)
3306 /* It seems not to happen. */
3307 case EXPR_STRUCTURE:
3309 gfc_error ("Unsupported statement while finding forall index in "
3316 /* Find the FORALL index in the first operand. */
3319 if (gfc_find_forall_index (expr->op1, symbol) == SUCCESS)
3323 /* Find the FORALL index in the second operand. */
3326 if (gfc_find_forall_index (expr->op2, symbol) == SUCCESS)
3333 /* Resolve assignment in FORALL construct.
3334 NVAR is the number of FORALL index variables, and VAR_EXPR records the
3335 FORALL index variables. */
3338 gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr)
3342 for (n = 0; n < nvar; n++)
3344 gfc_symbol *forall_index;
3346 forall_index = var_expr[n]->symtree->n.sym;
3348 /* Check whether the assignment target is one of the FORALL index
3350 if ((code->expr->expr_type == EXPR_VARIABLE)
3351 && (code->expr->symtree->n.sym == forall_index))
3352 gfc_error ("Assignment to a FORALL index variable at %L",
3353 &code->expr->where);
3356 /* If one of the FORALL index variables doesn't appear in the
3357 assignment target, then there will be a many-to-one
3359 if (gfc_find_forall_index (code->expr, forall_index) == FAILURE)
3360 gfc_error ("The FORALL with index '%s' cause more than one "
3361 "assignment to this object at %L",
3362 var_expr[n]->symtree->name, &code->expr->where);
3368 /* Resolve WHERE statement in FORALL construct. */
3371 gfc_resolve_where_code_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr){
3375 cblock = code->block;
3378 /* the assignment statement of a WHERE statement, or the first
3379 statement in where-body-construct of a WHERE construct */
3380 cnext = cblock->next;
3385 /* WHERE assignment statement */
3387 gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
3390 /* WHERE or WHERE construct is part of a where-body-construct */
3392 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr);
3396 gfc_error ("Unsupported statement inside WHERE at %L",
3399 /* the next statement within the same where-body-construct */
3400 cnext = cnext->next;
3402 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
3403 cblock = cblock->block;
3408 /* Traverse the FORALL body to check whether the following errors exist:
3409 1. For assignment, check if a many-to-one assignment happens.
3410 2. For WHERE statement, check the WHERE body to see if there is any
3411 many-to-one assignment. */
3414 gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
3418 c = code->block->next;
3424 case EXEC_POINTER_ASSIGN:
3425 gfc_resolve_assign_in_forall (c, nvar, var_expr);
3428 /* Because the resolve_blocks() will handle the nested FORALL,
3429 there is no need to handle it here. */
3433 gfc_resolve_where_code_in_forall(c, nvar, var_expr);
3438 /* The next statement in the FORALL body. */
3444 /* Given a FORALL construct, first resolve the FORALL iterator, then call
3445 gfc_resolve_forall_body to resolve the FORALL body. */
3447 static void resolve_blocks (gfc_code *, gfc_namespace *);
3450 gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
3452 static gfc_expr **var_expr;
3453 static int total_var = 0;
3454 static int nvar = 0;
3455 gfc_forall_iterator *fa;
3456 gfc_symbol *forall_index;
3460 /* Start to resolve a FORALL construct */
3461 if (forall_save == 0)
3463 /* Count the total number of FORALL index in the nested FORALL
3464 construct in order to allocate the VAR_EXPR with proper size. */
3466 while ((next != NULL) && (next->op == EXEC_FORALL))
3468 for (fa = next->ext.forall_iterator; fa; fa = fa->next)
3470 next = next->block->next;
3473 /* allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
3474 var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
3477 /* The information about FORALL iterator, including FORALL index start, end
3478 and stride. The FORALL index can not appear in start, end or stride. */
3479 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
3481 /* Check if any outer FORALL index name is the same as the current
3483 for (i = 0; i < nvar; i++)
3485 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
3487 gfc_error ("An outer FORALL construct already has an index "
3488 "with this name %L", &fa->var->where);
3492 /* Record the current FORALL index. */
3493 var_expr[nvar] = gfc_copy_expr (fa->var);
3495 forall_index = fa->var->symtree->n.sym;
3497 /* Check if the FORALL index appears in start, end or stride. */
3498 if (gfc_find_forall_index (fa->start, forall_index) == SUCCESS)
3499 gfc_error ("A FORALL index must not appear in a limit or stride "
3500 "expression in the same FORALL at %L", &fa->start->where);
3501 if (gfc_find_forall_index (fa->end, forall_index) == SUCCESS)
3502 gfc_error ("A FORALL index must not appear in a limit or stride "
3503 "expression in the same FORALL at %L", &fa->end->where);
3504 if (gfc_find_forall_index (fa->stride, forall_index) == SUCCESS)
3505 gfc_error ("A FORALL index must not appear in a limit or stride "
3506 "expression in the same FORALL at %L", &fa->stride->where);
3510 /* Resolve the FORALL body. */
3511 gfc_resolve_forall_body (code, nvar, var_expr);
3513 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */
3514 resolve_blocks (code->block, ns);
3516 /* Free VAR_EXPR after the whole FORALL construct resolved. */
3517 for (i = 0; i < total_var; i++)
3518 gfc_free_expr (var_expr[i]);
3520 /* Reset the counters. */
3526 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
3529 static void resolve_code (gfc_code *, gfc_namespace *);
3532 resolve_blocks (gfc_code * b, gfc_namespace * ns)
3536 for (; b; b = b->block)
3538 t = gfc_resolve_expr (b->expr);
3539 if (gfc_resolve_expr (b->expr2) == FAILURE)
3545 if (t == SUCCESS && b->expr != NULL
3546 && (b->expr->ts.type != BT_LOGICAL || b->expr->rank != 0))
3548 ("ELSE IF clause at %L requires a scalar LOGICAL expression",
3555 && (b->expr->ts.type != BT_LOGICAL
3556 || b->expr->rank == 0))
3558 ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array",
3563 resolve_branch (b->label, b);
3573 gfc_internal_error ("resolve_block(): Bad block type");
3576 resolve_code (b->next, ns);
3581 /* Given a block of code, recursively resolve everything pointed to by this
3585 resolve_code (gfc_code * code, gfc_namespace * ns)
3587 int forall_save = 0;
3592 frame.prev = cs_base;
3596 for (; code; code = code->next)
3598 frame.current = code;
3600 if (code->op == EXEC_FORALL)
3602 forall_save = forall_flag;
3604 gfc_resolve_forall (code, ns, forall_save);
3607 resolve_blocks (code->block, ns);
3609 if (code->op == EXEC_FORALL)
3610 forall_flag = forall_save;
3612 t = gfc_resolve_expr (code->expr);
3613 if (gfc_resolve_expr (code->expr2) == FAILURE)
3629 resolve_where (code, NULL);
3633 if (code->expr != NULL && code->expr->ts.type != BT_INTEGER)
3634 gfc_error ("ASSIGNED GOTO statement at %L requires an INTEGER "
3635 "variable", &code->expr->where);
3637 resolve_branch (code->label, code);
3641 if (code->expr != NULL && code->expr->ts.type != BT_INTEGER)
3642 gfc_error ("Alternate RETURN statement at %L requires an INTEGER "
3643 "return specifier", &code->expr->where);
3650 if (gfc_extend_assign (code, ns) == SUCCESS)
3653 if (gfc_pure (NULL))
3655 if (gfc_impure_variable (code->expr->symtree->n.sym))
3658 ("Cannot assign to variable '%s' in PURE procedure at %L",
3659 code->expr->symtree->n.sym->name, &code->expr->where);
3663 if (code->expr2->ts.type == BT_DERIVED
3664 && derived_pointer (code->expr2->ts.derived))
3667 ("Right side of assignment at %L is a derived type "
3668 "containing a POINTER in a PURE procedure",
3669 &code->expr2->where);
3674 gfc_check_assign (code->expr, code->expr2, 1);
3677 case EXEC_LABEL_ASSIGN:
3678 if (code->label->defined == ST_LABEL_UNKNOWN)
3679 gfc_error ("Label %d referenced at %L is never defined",
3680 code->label->value, &code->label->where);
3681 if (t == SUCCESS && code->expr->ts.type != BT_INTEGER)
3682 gfc_error ("ASSIGN statement at %L requires an INTEGER "
3683 "variable", &code->expr->where);
3686 case EXEC_POINTER_ASSIGN:
3690 gfc_check_pointer_assign (code->expr, code->expr2);
3693 case EXEC_ARITHMETIC_IF:
3695 && code->expr->ts.type != BT_INTEGER
3696 && code->expr->ts.type != BT_REAL)
3697 gfc_error ("Arithmetic IF statement at %L requires a numeric "
3698 "expression", &code->expr->where);
3700 resolve_branch (code->label, code);
3701 resolve_branch (code->label2, code);
3702 resolve_branch (code->label3, code);
3706 if (t == SUCCESS && code->expr != NULL
3707 && (code->expr->ts.type != BT_LOGICAL
3708 || code->expr->rank != 0))
3709 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
3710 &code->expr->where);
3715 resolve_call (code);
3719 /* Select is complicated. Also, a SELECT construct could be
3720 a transformed computed GOTO. */
3721 resolve_select (code);
3725 if (code->ext.iterator != NULL)
3726 gfc_resolve_iterator (code->ext.iterator);
3730 if (code->expr == NULL)
3731 gfc_internal_error ("resolve_code(): No expression on DO WHILE");
3733 && (code->expr->rank != 0
3734 || code->expr->ts.type != BT_LOGICAL))
3735 gfc_error ("Exit condition of DO WHILE loop at %L must be "
3736 "a scalar LOGICAL expression", &code->expr->where);
3740 if (t == SUCCESS && code->expr != NULL
3741 && code->expr->ts.type != BT_INTEGER)
3742 gfc_error ("STAT tag in ALLOCATE statement at %L must be "
3743 "of type INTEGER", &code->expr->where);
3745 for (a = code->ext.alloc_list; a; a = a->next)
3746 resolve_allocate_expr (a->expr);
3750 case EXEC_DEALLOCATE:
3751 if (t == SUCCESS && code->expr != NULL
3752 && code->expr->ts.type != BT_INTEGER)
3754 ("STAT tag in DEALLOCATE statement at %L must be of type "
3755 "INTEGER", &code->expr->where);
3757 for (a = code->ext.alloc_list; a; a = a->next)
3758 resolve_deallocate_expr (a->expr);
3763 if (gfc_resolve_open (code->ext.open) == FAILURE)
3766 resolve_branch (code->ext.open->err, code);
3770 if (gfc_resolve_close (code->ext.close) == FAILURE)
3773 resolve_branch (code->ext.close->err, code);
3776 case EXEC_BACKSPACE:
3779 if (gfc_resolve_filepos (code->ext.filepos) == FAILURE)
3782 resolve_branch (code->ext.filepos->err, code);
3786 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
3789 resolve_branch (code->ext.inquire->err, code);
3793 gcc_assert (code->ext.inquire != NULL);
3794 if (gfc_resolve_inquire (code->ext.inquire) == FAILURE)
3797 resolve_branch (code->ext.inquire->err, code);
3802 if (gfc_resolve_dt (code->ext.dt) == FAILURE)
3805 resolve_branch (code->ext.dt->err, code);
3806 resolve_branch (code->ext.dt->end, code);
3807 resolve_branch (code->ext.dt->eor, code);
3811 resolve_transfer (code);
3815 resolve_forall_iterators (code->ext.forall_iterator);
3817 if (code->expr != NULL && code->expr->ts.type != BT_LOGICAL)
3819 ("FORALL mask clause at %L requires a LOGICAL expression",
3820 &code->expr->where);
3824 gfc_internal_error ("resolve_code(): Bad statement code");
3828 cs_base = frame.prev;
3832 /* Resolve initial values and make sure they are compatible with
3836 resolve_values (gfc_symbol * sym)
3839 if (sym->value == NULL)
3842 if (gfc_resolve_expr (sym->value) == FAILURE)
3845 gfc_check_assign_symbol (sym, sym->value);
3849 /* Do anything necessary to resolve a symbol. Right now, we just
3850 assume that an otherwise unknown symbol is a variable. This sort
3851 of thing commonly happens for symbols in module. */
3854 resolve_symbol (gfc_symbol * sym)
3856 /* Zero if we are checking a formal namespace. */
3857 static int formal_ns_flag = 1;
3858 int formal_ns_save, check_constant, mp_flag;
3863 if (sym->attr.flavor == FL_UNKNOWN)
3865 if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
3866 sym->attr.flavor = FL_VARIABLE;
3869 sym->attr.flavor = FL_PROCEDURE;
3870 if (sym->attr.dimension)
3871 sym->attr.function = 1;
3875 /* Symbols that are module procedures with results (functions) have
3876 the types and array specification copied for type checking in
3877 procedures that call them, as well as for saving to a module
3878 file. These symbols can't stand the scrutiny that their results
3880 mp_flag = (sym->result != NULL && sym->result != sym);
3882 /* Assign default type to symbols that need one and don't have one. */
3883 if (sym->ts.type == BT_UNKNOWN)
3885 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
3886 gfc_set_default_type (sym, 1, NULL);
3888 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
3891 gfc_set_default_type (sym, 0, NULL);
3894 /* Result may be in another namespace. */
3895 resolve_symbol (sym->result);
3897 sym->ts = sym->result->ts;
3898 sym->as = gfc_copy_array_spec (sym->result->as);
3903 /* Assumed size arrays and assumed shape arrays must be dummy
3907 && (sym->as->type == AS_ASSUMED_SIZE
3908 || sym->as->type == AS_ASSUMED_SHAPE)
3909 && sym->attr.dummy == 0)
3911 gfc_error ("Assumed %s array at %L must be a dummy argument",
3912 sym->as->type == AS_ASSUMED_SIZE ? "size" : "shape",
3917 /* A parameter array's shape needs to be constant. */
3919 if (sym->attr.flavor == FL_PARAMETER && sym->as != NULL
3920 && !gfc_is_compile_time_shape (sym->as))
3922 gfc_error ("Parameter array '%s' at %L cannot be automatic "
3923 "or assumed shape", sym->name, &sym->declared_at);
3927 /* Make sure that character string variables with assumed length are
3930 if (sym->attr.flavor == FL_VARIABLE && !sym->attr.result
3931 && sym->ts.type == BT_CHARACTER
3932 && sym->ts.cl->length == NULL && sym->attr.dummy == 0)
3934 gfc_error ("Entity with assumed character length at %L must be a "
3935 "dummy argument or a PARAMETER", &sym->declared_at);
3939 /* Make sure a parameter that has been implicitly typed still
3940 matches the implicit type, since PARAMETER statements can precede
3941 IMPLICIT statements. */
3943 if (sym->attr.flavor == FL_PARAMETER
3944 && sym->attr.implicit_type
3945 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym, sym->ns)))
3946 gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
3947 "later IMPLICIT type", sym->name, &sym->declared_at);
3949 /* Make sure the types of derived parameters are consistent. This
3950 type checking is deferred until resolution because the type may
3951 refer to a derived type from the host. */
3953 if (sym->attr.flavor == FL_PARAMETER
3954 && sym->ts.type == BT_DERIVED
3955 && !gfc_compare_types (&sym->ts, &sym->value->ts))
3956 gfc_error ("Incompatible derived type in PARAMETER at %L",
3957 &sym->value->where);
3959 /* Make sure symbols with known intent or optional are really dummy
3960 variable. Because of ENTRY statement, this has to be deferred
3961 until resolution time. */
3963 if (! sym->attr.dummy
3964 && (sym->attr.optional
3965 || sym->attr.intent != INTENT_UNKNOWN))
3967 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
3971 if (sym->attr.proc == PROC_ST_FUNCTION)
3973 if (sym->ts.type == BT_CHARACTER)
3975 gfc_charlen *cl = sym->ts.cl;
3976 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
3978 gfc_error ("Character-valued statement function '%s' at %L must "
3979 "have constant length", sym->name, &sym->declared_at);
3985 /* Constraints on deferred shape variable. */
3986 if (sym->attr.flavor == FL_VARIABLE
3987 || (sym->attr.flavor == FL_PROCEDURE
3988 && sym->attr.function))
3990 if (sym->as == NULL || sym->as->type != AS_DEFERRED)
3992 if (sym->attr.allocatable)
3994 if (sym->attr.dimension)
3995 gfc_error ("Allocatable array at %L must have a deferred shape",
3998 gfc_error ("Object at %L may not be ALLOCATABLE",
4003 if (sym->attr.pointer && sym->attr.dimension)
4005 gfc_error ("Pointer to array at %L must have a deferred shape",
4013 if (!mp_flag && !sym->attr.allocatable
4014 && !sym->attr.pointer && !sym->attr.dummy)
4016 gfc_error ("Array at %L cannot have a deferred shape",
4023 if (sym->attr.flavor == FL_VARIABLE)
4025 /* Can the sybol have an initializer? */
4027 if (sym->attr.allocatable)
4028 whynot = "Allocatable";
4029 else if (sym->attr.external)
4030 whynot = "External";
4031 else if (sym->attr.dummy)
4033 else if (sym->attr.intrinsic)
4034 whynot = "Intrinsic";
4035 else if (sym->attr.result)
4036 whynot = "Function Result";
4037 else if (sym->attr.dimension && !sym->attr.pointer)
4039 /* Don't allow initialization of automatic arrays. */
4040 for (i = 0; i < sym->as->rank; i++)
4042 if (sym->as->lower[i] == NULL
4043 || sym->as->lower[i]->expr_type != EXPR_CONSTANT
4044 || sym->as->upper[i] == NULL
4045 || sym->as->upper[i]->expr_type != EXPR_CONSTANT)
4047 whynot = "Automatic array";
4053 /* Reject illegal initializers. */
4054 if (sym->value && whynot)
4056 gfc_error ("%s '%s' at %L cannot have an initializer",
4057 whynot, sym->name, &sym->declared_at);
4061 /* Assign default initializer. */
4062 if (sym->ts.type == BT_DERIVED && !(sym->value || whynot))
4063 sym->value = gfc_default_initializer (&sym->ts);
4067 /* Make sure that intrinsic exist */
4068 if (sym->attr.intrinsic
4069 && ! gfc_intrinsic_name(sym->name, 0)
4070 && ! gfc_intrinsic_name(sym->name, 1))
4071 gfc_error("Intrinsic at %L does not exist", &sym->declared_at);
4073 /* Resolve array specifier. Check as well some constraints
4074 on COMMON blocks. */
4076 check_constant = sym->attr.in_common && !sym->attr.pointer;
4077 gfc_resolve_array_spec (sym->as, check_constant);
4079 /* Resolve formal namespaces. */
4081 if (formal_ns_flag && sym != NULL && sym->formal_ns != NULL)
4083 formal_ns_save = formal_ns_flag;
4085 gfc_resolve (sym->formal_ns);
4086 formal_ns_flag = formal_ns_save;
4092 /************* Resolve DATA statements *************/
4096 gfc_data_value *vnode;
4102 /* Advance the values structure to point to the next value in the data list. */
4105 next_data_value (void)
4107 while (values.left == 0)
4109 if (values.vnode->next == NULL)
4112 values.vnode = values.vnode->next;
4113 values.left = values.vnode->repeat;
4121 check_data_variable (gfc_data_variable * var, locus * where)
4127 ar_type mark = AR_UNKNOWN;
4129 mpz_t section_index[GFC_MAX_DIMENSIONS];
4133 if (gfc_resolve_expr (var->expr) == FAILURE)
4137 mpz_init_set_si (offset, 0);
4140 if (e->expr_type != EXPR_VARIABLE)
4141 gfc_internal_error ("check_data_variable(): Bad expression");
4145 mpz_init_set_ui (size, 1);
4152 /* Find the array section reference. */
4153 for (ref = e->ref; ref; ref = ref->next)
4155 if (ref->type != REF_ARRAY)
4157 if (ref->u.ar.type == AR_ELEMENT)
4163 /* Set marks according to the reference pattern. */
4164 switch (ref->u.ar.type)
4172 /* Get the start position of array section. */
4173 gfc_get_section_index (ar, section_index, &offset);
4181 if (gfc_array_size (e, &size) == FAILURE)
4183 gfc_error ("Nonconstant array section at %L in DATA statement",
4192 while (mpz_cmp_ui (size, 0) > 0)
4194 if (next_data_value () == FAILURE)
4196 gfc_error ("DATA statement at %L has more variables than values",
4202 t = gfc_check_assign (var->expr, values.vnode->expr, 0);
4206 /* If we have more than one element left in the repeat count,
4207 and we have more than one element left in the target variable,
4208 then create a range assignment. */
4209 /* ??? Only done for full arrays for now, since array sections
4211 if (mark == AR_FULL && ref && ref->next == NULL
4212 && values.left > 1 && mpz_cmp_ui (size, 1) > 0)
4216 if (mpz_cmp_ui (size, values.left) >= 0)
4218 mpz_init_set_ui (range, values.left);
4219 mpz_sub_ui (size, size, values.left);
4224 mpz_init_set (range, size);
4225 values.left -= mpz_get_ui (size);
4226 mpz_set_ui (size, 0);
4229 gfc_assign_data_value_range (var->expr, values.vnode->expr,
4232 mpz_add (offset, offset, range);
4236 /* Assign initial value to symbol. */
4240 mpz_sub_ui (size, size, 1);
4242 gfc_assign_data_value (var->expr, values.vnode->expr, offset);
4244 if (mark == AR_FULL)
4245 mpz_add_ui (offset, offset, 1);
4247 /* Modify the array section indexes and recalculate the offset
4248 for next element. */
4249 else if (mark == AR_SECTION)
4250 gfc_advance_section (section_index, ar, &offset);
4254 if (mark == AR_SECTION)
4256 for (i = 0; i < ar->dimen; i++)
4257 mpz_clear (section_index[i]);
4267 static try traverse_data_var (gfc_data_variable *, locus *);
4269 /* Iterate over a list of elements in a DATA statement. */
4272 traverse_data_list (gfc_data_variable * var, locus * where)
4275 iterator_stack frame;
4278 mpz_init (frame.value);
4280 mpz_init_set (trip, var->iter.end->value.integer);
4281 mpz_sub (trip, trip, var->iter.start->value.integer);
4282 mpz_add (trip, trip, var->iter.step->value.integer);
4284 mpz_div (trip, trip, var->iter.step->value.integer);
4286 mpz_set (frame.value, var->iter.start->value.integer);
4288 frame.prev = iter_stack;
4289 frame.variable = var->iter.var->symtree;
4290 iter_stack = &frame;
4292 while (mpz_cmp_ui (trip, 0) > 0)
4294 if (traverse_data_var (var->list, where) == FAILURE)
4300 e = gfc_copy_expr (var->expr);
4301 if (gfc_simplify_expr (e, 1) == FAILURE)
4307 mpz_add (frame.value, frame.value, var->iter.step->value.integer);
4309 mpz_sub_ui (trip, trip, 1);
4313 mpz_clear (frame.value);
4315 iter_stack = frame.prev;
4320 /* Type resolve variables in the variable list of a DATA statement. */
4323 traverse_data_var (gfc_data_variable * var, locus * where)
4327 for (; var; var = var->next)
4329 if (var->expr == NULL)
4330 t = traverse_data_list (var, where);
4332 t = check_data_variable (var, where);
4342 /* Resolve the expressions and iterators associated with a data statement.
4343 This is separate from the assignment checking because data lists should
4344 only be resolved once. */
4347 resolve_data_variables (gfc_data_variable * d)
4349 for (; d; d = d->next)
4351 if (d->list == NULL)
4353 if (gfc_resolve_expr (d->expr) == FAILURE)
4358 if (gfc_resolve_iterator (&d->iter) == FAILURE)
4361 if (d->iter.start->expr_type != EXPR_CONSTANT
4362 || d->iter.end->expr_type != EXPR_CONSTANT
4363 || d->iter.step->expr_type != EXPR_CONSTANT)
4364 gfc_internal_error ("resolve_data_variables(): Bad iterator");
4366 if (resolve_data_variables (d->list) == FAILURE)
4375 /* Resolve a single DATA statement. We implement this by storing a pointer to
4376 the value list into static variables, and then recursively traversing the
4377 variables list, expanding iterators and such. */
4380 resolve_data (gfc_data * d)
4382 if (resolve_data_variables (d->var) == FAILURE)
4385 values.vnode = d->value;
4386 values.left = (d->value == NULL) ? 0 : d->value->repeat;
4388 if (traverse_data_var (d->var, &d->where) == FAILURE)
4391 /* At this point, we better not have any values left. */
4393 if (next_data_value () == SUCCESS)
4394 gfc_error ("DATA statement at %L has more values than variables",
4399 /* Determines if a variable is not 'pure', ie not assignable within a pure
4400 procedure. Returns zero if assignment is OK, nonzero if there is a problem.
4404 gfc_impure_variable (gfc_symbol * sym)
4406 if (sym->attr.use_assoc || sym->attr.in_common)
4409 if (sym->ns != gfc_current_ns)
4410 return !sym->attr.function;
4412 /* TODO: Check storage association through EQUIVALENCE statements */
4418 /* Test whether a symbol is pure or not. For a NULL pointer, checks the
4419 symbol of the current procedure. */
4422 gfc_pure (gfc_symbol * sym)
4424 symbol_attribute attr;
4427 sym = gfc_current_ns->proc_name;
4433 return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental);
4437 /* Test whether the current procedure is elemental or not. */
4440 gfc_elemental (gfc_symbol * sym)
4442 symbol_attribute attr;
4445 sym = gfc_current_ns->proc_name;
4450 return attr.flavor == FL_PROCEDURE && attr.elemental;
4454 /* Warn about unused labels. */
4457 warn_unused_label (gfc_namespace * ns)
4468 for (; l; l = l->prev)
4470 if (l->defined == ST_LABEL_UNKNOWN)
4473 switch (l->referenced)
4475 case ST_LABEL_UNKNOWN:
4476 gfc_warning ("Label %d at %L defined but not used", l->value,
4480 case ST_LABEL_BAD_TARGET:
4481 gfc_warning ("Label %d at %L defined but cannot be used", l->value,
4492 /* Resolve derived type EQUIVALENCE object. */
4495 resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
4498 gfc_component *c = derived->components;
4503 /* Shall not be an object of nonsequence derived type. */
4504 if (!derived->attr.sequence)
4506 gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
4507 "attribute to be an EQUIVALENCE object", sym->name, &e->where);
4511 for (; c ; c = c->next)
4514 if (d && (resolve_equivalence_derived (c->ts.derived, sym, e) == FAILURE))
4517 /* Shall not be an object of sequence derived type containing a pointer
4518 in the structure. */
4521 gfc_error ("Derived type variable '%s' at %L has pointer componet(s) "
4522 "cannot be an EQUIVALENCE object", sym->name, &e->where);
4530 /* Resolve equivalence object.
4531 An EQUIVALENCE object shall not be a dummy argument, a pointer, an
4532 allocatable array, an object of nonsequence derived type, an object of
4533 sequence derived type containing a pointer at any level of component
4534 selection, an automatic object, a function name, an entry name, a result
4535 name, a named constant, a structure component, or a subobject of any of
4536 the preceding objects. */
4539 resolve_equivalence (gfc_equiv *eq)
4542 gfc_symbol *derived;
4546 for (; eq; eq = eq->eq)
4549 if (gfc_resolve_expr (e) == FAILURE)
4552 sym = e->symtree->n.sym;
4554 /* Shall not be a dummy argument. */
4555 if (sym->attr.dummy)
4557 gfc_error ("Dummy argument '%s' at %L cannot be an EQUIVALENCE "
4558 "object", sym->name, &e->where);
4562 /* Shall not be an allocatable array. */
4563 if (sym->attr.allocatable)
4565 gfc_error ("Allocatable array '%s' at %L cannot be an EQUIVALENCE "
4566 "object", sym->name, &e->where);
4570 /* Shall not be a pointer. */
4571 if (sym->attr.pointer)
4573 gfc_error ("Pointer '%s' at %L cannot be an EQUIVALENCE object",
4574 sym->name, &e->where);
4578 /* Shall not be a function name, ... */
4579 if (sym->attr.function || sym->attr.result || sym->attr.entry
4580 || sym->attr.subroutine)
4582 gfc_error ("Entity '%s' at %L cannot be an EQUIVALENCE object",
4583 sym->name, &e->where);
4587 /* Shall not be a named constant. */
4588 if (e->expr_type == EXPR_CONSTANT)
4590 gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
4591 "object", sym->name, &e->where);
4595 derived = e->ts.derived;
4596 if (derived && resolve_equivalence_derived (derived, sym, e) == FAILURE)
4602 /* Shall not be an automatic array. */
4603 if (e->ref->type == REF_ARRAY
4604 && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
4606 gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
4607 "an EQUIVALENCE object", sym->name, &e->where);
4611 /* Shall not be a structure component. */
4615 if (r->type == REF_COMPONENT)
4617 gfc_error ("Structure component '%s' at %L cannot be an "
4618 "EQUIVALENCE object",
4619 r->u.c.component->name, &e->where);
4628 /* This function is called after a complete program unit has been compiled.
4629 Its purpose is to examine all of the expressions associated with a program
4630 unit, assign types to all intermediate expressions, make sure that all
4631 assignments are to compatible types and figure out which names refer to
4632 which functions or subroutines. */
4635 gfc_resolve (gfc_namespace * ns)
4637 gfc_namespace *old_ns, *n;
4642 old_ns = gfc_current_ns;
4643 gfc_current_ns = ns;
4645 resolve_entries (ns);
4647 resolve_contained_functions (ns);
4649 gfc_traverse_ns (ns, resolve_symbol);
4651 for (n = ns->contained; n; n = n->sibling)
4653 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
4654 gfc_error ("Contained procedure '%s' at %L of a PURE procedure must "
4655 "also be PURE", n->proc_name->name,
4656 &n->proc_name->declared_at);
4662 gfc_check_interfaces (ns);
4664 for (cl = ns->cl_list; cl; cl = cl->next)
4666 if (cl->length == NULL || gfc_resolve_expr (cl->length) == FAILURE)
4669 if (cl->length->ts.type != BT_INTEGER)
4671 ("Character length specification at %L must be of type INTEGER",
4672 &cl->length->where);
4675 gfc_traverse_ns (ns, resolve_values);
4681 for (d = ns->data; d; d = d->next)
4685 gfc_traverse_ns (ns, gfc_formalize_init_value);
4687 for (eq = ns->equiv; eq; eq = eq->next)
4688 resolve_equivalence (eq);
4691 resolve_code (ns->code, ns);
4693 /* Warn about unused labels. */
4694 if (gfc_option.warn_unused_labels)
4695 warn_unused_label (ns);
4697 gfc_current_ns = old_ns;